pax_global_header00006660000000000000000000000064124222714340014513gustar00rootroot0000000000000052 comment=8124395463d00b936d19bee630503690411eec8c gcl/000077500000000000000000000000001242227143400116245ustar00rootroot00000000000000gcl/AC_FD_CC000066400000000000000000000003241242227143400127470ustar00rootroot00000000000000#line 40 "configure" #include "confdefs.h" #include main() { char *b = (void *) malloc(1000); FILE *fp = fopen("conftest1","w"); fprintf(fp,"0x%x",((unsigned int) b) & ~0xffffff); fclose(fp); } gcl/AC_FD_MSG000066400000000000000000000000061242227143400131050ustar00rootroot00000000000000got 0 gcl/COPYING.LIB-2.0000077500000000000000000000612611242227143400135720ustar00rootroot00000000000000 GNU LIBRARY GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the library GPL. It is numbered 2 because it goes with version 2 of the ordinary GPL.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Library General Public License, applies to some specially designated Free Software Foundation software, and to any other libraries whose authors decide to use it. You can use it for your libraries, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library, or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link a program with the library, you must provide complete object files to the recipients so that they can relink them with the library, after making changes to the library and recompiling it. And you must show them these terms so they know their rights. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also compile or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. c) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. d) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. 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 not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Library 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 specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "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 LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY 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 LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! gcl/ChangeLog000077500000000000000000003551521242227143400134140ustar00rootroot000000000000002006-10-26 Gabriel Dos Reis * configure.in: Don't be overly eager about setting INFO_DIR. Fix quotations, as new Autoconf are pickier. * configure: Regenerate. 2002-01-25 Camm Maguire * /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/ChangeLog.orig: *** empty log message *** 2002-01-24 Camm Maguire * /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/sfaslelf.c: Get bfd initialization to bypass malloc * /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/sys_gcl.c, /cvsroot/gcl/gcl/lsp/defpackage.c, /cvsroot/gcl/gcl/lsp/defpackage.data, /cvsroot/gcl/gcl/lsp/defpackage.h, /cvsroot/gcl/gcl/lsp/defpackage.lsp, /cvsroot/gcl/gcl/lsp/make_defpackage.c, /cvsroot/gcl/gcl/lsp/make_defpackage.data, /cvsroot/gcl/gcl/lsp/make_defpackage.h, /cvsroot/gcl/gcl/lsp/make_defpackage.lsp, /cvsroot/gcl/gcl/lsp/makefile: Defpackage support 2002-01-23 Camm Maguire * /cvsroot/gcl/gcl/o/mingfile.c, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/h/minglacks.h, /cvsroot/gcl/gcl/h/mingw.h: Mingw support fixes 2002-01-20 Camm Maguire * /cvsroot/gcl/gcl/gcl.png: gif -> png for logo 2002-01-18 Camm Maguire * /cvsroot/gcl/gcl/lsp/destructuring_bind.c, /cvsroot/gcl/gcl/lsp/destructuring_bind.data, /cvsroot/gcl/gcl/lsp/destructuring_bind.h, /cvsroot/gcl/gcl/lsp/destructuring_bind.lsp, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/sys_gcl.c: Add support for destructuring-bind 2002-01-15 Camm Maguire * /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/o/unexnt.c: Changes to get a preliminary NT build 2002-01-13 Camm Maguire * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Emacs site list dir fix 2002-01-11 Camm Maguire * /cvsroot/gcl/gcl/cmpnew/lfun_list.lsp, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/lsp/stdlisp.lsp, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/new_init.c: Added (quit) and (exit) as synonyms to (bye) * /cvsroot/gcl/gcl/gmp/assert.c, /cvsroot/gcl/gcl/gmp/extract-dbl.c, /cvsroot/gcl/gcl/gmp/gmp-impl.h, /cvsroot/gcl/gcl/gmp/mpn/generic/gcdext.c, /cvsroot/gcl/gcl/gmp/mpn/generic/tdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpn/tests/addmul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/add_n.c, /cvsroot/gcl/gcl/gmp/mpn/tests/copy.c, /cvsroot/gcl/gcl/gmp/mpn/tests/divmod_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/divrem.c, /cvsroot/gcl/gcl/gmp/mpn/tests/lshift.c, /cvsroot/gcl/gcl/gmp/mpn/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/tests/mul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/rshift.c, /cvsroot/gcl/gcl/gmp/mpn/tests/submul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/sub_n.c, /cvsroot/gcl/gcl/gmp/mpz/bin_uiui.c, /cvsroot/gcl/gcl/gmp/mpz/fac_ui.c, /cvsroot/gcl/gcl/gmp/mpz/pprime_p.c, /cvsroot/gcl/gcl/gmp/mpz/root.c, /cvsroot/gcl/gcl/gmp/mpz/set_d.c, /cvsroot/gcl/gcl/gmp/mpz/tests/bit.c, /cvsroot/gcl/gcl/gmp/mpz/tests/convert.c, /cvsroot/gcl/gcl/gmp/mpz/tests/dive.c, /cvsroot/gcl/gcl/gmp/mpz/tests/io.c, /cvsroot/gcl/gcl/gmp/mpz/tests/logic.c, /cvsroot/gcl/gcl/gmp/mpz/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpz/tests/reuse.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-2exp.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-bin.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-fdiv.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-fdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-gcd.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-jac.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-misc.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-mul.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-powm.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-powm_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-pow_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-root.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-sqrtrem.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-tdiv.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-tdiv_ui.c, /cvsroot/gcl/gcl/gmp/randlc.c, /cvsroot/gcl/gcl/gmp/randraw.c, /cvsroot/gcl/gcl/gmp/urandom.h: Changes submitted by Robert Byer for VMS (thanks\!) 2002-01-10 Camm Maguire * /cvsroot/gcl/gcl/o/eval.c, /cvsroot/gcl/gcl/o/funlink.c, /cvsroot/gcl/gcl/h/object.h: Fix function definitions to be more portable, enables build on m68k 2002-01-09 Camm Maguire * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Need 'return 0' at end of tests for DBEGIN and CSTACK_ADDRESS for sparc * /cvsroot/gcl/gcl/info/makefile: Removed info files from tree, created now at build time from texi files 2002-01-08 Camm Maguire * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Better arm config support * /cvsroot/gcl/gcl/h/arm-linux.defs, /cvsroot/gcl/gcl/h/arm-linux.h, /cvsroot/gcl/gcl/h/m68k-linux.defs, /cvsroot/gcl/gcl/h/m68k-linux.h: New arm and m68k machine files * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Added configuration support for linux architectures 2002-01-07 Camm Maguire * /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/notcomp.h, /cvsroot/gcl/gcl/o/sfasl.c, /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/o/sfasli.c, /cvsroot/gcl/gcl/acconfig.h: BFD library support for relocations * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Changes to better detect tcl/tk locations * /cvsroot/gcl/gcl/h/386-linux.defs: Optimization flags by default in 386-linux.defs * /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-linux.defs, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/info/gcl-si.info, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/makefile: Removed some build-generated files 2002-01-06 Camm Maguire * /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/unexelf.c, /cvsroot/gcl/gcl/unixport/rsym_elf.c: Refinement to max stack size handling, better fix to unexelf section numbering bug, revert sigsetjmp change in rsym_elf.c * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: configure changes to detect newer as well as older tcl/tk libraries * /cvsroot/gcl/gcl/o/unexelf.c: Protect against sh_info=0, causing occasional segfaults, in unexelf.c 2002-01-04 Camm Maguire * /cvsroot/gcl/gcl/unixport/rsym_elf.c: _setjmp -> __sigsetjmp for glibc systems in rsym_elf.c * /cvsroot/gcl/gcl/o/main.c: Protect against unlimited stack resource environments * /cvsroot/gcl/gcl/unixport/rsym_elf.c: _setjmp -> __sigsetjmp for glibc systems in rsym_elf.c 2001-12-29 Camm Maguire * /cvsroot/gcl/gcl/ChangeLog: *** empty log message *** * /cvsroot/gcl/gcl/unixport/makefile: Added DESTDIR to makefiles to support installing under arbitrary subdir; good 'clean' targets; correct building in absense of tcl/tk * /cvsroot/gcl/gcl/gcl-tk/makefile: Add gcl-tk/demos/index.lsp to clean target * /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/makefile: Added DESTDIR to makefiles to support installing under arbitrary subdir; good 'clean' targets; correct building in absense of tcl/tk * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/elisp/makefile: changes to configure.in and elisp/makefile to handle emacs not being present * /cvsroot/gcl/gcl/gmp/ltconfig: fix to gmp/ltconfig to avoid exec'ing empty string * /cvsroot/gcl/gcl/gmp/configure, /cvsroot/gcl/gcl/gmp/configure.in: gmp/configure.in update for darwin * /cvsroot/gcl/gcl/gmp/ltconfig: fix to gmp/ltconfig to avoid exec'ing empty string * /cvsroot/gcl/gcl/gmp/configure, /cvsroot/gcl/gcl/gmp/configure.in: gmp/configure.in update for darwin 2001-12-21 Camm Maguire * /cvsroot/gcl/gcl/debian/changelog, /cvsroot/gcl/gcl/debian/control, /cvsroot/gcl/gcl/debian/emacsen-startup, /cvsroot/gcl/gcl/debian/gcl-doc.dirs, /cvsroot/gcl/gcl/debian/gcl-doc.doc-base.si, /cvsroot/gcl/gcl/debian/gcl-doc.doc-base.tk, /cvsroot/gcl/gcl/debian/rules, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/debian/copyright, /cvsroot/gcl/gcl/debian/emacsen-install, /cvsroot/gcl/gcl/debian/emacsen-remove, /cvsroot/gcl/gcl/debian/gcl.dirs, /cvsroot/gcl/gcl/debian/gcl-doc.doc-base, /cvsroot/gcl/gcl/debian/gcl-doc.docs, /cvsroot/gcl/gcl/debian/gcl-doc.files, /cvsroot/gcl/gcl/debian/gcl.files, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/info/texinfo.tex, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/man/man1/gcl.1, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/makefile: Many changes to get Debian package to build cleanly 2001-12-20 Camm Maguire * /cvsroot/gcl/gcl/ChangeLog: remove more build-generated files * /cvsroot/gcl/gcl/h/gnuwin95.h: Apply fopen patch * /cvsroot/gcl/gcl/debian/all-files, /cvsroot/gcl/gcl/debian/changelog, /cvsroot/gcl/gcl/debian/clean, /cvsroot/gcl/gcl/debian/control, /cvsroot/gcl/gcl/debian/control.withtk, /cvsroot/gcl/gcl/debian/copyright, /cvsroot/gcl/gcl/debian/dirs, /cvsroot/gcl/gcl/debian/docs, /cvsroot/gcl/gcl/debian/gcl-doc.info, /cvsroot/gcl/gcl/debian/gcl.substvars, /cvsroot/gcl/gcl/debian/manpages, /cvsroot/gcl/gcl/debian/postinst, /cvsroot/gcl/gcl/debian/rules, /cvsroot/gcl/gcl/debian/texi.awk: Initial upload of debian package building subdir * /cvsroot/gcl/gcl/tests/alltest.tst, /cvsroot/gcl/gcl/tests/array.tst, /cvsroot/gcl/gcl/tests/backquot.tst, /cvsroot/gcl/gcl/tests/characters.tst, /cvsroot/gcl/gcl/tests/eval20.tst, /cvsroot/gcl/gcl/tests/format.tst, /cvsroot/gcl/gcl/tests/GNU-GPL, /cvsroot/gcl/gcl/tests/hashlong.tst, /cvsroot/gcl/gcl/tests/hash.tst, /cvsroot/gcl/gcl/tests/iofkts.tst, /cvsroot/gcl/gcl/tests/lambda.tst, /cvsroot/gcl/gcl/tests/lists151.tst, /cvsroot/gcl/gcl/tests/lists152.tst, /cvsroot/gcl/gcl/tests/lists153.tst, /cvsroot/gcl/gcl/tests/lists154.tst, /cvsroot/gcl/gcl/tests/lists155.tst, /cvsroot/gcl/gcl/tests/lists156.tst, /cvsroot/gcl/gcl/tests/macro8.tst, /cvsroot/gcl/gcl/tests/Makefile, /cvsroot/gcl/gcl/tests/map.tst, /cvsroot/gcl/gcl/tests/number.tst, /cvsroot/gcl/gcl/tests/pack11.tst, /cvsroot/gcl/gcl/tests/path.tst, /cvsroot/gcl/gcl/tests/README, /cvsroot/gcl/gcl/tests/readtable.tst, /cvsroot/gcl/gcl/tests/setf.tst, /cvsroot/gcl/gcl/tests/steele7.tst, /cvsroot/gcl/gcl/tests/streamslong.tst, /cvsroot/gcl/gcl/tests/streams.tst, /cvsroot/gcl/gcl/tests/strings.tst, /cvsroot/gcl/gcl/tests/symbol10.tst, /cvsroot/gcl/gcl/tests/symbols.tst, /cvsroot/gcl/gcl/tests/tests.lsp, /cvsroot/gcl/gcl/tests/tprint.tst, /cvsroot/gcl/gcl/tests/tread.tst, /cvsroot/gcl/gcl/tests/type.tst: Initial upload of cltl1 tests used by clisp -- needs #+ and #- for gcl * /cvsroot/gcl/gcl/makefile: Make distclean on gmp non-fatal * /cvsroot/gcl/gcl/info/compile.texi, /cvsroot/gcl/gcl/info/io.texi, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/info/number.texi, /cvsroot/gcl/gcl/info/sequence.texi, /cvsroot/gcl/gcl/info/si-defs.texi: Clean target for docs, build all docs, fix texinfo errors * /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/makefile: Got clean targets working so as not to leave any non-CVS files in tree after build (and clean) * /cvsroot/gcl/gcl/makefile: Fixed makefile to build without tcl/tk if not found in configure * /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-linux.defs, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/lsp/readline.c, /cvsroot/gcl/gcl/lsp/readline.data, /cvsroot/gcl/gcl/lsp/readline.h, /cvsroot/gcl/gcl/lsp/readline.lsp, /cvsroot/gcl/gcl/lsp/serror.c, /cvsroot/gcl/gcl/lsp/serror.data, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/readline.d, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/acconfig.h, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/makedefc.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/minvers: Integrated dynamic readline support, activated at runtime with (si::init-readline) 2001-12-19 Camm Maguire * /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/makefile: Merge bugfixes from current 2001-12-18 Camm Maguire * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: FCNTL check opens bad file 'jim', now opens configure.in read-only * /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/fasldlsym.c, /cvsroot/gcl/gcl/o/fat_string.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/symbol.d, /cvsroot/gcl/gcl/o/try.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/unixport/tryserv.tcl, /cvsroot/gcl/gcl/bin/append.c, /cvsroot/gcl/gcl/bin/dpp.c, /cvsroot/gcl/gcl/bin/file-sub.c, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/elisp/smart-complete.el, /cvsroot/gcl/gcl/gcl-tk/decode.tcl, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in.interp, /cvsroot/gcl/gcl/gcl-tk/ngcltksrv, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/h/coff/i386.h, /cvsroot/gcl/gcl/h/cyglacks.h, /cvsroot/gcl/gcl/h/gnuwin95.defs, /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/h/num_include.h, /cvsroot/gcl/gcl/info/control.texi, /cvsroot/gcl/gcl/info/gcl-si.texi, /cvsroot/gcl/gcl/makdefs, /cvsroot/gcl/gcl/readme.mingw: Merge current bugfixes into 2.5.0 * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: s/cygwin32/ cygwin\*/ in configure * /cvsroot/gcl/gcl/h/gnuwin95.defs: Tidy up h/gnuwin95.defs * /cvsroot/gcl/gcl/h/cyglacks.h: Remove cruft from h/cyglacks.h * /cvsroot/gcl/gcl/h/gnuwin95.h: Tidy up h/gnuwin95.defs * /cvsroot/gcl/gcl/h/coff/i386.h: Remove cruft from h/coff/i386.h * /cvsroot/gcl/gcl/o/print.d: Prototype definition for coerce_stream * /cvsroot/gcl/gcl/o/fat_string.c: Compiler warning cleanup, strings end with char 0, not NULL * /cvsroot/gcl/gcl/info/control.texi, /cvsroot/gcl/gcl/info/gcl-si.texi: Minor changes to .texi files to compile cleanly on standard texinfo installations * /cvsroot/gcl/gcl/h/num_include.h: Clear up a compiler warning with MOST_NEGATIVE_FIX * /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in.interp, /cvsroot/gcl/gcl/gcl-tk/ngcltksrv: Remove version dependence on wish in shell scripts -- if need a dependency, will put in configure later * /cvsroot/gcl/gcl/elisp/smart-complete.el: Rename split-string to split-string-gcl to avoid name conflicts with other elisp packages * /cvsroot/gcl/gcl/bin/dpp.c, /cvsroot/gcl/gcl/bin/file-sub.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/fasldlsym.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/symbol.d, /cvsroot/gcl/gcl/o/unixfsys.c: Added missing headers for str... and exit standard functions * /cvsroot/gcl/gcl/bin/append.c, /cvsroot/gcl/gcl/gcl-tk/decode.tcl, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/h/cyglacks.h, /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/try.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/unixport/tryserv.tcl, /cvsroot/gcl/gcl/makdefs, /cvsroot/gcl/gcl/readme.mingw: Removed CR from all compilable files; removed one useless file 2001-12-17 Camm Maguire * /cvsroot/gcl/gcl/config.guess, /cvsroot/gcl/gcl/config.sub: New versions of config.sub and config.guess 2001-12-16 Camm Maguire * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Allow setting compiler in CC env variable * /cvsroot/gcl/gcl/h/compbas2.h, /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/file.d: Commented labels at end of #endifs * /cvsroot/gcl/gcl/h/ptable.h: removed carriage returns 2001-12-15 Camm Maguire * /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/submul_1.S, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/supersparc/udiv.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/k62mmx/copyd.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/k62mmx/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/k62mmx/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/k62mmx/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/com_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/logops_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/copyd.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/divrem_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/mod_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/mmx/divrem_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/mmx/mod_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/p3mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mmx/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mmx/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mmx/rshift.asm, /cvsroot/gcl/gcl/gmp/mpbsd/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpfr/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpf/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev5/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev5/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev5/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev5/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev6/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev6/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/udiv_qrnnd.S, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/umul.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa2_0/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa2_0/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/mul_1.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/submul_1.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/udiv.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/umul.S, /cvsroot/gcl/gcl/gmp/mpn/m88k/mc88110/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/m88k/mc88110/add_n.S, /cvsroot/gcl/gcl/gmp/mpn/m88k/mc88110/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/m88k/mc88110/sub_n.S, /cvsroot/gcl/gcl/gmp/mpn/sh/sh2/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/sh/sh2/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/sh/sh2/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/README, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/aors_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/cross.pl, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mul_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/README, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/sqr_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/aors_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mul_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/README, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/sqr_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/README, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/sqr_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/aors_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mul_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/README, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/sqr_basecase.asm, /cvsroot/gcl/gcl/gmp/mpq/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/tests/rand/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/tests/submul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/sub_n.c, /cvsroot/gcl/gcl/gmp/mpn/tests/trace.c, /cvsroot/gcl/gcl/gmp/mpn/tests/try.c, /cvsroot/gcl/gcl/gmp/mpn/tests/try.h, /cvsroot/gcl/gcl/gmp/mpn/tests/tst-addsub.c, /cvsroot/gcl/gcl/gmp/mpn/tests/x86call.asm, /cvsroot/gcl/gcl/gmp/mpn/tests/x86check.c, /cvsroot/gcl/gcl/gmp/mpn/thumb/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/thumb/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/vax/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/vax/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/vax/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/vax/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/vax/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/vax/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/vax/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/x86/addsub_n.S, /cvsroot/gcl/gcl/gmp/mpn/x86/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/aors_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/copyd.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/divrem_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/mod_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/mul_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/README, /cvsroot/gcl/gcl/gmp/mpn/x86/README.family, /cvsroot/gcl/gcl/gmp/mpn/x86/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/udiv.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/x86-defs.m4, /cvsroot/gcl/gcl/gmp/mpn/z8000/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/z8000/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/z8000/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/z8000/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/z8000x/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/z8000x/sub_n.s, /cvsroot/gcl/gcl/gmp/mpq/Makefile.in, /cvsroot/gcl/gcl/gmp/mpz/tests/bit.c, /cvsroot/gcl/gcl/gmp/mpz/tests/convert.c, /cvsroot/gcl/gcl/gmp/mpz/tests/dive.c, /cvsroot/gcl/gcl/gmp/mpz/tests/io.c, /cvsroot/gcl/gcl/gmp/mpz/tests/logic.c, /cvsroot/gcl/gcl/gmp/mpz/tests/Makefile.am, /cvsroot/gcl/gcl/gmp/mpz/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpz/tests/reuse.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-2exp.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-bin.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-fdiv.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-fdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-gcd.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-jac.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-misc.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-mul.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-powm.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-powm_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-pow_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-root.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-sqrtrem.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-tdiv.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-tdiv_ui.c, /cvsroot/gcl/gcl/gmp/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/tune/Makefile.in, /cvsroot/gcl/gcl/gmp/demos/Makefile.in, /cvsroot/gcl/gcl/gmp/macos/Makefile.in, /cvsroot/gcl/gcl/gmp/mpbsd/Makefile.in, /cvsroot/gcl/gcl/gmp/mpf/Makefile.in, /cvsroot/gcl/gcl/gmp/mpfr/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/a29k/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/udiv.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/umul.s, /cvsroot/gcl/gcl/gmp/mpn/alpha/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/cntlz.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/default.m4, /cvsroot/gcl/gcl/gmp/mpn/alpha/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/alpha/invert_limb.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/README, /cvsroot/gcl/gcl/gmp/mpn/alpha/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/udiv_qrnnd.S, /cvsroot/gcl/gcl/gmp/mpn/alpha/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/unicos.m4, /cvsroot/gcl/gcl/gmp/mpn/arm/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/arm/add_n.S, /cvsroot/gcl/gcl/gmp/mpn/arm/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/arm/mul_1.S, /cvsroot/gcl/gcl/gmp/mpn/arm/sub_n.S, /cvsroot/gcl/gcl/gmp/mpn/clipper/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/clipper/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/clipper/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/cray/addmul_1.c, /cvsroot/gcl/gcl/gmp/mpn/cray/add_n.c, /cvsroot/gcl/gcl/gmp/mpn/cray/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/cray/mul_1.c, /cvsroot/gcl/gcl/gmp/mpn/cray/mulww.f, /cvsroot/gcl/gcl/gmp/mpn/cray/mulww.s, /cvsroot/gcl/gcl/gmp/mpn/cray/README, /cvsroot/gcl/gcl/gmp/mpn/cray/submul_1.c, /cvsroot/gcl/gcl/gmp/mpn/cray/sub_n.c, /cvsroot/gcl/gcl/gmp/mpn/hppa/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/hppa/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/README, /cvsroot/gcl/gcl/gmp/mpn/hppa/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/udiv_qrnnd.s, /cvsroot/gcl/gcl/gmp/mpn/i960/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/i960/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/i960/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/i960/README, /cvsroot/gcl/gcl/gmp/mpn/i960/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/lisp/gmpasm-mode.el, /cvsroot/gcl/gcl/gmp/mpn/m68k/add_n.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/lshift.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/rshift.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/sub_n.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/syntax.h, /cvsroot/gcl/gcl/gmp/mpn/m88k/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/m88k/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/m88k/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/umul.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/mips3/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/README, /cvsroot/gcl/gcl/gmp/mpn/mips3/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/pa64/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/mul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64/README, /cvsroot/gcl/gcl/gmp/mpn/pa64/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/submul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/udiv_qrnnd.c, /cvsroot/gcl/gcl/gmp/mpn/pa64/umul_ppmm.S, /cvsroot/gcl/gcl/gmp/mpn/pa64w/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64w/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64w/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/pa64w/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/pa64w/mul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64w/README, /cvsroot/gcl/gcl/gmp/mpn/pa64w/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/pa64w/submul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64w/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64w/udiv_qrnnd.c, /cvsroot/gcl/gcl/gmp/mpn/pa64w/umul_ppmm.S, /cvsroot/gcl/gcl/gmp/mpn/power/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/power/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/power/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/power/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/aix.m4, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/regmap.m4, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/addsub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/aix.m4, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/copyd.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/README, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/power/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/power/sdiv.s, /cvsroot/gcl/gcl/gmp/mpn/power/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/power/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/power/umul.s, /cvsroot/gcl/gcl/gmp/mpn/pyr/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/pyr/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/pyr/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/pyr/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/sh/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/sh/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/sparc32/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/README, /cvsroot/gcl/gcl/gmp/mpn/sparc32/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/udiv_fp.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/udiv_nfp.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/addmul1h.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/sparc64/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/mul_1h.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/README, /cvsroot/gcl/gcl/gmp/mpn/sparc64/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/submul1h.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/tests/addmul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/add_n.c, /cvsroot/gcl/gcl/gmp/mpn/tests/copy.c, /cvsroot/gcl/gcl/gmp/mpn/tests/divmod_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/divrem.c, /cvsroot/gcl/gcl/gmp/mpn/tests/lshift.c, /cvsroot/gcl/gcl/gmp/mpn/tests/Makefile.am, /cvsroot/gcl/gcl/gmp/mpn/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/tests/mul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/README, /cvsroot/gcl/gcl/gmp/mpn/tests/ref.c, /cvsroot/gcl/gcl/gmp/mpn/tests/ref.h, /cvsroot/gcl/gcl/gmp/mpn/tests/rshift.c, /cvsroot/gcl/gcl/gmp/mpn/tests/spinner.c, /cvsroot/gcl/gcl/gmp/ansi2knr.c, /cvsroot/gcl/gcl/gmp/configure.in, /cvsroot/gcl/gcl/gmp/mpn/asm-defs.m4, /cvsroot/gcl/gcl/gmp/mpn/generic/addmul_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/add_n.c, /cvsroot/gcl/gcl/gmp/mpn/generic/addsub_n.c, /cvsroot/gcl/gcl/gmp/mpn/generic/bdivmod.c, /cvsroot/gcl/gcl/gmp/mpn/generic/bz_divrem_n.c, /cvsroot/gcl/gcl/gmp/mpn/generic/cmp.c, /cvsroot/gcl/gcl/gmp/mpn/generic/diveby3.c, /cvsroot/gcl/gcl/gmp/mpn/generic/divrem_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/divrem_2.c, /cvsroot/gcl/gcl/gmp/mpn/generic/divrem.c, /cvsroot/gcl/gcl/gmp/mpn/generic/dump.c, /cvsroot/gcl/gcl/gmp/mpn/generic/gcd_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/gcd.c, /cvsroot/gcl/gcl/gmp/mpn/generic/gcdext.c, /cvsroot/gcl/gcl/gmp/mpn/generic/get_str.c, /cvsroot/gcl/gcl/gmp/mpn/generic/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/generic/hamdist.c, /cvsroot/gcl/gcl/gmp/mpn/generic/inlines.c, /cvsroot/gcl/gcl/gmp/mpn/generic/jacbase.c, /cvsroot/gcl/gcl/gmp/mpn/generic/lshift.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mod_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mod_1_rs.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mul_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mul_basecase.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mul.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mul_fft.c, /cvsroot/gcl/gcl/gmp/mpn/generic/perfsqr.c, /cvsroot/gcl/gcl/gmp/mpn/generic/popcount.c, /cvsroot/gcl/gcl/gmp/mpn/generic/pre_mod_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/random2.c, /cvsroot/gcl/gcl/gmp/mpn/generic/random.c, /cvsroot/gcl/gcl/gmp/mpn/generic/rshift.c, /cvsroot/gcl/gcl/gmp/mpn/generic/sb_divrem_mn.c, /cvsroot/gcl/gcl/gmp/mpn/generic/scan0.c, /cvsroot/gcl/gcl/gmp/mpn/generic/scan1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/set_str.c, /cvsroot/gcl/gcl/gmp/mpn/generic/sqr_basecase.c, /cvsroot/gcl/gcl/gmp/mpn/generic/sqrtrem.c, /cvsroot/gcl/gcl/gmp/mpn/generic/submul_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/sub_n.c, /cvsroot/gcl/gcl/gmp/mpn/generic/tdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpn/generic/udiv_w_sdiv.c, /cvsroot/gcl/gcl/gmp/mpn/Makefile.am, /cvsroot/gcl/gcl/gmp/mpn/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/mp_bases.c, /cvsroot/gcl/gcl/gmp/mpn/README, /cvsroot/gcl/gcl/gmp/mpz/abs.c, /cvsroot/gcl/gcl/gmp/mpz/add.c, /cvsroot/gcl/gcl/gmp/mpz/addmul_ui.c, /cvsroot/gcl/gcl/gmp/mpz/add_ui.c, /cvsroot/gcl/gcl/gmp/mpz/and.c, /cvsroot/gcl/gcl/gmp/mpz/array_init.c, /cvsroot/gcl/gcl/gmp/mpz/bin_ui.c, /cvsroot/gcl/gcl/gmp/mpz/bin_uiui.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_q.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_qr_ui.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_q_ui.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_r.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_r_ui.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/clear.c, /cvsroot/gcl/gcl/gmp/mpz/clrbit.c, /cvsroot/gcl/gcl/gmp/mpz/cmpabs.c, /cvsroot/gcl/gcl/gmp/mpz/cmpabs_ui.c, /cvsroot/gcl/gcl/gmp/mpz/cmp.c, /cvsroot/gcl/gcl/gmp/mpz/cmp_si.c, /cvsroot/gcl/gcl/gmp/mpz/cmp_ui.c, /cvsroot/gcl/gcl/gmp/mpz/com.c, /cvsroot/gcl/gcl/gmp/mpz/divexact.c, /cvsroot/gcl/gcl/gmp/mpz/dump.c, /cvsroot/gcl/gcl/gmp/mpz/fac_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_q_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_q.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_qr_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_q_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_r.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_r_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fib_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fits_sint_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_slong_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_sshort_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_uint_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_ulong_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_ushort_p.c, /cvsroot/gcl/gcl/gmp/mpz/gcdext.c, /cvsroot/gcl/gcl/gmp/mpz/gcd_ui.c, /cvsroot/gcl/gcl/gmp/mpz/get_d.c, /cvsroot/gcl/gcl/gmp/mpz/getlimbn.c, /cvsroot/gcl/gcl/gmp/mpz/get_si.c, /cvsroot/gcl/gcl/gmp/mpz/get_str.c, /cvsroot/gcl/gcl/gmp/mpz/get_ui.c, /cvsroot/gcl/gcl/gmp/mpz/hamdist.c, /cvsroot/gcl/gcl/gmp/mpz/init.c, /cvsroot/gcl/gcl/gmp/mpz/inp_raw.c, /cvsroot/gcl/gcl/gmp/mpz/inp_str.c, /cvsroot/gcl/gcl/gmp/mpz/invert.c, /cvsroot/gcl/gcl/gmp/mpz/ior.c, /cvsroot/gcl/gcl/gmp/mpz/iset.c, /cvsroot/gcl/gcl/gmp/mpz/iset_d.c, /cvsroot/gcl/gcl/gmp/mpz/iset_si.c, /cvsroot/gcl/gcl/gmp/mpz/iset_str.c, /cvsroot/gcl/gcl/gmp/mpz/iset_ui.c, /cvsroot/gcl/gcl/gmp/mpz/jacobi.c, /cvsroot/gcl/gcl/gmp/mpz/kronsz.c, /cvsroot/gcl/gcl/gmp/mpz/kronuz.c, /cvsroot/gcl/gcl/gmp/mpz/kronzs.c, /cvsroot/gcl/gcl/gmp/mpz/kronzu.c, /cvsroot/gcl/gcl/gmp/mpz/lcm.c, /cvsroot/gcl/gcl/gmp/mpz/legendre.c, /cvsroot/gcl/gcl/gmp/mpz/Makefile.am, /cvsroot/gcl/gcl/gmp/mpz/Makefile.in, /cvsroot/gcl/gcl/gmp/mpz/mod.c, /cvsroot/gcl/gcl/gmp/mpz/mul_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/mul_siui.c, /cvsroot/gcl/gcl/gmp/mpz/neg.c, /cvsroot/gcl/gcl/gmp/mpz/nextprime.c, /cvsroot/gcl/gcl/gmp/mpz/out_raw.c, /cvsroot/gcl/gcl/gmp/mpz/out_str.c, /cvsroot/gcl/gcl/gmp/mpz/perfpow.c, /cvsroot/gcl/gcl/gmp/mpz/perfsqr.c, /cvsroot/gcl/gcl/gmp/mpz/popcount.c, /cvsroot/gcl/gcl/gmp/mpz/powm.c, /cvsroot/gcl/gcl/gmp/mpz/powm_ui.c, /cvsroot/gcl/gcl/gmp/mpz/pow_ui.c, /cvsroot/gcl/gcl/gmp/mpz/pprime_p.c, /cvsroot/gcl/gcl/gmp/mpz/random2.c, /cvsroot/gcl/gcl/gmp/mpz/random.c, /cvsroot/gcl/gcl/gmp/mpz/README, /cvsroot/gcl/gcl/gmp/mpz/realloc.c, /cvsroot/gcl/gcl/gmp/mpz/remove.c, /cvsroot/gcl/gcl/gmp/mpz/root.c, /cvsroot/gcl/gcl/gmp/mpz/rrandomb.c, /cvsroot/gcl/gcl/gmp/mpz/scan0.c, /cvsroot/gcl/gcl/gmp/mpz/scan1.c, /cvsroot/gcl/gcl/gmp/mpz/setbit.c, /cvsroot/gcl/gcl/gmp/mpz/set.c, /cvsroot/gcl/gcl/gmp/mpz/set_d.c, /cvsroot/gcl/gcl/gmp/mpz/set_f.c, /cvsroot/gcl/gcl/gmp/mpz/set_q.c, /cvsroot/gcl/gcl/gmp/mpz/set_si.c, /cvsroot/gcl/gcl/gmp/mpz/set_str.c, /cvsroot/gcl/gcl/gmp/mpz/set_ui.c, /cvsroot/gcl/gcl/gmp/mpz/size.c, /cvsroot/gcl/gcl/gmp/mpz/sizeinbase.c, /cvsroot/gcl/gcl/gmp/mpz/sqrt.c, /cvsroot/gcl/gcl/gmp/mpz/sqrtrem.c, /cvsroot/gcl/gcl/gmp/mpz/sub.c, /cvsroot/gcl/gcl/gmp/mpz/sub_ui.c, /cvsroot/gcl/gcl/gmp/mpz/swap.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_q_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_q.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_qr_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_q_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_r_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_r.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_r_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tstbit.c, /cvsroot/gcl/gcl/gmp/mpz/ui_pow_ui.c, /cvsroot/gcl/gcl/gmp/mpz/urandomb.c, /cvsroot/gcl/gcl/gmp/mpz/urandomm.c, /cvsroot/gcl/gcl/gmp/mpz/xor.c: Complete file additions for gmp configure and build * /cvsroot/gcl/gcl/gmp/ansi2knr.c, /cvsroot/gcl/gcl/gmp/assert.c, /cvsroot/gcl/gcl/gmp/compat.c, /cvsroot/gcl/gcl/gmp/config.guess, /cvsroot/gcl/gcl/gmp/config.in, /cvsroot/gcl/gcl/gmp/config.sub, /cvsroot/gcl/gcl/gmp/configure, /cvsroot/gcl/gcl/gmp/configure.in, /cvsroot/gcl/gcl/gmp/COPYING, /cvsroot/gcl/gcl/gmp/errno.c, /cvsroot/gcl/gcl/gmp/extract-dbl.c, /cvsroot/gcl/gcl/gmp/gmp.h, /cvsroot/gcl/gcl/gmp/gmp-impl.h, /cvsroot/gcl/gcl/gmp/insert-dbl.c, /cvsroot/gcl/gcl/gmp/install-sh, /cvsroot/gcl/gcl/gmp/longlong.h, /cvsroot/gcl/gcl/gmp/ltconfig, /cvsroot/gcl/gcl/gmp/ltmain.sh, /cvsroot/gcl/gcl/gmp/Makefile.in, /cvsroot/gcl/gcl/gmp/memory.c, /cvsroot/gcl/gcl/gmp/missing, /cvsroot/gcl/gcl/gmp/mp_bpl.c, /cvsroot/gcl/gcl/gmp/mp_clz_tab.c, /cvsroot/gcl/gcl/gmp/mp.h, /cvsroot/gcl/gcl/gmp/mp_minv_tab.c, /cvsroot/gcl/gcl/gmp/mp_set_fns.c, /cvsroot/gcl/gcl/gmp/rand.c, /cvsroot/gcl/gcl/gmp/randclr.c, /cvsroot/gcl/gcl/gmp/randlc2x.c, /cvsroot/gcl/gcl/gmp/randlc.c, /cvsroot/gcl/gcl/gmp/randraw.c, /cvsroot/gcl/gcl/gmp/randsd.c, /cvsroot/gcl/gcl/gmp/randsdui.c, /cvsroot/gcl/gcl/gmp/README, /cvsroot/gcl/gcl/gmp/stack-alloc.c, /cvsroot/gcl/gcl/gmp/stack-alloc.h, /cvsroot/gcl/gcl/gmp/urandom.h, /cvsroot/gcl/gcl/gmp/version.c: gmp configure and build restoration * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Run emacs with --no-site-file to avoid errors; default ix86 gmp target is i486 * /cvsroot/gcl/gcl/h/gmp.h: Link needed to get gmp bignums working with new gmp_big.c file * /cvsroot/gcl/gcl/h/386-linux.h: Patch submitted via email months ago by Dr. Schelter to enable reliable dynamic linking on i386 Linux 2001-07-03 wfs * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/h/gclincl.h: fix to configure 2001-06-06 wfs * /cvsroot/gcl/gcl/lsp/info.data, /cvsroot/gcl/gcl/lsp/info.lsp: fix info to handle defunx 2001-05-18 wfs * /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/o/gmp_big.c, /cvsroot/gcl/gcl/o/gmp.c, /cvsroot/gcl/gcl/o/gmp_num_log.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/pari_big.c, /cvsroot/gcl/gcl/o/pari_num_log.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/elisp/gcl.el, /cvsroot/gcl/gcl/h/mp.h: changes for bignum code, now relocatable bignums ok, worked around bug in gmp code which does not detect 0 as fitting in an int 2001-05-16 wfs * /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/mp.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/fat_string.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/makefile: changes for gmp 2001-05-15 wfs * /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/num_log.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/cmpnew/cmpopt.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/makefile: fix to ash, and for buggy redhat/cygnus compiler 2001-05-11 wfs * /cvsroot/gcl/gcl/readme.gmp, /cvsroot/gcl/gcl/readme.mingw, /cvsroot/gcl/gcl/unixport/init_gcl.lsp: fix the error code on compile from command line 2001-05-06 wfs * /cvsroot/gcl/gcl/gmp/mpn/generic/mul_n.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_r_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/gcd.c, /cvsroot/gcl/gcl/gmp/mpz/mul.c: changes to gmp from 3.1.1 for gcl * /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/cmpopt.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/dbl.el, /cvsroot/gcl/gcl/elisp/gcl.el, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/elisp/smart-complete.el, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gmp/mpn/generic/mul_n.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_r_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/gcd.c, /cvsroot/gcl/gcl/gmp/mpz/mul.c, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/att_ext.h, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/cmponly.h, /cvsroot/gcl/gcl/h/compbas2.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/include.h, /cvsroot/gcl/gcl/h/mdefs.h, /cvsroot/gcl/gcl/h/mp.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/minvers, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/cmac.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/fasdump.c, /cvsroot/gcl/gcl/o/gbc.c, /cvsroot/gcl/gcl/o/hash.d, /cvsroot/gcl/gcl/o/init_pari.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/num_arith.c, /cvsroot/gcl/gcl/o/number.c, /cvsroot/gcl/gcl/o/num_log.c, /cvsroot/gcl/gcl/o/num_pred.c, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/sgbc.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/o/usig2_aux.c, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/xbin/new-files: many changes adding gmp bignums 2001-04-17 wfs * /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/lsp/debug.c, /cvsroot/gcl/gcl/lsp/debug.data, /cvsroot/gcl/gcl/lsp/debug.h, /cvsroot/gcl/gcl/lsp/debug.lsp, /cvsroot/gcl/gcl/lsp/top.c, /cvsroot/gcl/gcl/lsp/top.data, /cvsroot/gcl/gcl/lsp/top.h, /cvsroot/gcl/gcl/lsp/top.lsp, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/new_init.c: minor change to break-call * /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/h/mingw.defs, /cvsroot/gcl/gcl/h/mingw.h, /cvsroot/gcl/gcl/lsp/autoload.lsp, /cvsroot/gcl/gcl/lsp/debug.lsp: removed the o/*.ini files since these are generated automatically. fixed things in h/mingw.{h,defs}, made o/sfaslelf.c so it can load things compiled under -O4 (since init_ is searched for), repaired rsym_nt.c for mingw port 2001-04-13 wfs * /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/notcomp.h: changes for clisp, and to sysdef 2001-03-22 wfs * /cvsroot/gcl/gcl/lsp/evalmacros.c, /cvsroot/gcl/gcl/lsp/evalmacros.data, /cvsroot/gcl/gcl/lsp/evalmacros.h, /cvsroot/gcl/gcl/lsp/evalmacros.lsp, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/unexelf.c: Fix the unexelf to make the data section executable 2001-02-24 wfs * /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/gcl-tk/guis.c, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/notcomp.h, /cvsroot/gcl/gcl/h/OpenBSD.defs, /cvsroot/gcl/gcl/h/OpenBSD.h, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/unexec.c, /cvsroot/gcl/gcl/xbin/new-files: fix for debian, for stdout corruption after save 2000-12-09 wfs * /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/add-defs, /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/file-sub.c, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/bin/winkill.c, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/dbl.el, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/coff/i386.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/h/mingw.defs, /cvsroot/gcl/gcl/h/mingw.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/h/wincoff.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/info.c, /cvsroot/gcl/gcl/lsp/info.lsp, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/lsp/top.c, /cvsroot/gcl/gcl/lsp/top.data, /cvsroot/gcl/gcl/lsp/top.h, /cvsroot/gcl/gcl/lsp/top.lsp, /cvsroot/gcl/gcl/makedefc.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/minvers, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/mingwin.c, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/nsocket.c, /cvsroot/gcl/gcl/o/pathname.d, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/save.c, /cvsroot/gcl/gcl/o/sockets.c, /cvsroot/gcl/gcl/o/tclwinkill.c, /cvsroot/gcl/gcl/o/unexnt.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/o/unixfsys.ini, /cvsroot/gcl/gcl/o/unixtime.c, /cvsroot/gcl/gcl/o/usig2.c, /cvsroot/gcl/gcl/o/usig.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/xbin/386-linux-fix: many changes for xmaxima and for windows 2000-10-28 wfs * /cvsroot/gcl/gcl/xbin/386-linux-fix: changes for redhat 7.0 2000-10-27 wfs * /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/bsd.h, /cvsroot/gcl/gcl/h/sparc-linux.h, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/configure.in: changes for close_stream, and to configure for redhat 7.0 * /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/elisp/sshell.el, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/makefile: abort() is void so fixed BV_OFFSET macro 2000-06-27 wfs * /cvsroot/gcl/gcl/info/io.texi, /cvsroot/gcl/gcl/o/file.d: allow open of a file '| command' to open a pipe 2000-06-26 wfs * /cvsroot/gcl/gcl/lsp/export.lsp, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/read.d: change parse_number to do bignums much faster 2000-06-15 wfs * /cvsroot/gcl/gcl/configure.in: fixes to configure 2000-06-13 wfs * /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/unixport/init_maxima.lsp: fix info compilation in makefile 2000-06-04 wfs * /cvsroot/gcl/gcl/o/pathname.d: fix so make-pathname when given an :type nil makes the type nil independent of the default * /cvsroot/gcl/gcl/lsp/sloop.c, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/macros.ini, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/number.ini, /cvsroot/gcl/gcl/o/package.ini, /cvsroot/gcl/gcl/o/predicate.ini, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/structure.ini, /cvsroot/gcl/gcl/o/toplevel.ini, /cvsroot/gcl/gcl/o/typespec.ini, /cvsroot/gcl/gcl/o/unixsys.ini, /cvsroot/gcl/gcl/o/usig.ini, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/cmplam.c, /cvsroot/gcl/gcl/cmpnew/cmptype.c, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/makefile: change the # syntax for pathnames to be #p 2000-05-25 wfs * /cvsroot/gcl/gcl/minvers: fix version to 3.6 * /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/configure: update configure from configure.in 2000-05-16 wfs * /cvsroot/gcl/gcl/h/386-linux.defs: remove the -static declaration for the link 2000-05-15 wfs * /cvsroot/gcl/gcl/readme, /cvsroot/gcl/gcl/makefile: fix some cosmetic and documentation items 2000-05-15 mzou * /cvsroot/gcl/gcl/ChangeLog: *** empty log message *** 2000-05-13 wfs * /cvsroot/gcl/gcl/xbin/distribute, /cvsroot/gcl/gcl/xbin/new-files: fix xbin/distribute * /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/unixport/rsym_elf.c, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/mp/mpi-sol-sparc.s, /cvsroot/gcl/gcl/o/cmac.c, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/earith.c, /cvsroot/gcl/gcl/o/earith.ini, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/makedefs.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/readme: bring cvs tree up to date with my development tree * /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/readme: some cosmetic and readme changes 1999-12-06 wfs * /cvsroot/gcl/gcl/ChangeLog: *** empty log message *** * /cvsroot/gcl/gcl/utils/replace, /cvsroot/gcl/gcl/utils/repls1.sed, /cvsroot/gcl/gcl/utils/repls2.sed, /cvsroot/gcl/gcl/utils/repls3.sed, /cvsroot/gcl/gcl/utils/repls4.sed, /cvsroot/gcl/gcl/utils/repls5.sed, /cvsroot/gcl/gcl/utils/revstruct.sed, /cvsroot/gcl/gcl/xbin/add-dir, /cvsroot/gcl/gcl/xbin/append, /cvsroot/gcl/gcl/xbin/append.bat, /cvsroot/gcl/gcl/xbin/compare.c, /cvsroot/gcl/gcl/xbin/compare-src, /cvsroot/gcl/gcl/xbin/comp_rel, /cvsroot/gcl/gcl/xbin/dfiles, /cvsroot/gcl/gcl/xbin/distrib-help, /cvsroot/gcl/gcl/xbin/distribute, /cvsroot/gcl/gcl/xbin/dos-files, /cvsroot/gcl/gcl/xbin/dosmake.bat, /cvsroot/gcl/gcl/xbin/exists, /cvsroot/gcl/gcl/xbin/file-sub, /cvsroot/gcl/gcl/xbin/fix-copyright, /cvsroot/gcl/gcl/xbin/get-externals, /cvsroot/gcl/gcl/xbin/get-internal-calls, /cvsroot/gcl/gcl/xbin/get-machine, /cvsroot/gcl/gcl/xbin/ibm, /cvsroot/gcl/gcl/xbin/if-exist.bat, /cvsroot/gcl/gcl/xbin/if-exists, /cvsroot/gcl/gcl/xbin/if-have-gcc, /cvsroot/gcl/gcl/xbin/inc-version, /cvsroot/gcl/gcl/xbin/is-V-newest, /cvsroot/gcl/gcl/xbin/make-fn, /cvsroot/gcl/gcl/xbin/maketest1, /cvsroot/gcl/gcl/xbin/maketest, /cvsroot/gcl/gcl/xbin/move-if-changed, /cvsroot/gcl/gcl/xbin/new-files, /cvsroot/gcl/gcl/xbin/notify, /cvsroot/gcl/gcl/xbin/setup-tmptest, /cvsroot/gcl/gcl/xbin/spp.c, /cvsroot/gcl/gcl/xbin/strip-ifdef, /cvsroot/gcl/gcl/xbin/test1, /cvsroot/gcl/gcl/xbin/test, /cvsroot/gcl/gcl/xbin/test-distrib, /cvsroot/gcl/gcl/xbin/update: initial checkin * /cvsroot/gcl/gcl/utils/replace, /cvsroot/gcl/gcl/utils/repls1.sed, /cvsroot/gcl/gcl/utils/repls2.sed, /cvsroot/gcl/gcl/utils/repls3.sed, /cvsroot/gcl/gcl/utils/repls4.sed, /cvsroot/gcl/gcl/utils/repls5.sed, /cvsroot/gcl/gcl/utils/revstruct.sed, /cvsroot/gcl/gcl/xbin/add-dir, /cvsroot/gcl/gcl/xbin/append, /cvsroot/gcl/gcl/xbin/append.bat, /cvsroot/gcl/gcl/xbin/compare.c, /cvsroot/gcl/gcl/xbin/compare-src, /cvsroot/gcl/gcl/xbin/comp_rel, /cvsroot/gcl/gcl/xbin/dfiles, /cvsroot/gcl/gcl/xbin/distrib-help, /cvsroot/gcl/gcl/xbin/distribute, /cvsroot/gcl/gcl/xbin/dos-files, /cvsroot/gcl/gcl/xbin/dosmake.bat, /cvsroot/gcl/gcl/xbin/exists, /cvsroot/gcl/gcl/xbin/file-sub, /cvsroot/gcl/gcl/xbin/fix-copyright, /cvsroot/gcl/gcl/xbin/get-externals, /cvsroot/gcl/gcl/xbin/get-internal-calls, /cvsroot/gcl/gcl/xbin/get-machine, /cvsroot/gcl/gcl/xbin/ibm, /cvsroot/gcl/gcl/xbin/if-exist.bat, /cvsroot/gcl/gcl/xbin/if-exists, /cvsroot/gcl/gcl/xbin/if-have-gcc, /cvsroot/gcl/gcl/xbin/inc-version, /cvsroot/gcl/gcl/xbin/is-V-newest, /cvsroot/gcl/gcl/xbin/make-fn, /cvsroot/gcl/gcl/xbin/maketest1, /cvsroot/gcl/gcl/xbin/maketest, /cvsroot/gcl/gcl/xbin/move-if-changed, /cvsroot/gcl/gcl/xbin/new-files, /cvsroot/gcl/gcl/xbin/notify, /cvsroot/gcl/gcl/xbin/setup-tmptest, /cvsroot/gcl/gcl/xbin/spp.c, /cvsroot/gcl/gcl/xbin/strip-ifdef, /cvsroot/gcl/gcl/xbin/test1, /cvsroot/gcl/gcl/xbin/test, /cvsroot/gcl/gcl/xbin/test-distrib, /cvsroot/gcl/gcl/xbin/update: New file. * /cvsroot/gcl/gcl/o/nsocket.ini, /cvsroot/gcl/gcl/o/unexaix.c, /cvsroot/gcl/gcl/unixport/aix-crt0.el, /cvsroot/gcl/gcl/unixport/aix_exports, /cvsroot/gcl/gcl/unixport/boots, /cvsroot/gcl/gcl/unixport/bsd_rsym.c, /cvsroot/gcl/gcl/unixport/cmpboots, /cvsroot/gcl/gcl/unixport/gcldos.lsp, /cvsroot/gcl/gcl/unixport/gcrt0.el, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/init_kcn.lsp, /cvsroot/gcl/gcl/unixport/init_maxima.lsp, /cvsroot/gcl/gcl/unixport/init_xgcl.lsp, /cvsroot/gcl/gcl/unixport/lspboots, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/makefile.dos, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/unixport/ncrt0.el, /cvsroot/gcl/gcl/unixport/rsym.c, /cvsroot/gcl/gcl/unixport/rsym_elf.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/unixport/so_locations, /cvsroot/gcl/gcl/unixport/sys_boot.c, /cvsroot/gcl/gcl/unixport/sys_gcl.c, /cvsroot/gcl/gcl/unixport/sys-init.lsp, /cvsroot/gcl/gcl/unixport/sys_kcn.c, /cvsroot/gcl/gcl/unixport/tryserv.tcl: initial checkin * /cvsroot/gcl/gcl/o/nsocket.ini, /cvsroot/gcl/gcl/o/unexaix.c, /cvsroot/gcl/gcl/unixport/aix-crt0.el, /cvsroot/gcl/gcl/unixport/aix_exports, /cvsroot/gcl/gcl/unixport/boots, /cvsroot/gcl/gcl/unixport/bsd_rsym.c, /cvsroot/gcl/gcl/unixport/cmpboots, /cvsroot/gcl/gcl/unixport/gcldos.lsp, /cvsroot/gcl/gcl/unixport/gcrt0.el, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/init_kcn.lsp, /cvsroot/gcl/gcl/unixport/init_maxima.lsp, /cvsroot/gcl/gcl/unixport/init_xgcl.lsp, /cvsroot/gcl/gcl/unixport/lspboots, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/makefile.dos, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/unixport/ncrt0.el, /cvsroot/gcl/gcl/unixport/rsym.c, /cvsroot/gcl/gcl/unixport/rsym_elf.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/unixport/so_locations, /cvsroot/gcl/gcl/unixport/sys_boot.c, /cvsroot/gcl/gcl/unixport/sys_gcl.c, /cvsroot/gcl/gcl/unixport/sys-init.lsp, /cvsroot/gcl/gcl/unixport/sys_kcn.c, /cvsroot/gcl/gcl/unixport/tryserv.tcl: New file. * /cvsroot/gcl/gcl/o/clxsocket.ini, /cvsroot/gcl/gcl/o/fasdump.c, /cvsroot/gcl/gcl/o/faslnt.c, /cvsroot/gcl/gcl/o/fat_string.ini, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/o/firstfile.c, /cvsroot/gcl/gcl/o/init_pari.ini, /cvsroot/gcl/gcl/o/lastfile.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefun.ini, /cvsroot/gcl/gcl/o/nsocket.c, /cvsroot/gcl/gcl/o/ntheap.h, /cvsroot/gcl/gcl/o/num_co.c, /cvsroot/gcl/gcl/o/rel_coff.c, /cvsroot/gcl/gcl/o/rel_stand.c, /cvsroot/gcl/gcl/o/run_process.ini, /cvsroot/gcl/gcl/o/sfasl.c, /cvsroot/gcl/gcl/o/sfasl.ini, /cvsroot/gcl/gcl/o/sockets.ini, /cvsroot/gcl/gcl/o/try.c, /cvsroot/gcl/gcl/o/unexelfsgi.c, /cvsroot/gcl/gcl/o/unexhp9k800.c, /cvsroot/gcl/gcl/o/unexlin.c, /cvsroot/gcl/gcl/o/unexmips.c, /cvsroot/gcl/gcl/o/unexsgi.c, /cvsroot/gcl/gcl/o/unixfasl.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/o/unixsave.c, /cvsroot/gcl/gcl/o/unixsys.c, /cvsroot/gcl/gcl/o/unixtime.c, /cvsroot/gcl/gcl/o/user_init.c, /cvsroot/gcl/gcl/o/usig2_aux.c, /cvsroot/gcl/gcl/o/usig2.c, /cvsroot/gcl/gcl/o/usig.c, /cvsroot/gcl/gcl/o/utils.c, /cvsroot/gcl/gcl/o/utils.ini, /cvsroot/gcl/gcl/o/Vmalloc.c, /cvsroot/gcl/gcl/o/xdrfuns.c: initial checkin * /cvsroot/gcl/gcl/o/clxsocket.ini, /cvsroot/gcl/gcl/o/fasdump.c, /cvsroot/gcl/gcl/o/faslnt.c, /cvsroot/gcl/gcl/o/fat_string.ini, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/o/firstfile.c, /cvsroot/gcl/gcl/o/init_pari.ini, /cvsroot/gcl/gcl/o/lastfile.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefun.ini, /cvsroot/gcl/gcl/o/nsocket.c, /cvsroot/gcl/gcl/o/ntheap.h, /cvsroot/gcl/gcl/o/num_co.c, /cvsroot/gcl/gcl/o/rel_coff.c, /cvsroot/gcl/gcl/o/rel_stand.c, /cvsroot/gcl/gcl/o/run_process.ini, /cvsroot/gcl/gcl/o/sfasl.c, /cvsroot/gcl/gcl/o/sfasl.ini, /cvsroot/gcl/gcl/o/sockets.ini, /cvsroot/gcl/gcl/o/try.c, /cvsroot/gcl/gcl/o/unexelfsgi.c, /cvsroot/gcl/gcl/o/unexhp9k800.c, /cvsroot/gcl/gcl/o/unexlin.c, /cvsroot/gcl/gcl/o/unexmips.c, /cvsroot/gcl/gcl/o/unexsgi.c, /cvsroot/gcl/gcl/o/unixfasl.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/o/unixsave.c, /cvsroot/gcl/gcl/o/unixsys.c, /cvsroot/gcl/gcl/o/unixtime.c, /cvsroot/gcl/gcl/o/user_init.c, /cvsroot/gcl/gcl/o/usig2_aux.c, /cvsroot/gcl/gcl/o/usig2.c, /cvsroot/gcl/gcl/o/usig.c, /cvsroot/gcl/gcl/o/utils.c, /cvsroot/gcl/gcl/o/utils.ini, /cvsroot/gcl/gcl/o/Vmalloc.c, /cvsroot/gcl/gcl/o/xdrfuns.c: New file. * /cvsroot/gcl/gcl/o/error.ini, /cvsroot/gcl/gcl/o/funlink.ini, /cvsroot/gcl/gcl/o/nfunlink.ini, /cvsroot/gcl/gcl/o/pathname.ini, /cvsroot/gcl/gcl/o/regexp.c, /cvsroot/gcl/gcl/o/regexp.h, /cvsroot/gcl/gcl/o/regexpr.c, /cvsroot/gcl/gcl/o/rel_aix.c, /cvsroot/gcl/gcl/o/rel_hp300.c, /cvsroot/gcl/gcl/o/rel_mac2.c, /cvsroot/gcl/gcl/o/rel_ps2aix.c, /cvsroot/gcl/gcl/o/rel_rios.c, /cvsroot/gcl/gcl/o/rel_sun3.c, /cvsroot/gcl/gcl/o/rel_sun4.c, /cvsroot/gcl/gcl/o/rel_u370aix.c, /cvsroot/gcl/gcl/o/run_process.c, /cvsroot/gcl/gcl/o/saveaix3.c, /cvsroot/gcl/gcl/o/save.c, /cvsroot/gcl/gcl/o/savedec31.c, /cvsroot/gcl/gcl/o/save_sgi4.c, /cvsroot/gcl/gcl/o/saveu370.c, /cvsroot/gcl/gcl/o/sbrk.c, /cvsroot/gcl/gcl/o/sequence.d, /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/o/sfasli.c, /cvsroot/gcl/gcl/o/sgbc.c, /cvsroot/gcl/gcl/o/sgi4d_emul.s, /cvsroot/gcl/gcl/o/sockets.c, /cvsroot/gcl/gcl/o/strcspn.c, /cvsroot/gcl/gcl/o/string.d, /cvsroot/gcl/gcl/o/structure.c, /cvsroot/gcl/gcl/o/symbol.d, /cvsroot/gcl/gcl/o/test_memprotect.c, /cvsroot/gcl/gcl/o/toplevel.c, /cvsroot/gcl/gcl/o/typespec.c, /cvsroot/gcl/gcl/o/u370_emul.s, /cvsroot/gcl/gcl/o/unexec-19.29.c, /cvsroot/gcl/gcl/o/unexec.c, /cvsroot/gcl/gcl/o/unexelf.c, /cvsroot/gcl/gcl/o/unixfasl.ini, /cvsroot/gcl/gcl/o/unixfsys.ini, /cvsroot/gcl/gcl/o/unixsave.ini, /cvsroot/gcl/gcl/o/unixsys.ini, /cvsroot/gcl/gcl/o/unixtime.ini, /cvsroot/gcl/gcl/o/usig2.ini, /cvsroot/gcl/gcl/o/usig.ini: initial checkin * /cvsroot/gcl/gcl/o/error.ini, /cvsroot/gcl/gcl/o/funlink.ini, /cvsroot/gcl/gcl/o/nfunlink.ini, /cvsroot/gcl/gcl/o/pathname.ini, /cvsroot/gcl/gcl/o/regexp.c, /cvsroot/gcl/gcl/o/regexp.h, /cvsroot/gcl/gcl/o/regexpr.c, /cvsroot/gcl/gcl/o/rel_aix.c, /cvsroot/gcl/gcl/o/rel_hp300.c, /cvsroot/gcl/gcl/o/rel_mac2.c, /cvsroot/gcl/gcl/o/rel_ps2aix.c, /cvsroot/gcl/gcl/o/rel_rios.c, /cvsroot/gcl/gcl/o/rel_sun3.c, /cvsroot/gcl/gcl/o/rel_sun4.c, /cvsroot/gcl/gcl/o/rel_u370aix.c, /cvsroot/gcl/gcl/o/run_process.c, /cvsroot/gcl/gcl/o/saveaix3.c, /cvsroot/gcl/gcl/o/save.c, /cvsroot/gcl/gcl/o/savedec31.c, /cvsroot/gcl/gcl/o/save_sgi4.c, /cvsroot/gcl/gcl/o/saveu370.c, /cvsroot/gcl/gcl/o/sbrk.c, /cvsroot/gcl/gcl/o/sequence.d, /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/o/sfasli.c, /cvsroot/gcl/gcl/o/sgbc.c, /cvsroot/gcl/gcl/o/sgi4d_emul.s, /cvsroot/gcl/gcl/o/sockets.c, /cvsroot/gcl/gcl/o/strcspn.c, /cvsroot/gcl/gcl/o/string.d, /cvsroot/gcl/gcl/o/structure.c, /cvsroot/gcl/gcl/o/symbol.d, /cvsroot/gcl/gcl/o/test_memprotect.c, /cvsroot/gcl/gcl/o/toplevel.c, /cvsroot/gcl/gcl/o/typespec.c, /cvsroot/gcl/gcl/o/u370_emul.s, /cvsroot/gcl/gcl/o/unexec-19.29.c, /cvsroot/gcl/gcl/o/unexec.c, /cvsroot/gcl/gcl/o/unexelf.c, /cvsroot/gcl/gcl/o/unixfasl.ini, /cvsroot/gcl/gcl/o/unixfsys.ini, /cvsroot/gcl/gcl/o/unixsave.ini, /cvsroot/gcl/gcl/o/unixsys.ini, /cvsroot/gcl/gcl/o/unixtime.ini, /cvsroot/gcl/gcl/o/usig2.ini, /cvsroot/gcl/gcl/o/usig.ini: New file. * /cvsroot/gcl/gcl/o/array.ini, /cvsroot/gcl/gcl/o/backq.ini, /cvsroot/gcl/gcl/o/character.ini, /cvsroot/gcl/gcl/o/earith.ini, /cvsroot/gcl/gcl/o/file.ini, /cvsroot/gcl/gcl/o/format.ini, /cvsroot/gcl/gcl/o/hash.ini, /cvsroot/gcl/gcl/o/list.ini, /cvsroot/gcl/gcl/o/mapfun.c, /cvsroot/gcl/gcl/o/multival.c, /cvsroot/gcl/gcl/o/ndiv.c, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/NeXTunixfasl.c, /cvsroot/gcl/gcl/o/NeXTunixsave.c, /cvsroot/gcl/gcl/o/nfunlink.c, /cvsroot/gcl/gcl/o/nmul.c, /cvsroot/gcl/gcl/o/num_arith.c, /cvsroot/gcl/gcl/o/number.c, /cvsroot/gcl/gcl/o/num_co.ini, /cvsroot/gcl/gcl/o/num_comp.c, /cvsroot/gcl/gcl/o/num_log.c, /cvsroot/gcl/gcl/o/num_log.ini, /cvsroot/gcl/gcl/o/num_pred.c, /cvsroot/gcl/gcl/o/num_rand.c, /cvsroot/gcl/gcl/o/num_rand.ini, /cvsroot/gcl/gcl/o/num_sfun.c, /cvsroot/gcl/gcl/o/package.d, /cvsroot/gcl/gcl/o/pathname.d, /cvsroot/gcl/gcl/o/peculiar.c, /cvsroot/gcl/gcl/o/predicate.c, /cvsroot/gcl/gcl/o/pre_init.c, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/print.ini, /cvsroot/gcl/gcl/o/prog.c, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/read.ini, /cvsroot/gcl/gcl/o/readme, /cvsroot/gcl/gcl/o/reference.c, /cvsroot/gcl/gcl/o/regexpr.ini, /cvsroot/gcl/gcl/o/sequence.ini, /cvsroot/gcl/gcl/o/string.ini, /cvsroot/gcl/gcl/o/structure.ini, /cvsroot/gcl/gcl/o/toplevel.ini: initial checkin * /cvsroot/gcl/gcl/o/array.ini, /cvsroot/gcl/gcl/o/backq.ini, /cvsroot/gcl/gcl/o/character.ini, /cvsroot/gcl/gcl/o/earith.ini, /cvsroot/gcl/gcl/o/file.ini, /cvsroot/gcl/gcl/o/format.ini, /cvsroot/gcl/gcl/o/hash.ini, /cvsroot/gcl/gcl/o/list.ini, /cvsroot/gcl/gcl/o/mapfun.c, /cvsroot/gcl/gcl/o/multival.c, /cvsroot/gcl/gcl/o/ndiv.c, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/NeXTunixfasl.c, /cvsroot/gcl/gcl/o/NeXTunixsave.c, /cvsroot/gcl/gcl/o/nfunlink.c, /cvsroot/gcl/gcl/o/nmul.c, /cvsroot/gcl/gcl/o/num_arith.c, /cvsroot/gcl/gcl/o/number.c, /cvsroot/gcl/gcl/o/num_co.ini, /cvsroot/gcl/gcl/o/num_comp.c, /cvsroot/gcl/gcl/o/num_log.c, /cvsroot/gcl/gcl/o/num_log.ini, /cvsroot/gcl/gcl/o/num_pred.c, /cvsroot/gcl/gcl/o/num_rand.c, /cvsroot/gcl/gcl/o/num_rand.ini, /cvsroot/gcl/gcl/o/num_sfun.c, /cvsroot/gcl/gcl/o/package.d, /cvsroot/gcl/gcl/o/pathname.d, /cvsroot/gcl/gcl/o/peculiar.c, /cvsroot/gcl/gcl/o/predicate.c, /cvsroot/gcl/gcl/o/pre_init.c, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/print.ini, /cvsroot/gcl/gcl/o/prog.c, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/read.ini, /cvsroot/gcl/gcl/o/readme, /cvsroot/gcl/gcl/o/reference.c, /cvsroot/gcl/gcl/o/regexpr.ini, /cvsroot/gcl/gcl/o/sequence.ini, /cvsroot/gcl/gcl/o/string.ini, /cvsroot/gcl/gcl/o/structure.ini, /cvsroot/gcl/gcl/o/toplevel.ini: New file. * /cvsroot/gcl/gcl/o/big.ini, /cvsroot/gcl/gcl/o/catch.ini, /cvsroot/gcl/gcl/o/cfun.ini, /cvsroot/gcl/gcl/o/cmpaux.ini, /cvsroot/gcl/gcl/o/conditional.ini, /cvsroot/gcl/gcl/o/faslsgi4.c, /cvsroot/gcl/gcl/o/fat_string.c, /cvsroot/gcl/gcl/o/fix-structref.el, /cvsroot/gcl/gcl/o/format.c, /cvsroot/gcl/gcl/o/frame.c, /cvsroot/gcl/gcl/o/funlink.c, /cvsroot/gcl/gcl/o/funs, /cvsroot/gcl/gcl/o/gbc.c, /cvsroot/gcl/gcl/o/gdb_commands, /cvsroot/gcl/gcl/o/gnumalloc.c, /cvsroot/gcl/gcl/o/grab_defs.c, /cvsroot/gcl/gcl/o/grab_defs.u, /cvsroot/gcl/gcl/o/hash.d, /cvsroot/gcl/gcl/o/help.el, /cvsroot/gcl/gcl/o/init_pari.c, /cvsroot/gcl/gcl/o/internal-calls.lisp, /cvsroot/gcl/gcl/o/iteration.c, /cvsroot/gcl/gcl/o/let.c, /cvsroot/gcl/gcl/o/lex.c, /cvsroot/gcl/gcl/o/list.d, /cvsroot/gcl/gcl/o/littleXwin.c, /cvsroot/gcl/gcl/o/macros.c, /cvsroot/gcl/gcl/o/makefun.c, /cvsroot/gcl/gcl/o/multival.ini, /cvsroot/gcl/gcl/o/mych, /cvsroot/gcl/gcl/o/num_arith.ini, /cvsroot/gcl/gcl/o/number.ini, /cvsroot/gcl/gcl/o/num_comp.ini, /cvsroot/gcl/gcl/o/num_pred.ini, /cvsroot/gcl/gcl/o/num_sfun.ini, /cvsroot/gcl/gcl/o/package.ini, /cvsroot/gcl/gcl/o/prog.ini, /cvsroot/gcl/gcl/o/symbol.ini, /cvsroot/gcl/gcl/o/unexnt.c: initial checkin * /cvsroot/gcl/gcl/o/big.ini, /cvsroot/gcl/gcl/o/catch.ini, /cvsroot/gcl/gcl/o/cfun.ini, /cvsroot/gcl/gcl/o/cmpaux.ini, /cvsroot/gcl/gcl/o/conditional.ini, /cvsroot/gcl/gcl/o/faslsgi4.c, /cvsroot/gcl/gcl/o/fat_string.c, /cvsroot/gcl/gcl/o/fix-structref.el, /cvsroot/gcl/gcl/o/format.c, /cvsroot/gcl/gcl/o/frame.c, /cvsroot/gcl/gcl/o/funlink.c, /cvsroot/gcl/gcl/o/funs, /cvsroot/gcl/gcl/o/gbc.c, /cvsroot/gcl/gcl/o/gdb_commands, /cvsroot/gcl/gcl/o/gnumalloc.c, /cvsroot/gcl/gcl/o/grab_defs.c, /cvsroot/gcl/gcl/o/grab_defs.u, /cvsroot/gcl/gcl/o/hash.d, /cvsroot/gcl/gcl/o/help.el, /cvsroot/gcl/gcl/o/init_pari.c, /cvsroot/gcl/gcl/o/internal-calls.lisp, /cvsroot/gcl/gcl/o/iteration.c, /cvsroot/gcl/gcl/o/let.c, /cvsroot/gcl/gcl/o/lex.c, /cvsroot/gcl/gcl/o/list.d, /cvsroot/gcl/gcl/o/littleXwin.c, /cvsroot/gcl/gcl/o/macros.c, /cvsroot/gcl/gcl/o/makefun.c, /cvsroot/gcl/gcl/o/multival.ini, /cvsroot/gcl/gcl/o/mych, /cvsroot/gcl/gcl/o/num_arith.ini, /cvsroot/gcl/gcl/o/number.ini, /cvsroot/gcl/gcl/o/num_comp.ini, /cvsroot/gcl/gcl/o/num_pred.ini, /cvsroot/gcl/gcl/o/num_sfun.ini, /cvsroot/gcl/gcl/o/package.ini, /cvsroot/gcl/gcl/o/prog.ini, /cvsroot/gcl/gcl/o/symbol.ini, /cvsroot/gcl/gcl/o/unexnt.c: New file. * /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/assignment.c, /cvsroot/gcl/gcl/o/assignment.ini, /cvsroot/gcl/gcl/o/backq.c, /cvsroot/gcl/gcl/o/bcmp.c, /cvsroot/gcl/gcl/o/bcopy.c, /cvsroot/gcl/gcl/o/bds.c, /cvsroot/gcl/gcl/o/bds.ini, /cvsroot/gcl/gcl/o/before_init.c, /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/bind.c, /cvsroot/gcl/gcl/o/bind.ini, /cvsroot/gcl/gcl/o/bind.texi, /cvsroot/gcl/gcl/o/bitop.c, /cvsroot/gcl/gcl/o/bitop.ini, /cvsroot/gcl/gcl/o/block.c, /cvsroot/gcl/gcl/o/block.ini, /cvsroot/gcl/gcl/o/bsearch.c, /cvsroot/gcl/gcl/o/bzero.c, /cvsroot/gcl/gcl/o/catch.c, /cvsroot/gcl/gcl/o/cfun.c, /cvsroot/gcl/gcl/o/ChangeLog, /cvsroot/gcl/gcl/o/character.d, /cvsroot/gcl/gcl/o/clxsocket.c, /cvsroot/gcl/gcl/o/cmac.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/conditional.c, /cvsroot/gcl/gcl/o/earith.c, /cvsroot/gcl/gcl/o/egrep-def, /cvsroot/gcl/gcl/o/error.c, /cvsroot/gcl/gcl/o/eval.c, /cvsroot/gcl/gcl/o/eval.ini, /cvsroot/gcl/gcl/o/external_funs.h, /cvsroot/gcl/gcl/o/fasldlsym.c, /cvsroot/gcl/gcl/o/fasldlsym.c.link, /cvsroot/gcl/gcl/o/faslhp800.c, /cvsroot/gcl/gcl/o/frame.ini, /cvsroot/gcl/gcl/o/gbc.ini, /cvsroot/gcl/gcl/o/iteration.ini, /cvsroot/gcl/gcl/o/let.ini, /cvsroot/gcl/gcl/o/lex.ini, /cvsroot/gcl/gcl/o/macros.ini, /cvsroot/gcl/gcl/o/malloc.c, /cvsroot/gcl/gcl/o/mapfun.ini, /cvsroot/gcl/gcl/o/predicate.ini, /cvsroot/gcl/gcl/o/reference.ini, /cvsroot/gcl/gcl/o/st, /cvsroot/gcl/gcl/o/typespec.ini: initial checkin * /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/assignment.c, /cvsroot/gcl/gcl/o/assignment.ini, /cvsroot/gcl/gcl/o/backq.c, /cvsroot/gcl/gcl/o/bcmp.c, /cvsroot/gcl/gcl/o/bcopy.c, /cvsroot/gcl/gcl/o/bds.c, /cvsroot/gcl/gcl/o/bds.ini, /cvsroot/gcl/gcl/o/before_init.c, /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/bind.c, /cvsroot/gcl/gcl/o/bind.ini, /cvsroot/gcl/gcl/o/bind.texi, /cvsroot/gcl/gcl/o/bitop.c, /cvsroot/gcl/gcl/o/bitop.ini, /cvsroot/gcl/gcl/o/block.c, /cvsroot/gcl/gcl/o/block.ini, /cvsroot/gcl/gcl/o/bsearch.c, /cvsroot/gcl/gcl/o/bzero.c, /cvsroot/gcl/gcl/o/catch.c, /cvsroot/gcl/gcl/o/cfun.c, /cvsroot/gcl/gcl/o/ChangeLog, /cvsroot/gcl/gcl/o/character.d, /cvsroot/gcl/gcl/o/clxsocket.c, /cvsroot/gcl/gcl/o/cmac.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/conditional.c, /cvsroot/gcl/gcl/o/earith.c, /cvsroot/gcl/gcl/o/egrep-def, /cvsroot/gcl/gcl/o/error.c, /cvsroot/gcl/gcl/o/eval.c, /cvsroot/gcl/gcl/o/eval.ini, /cvsroot/gcl/gcl/o/external_funs.h, /cvsroot/gcl/gcl/o/fasldlsym.c, /cvsroot/gcl/gcl/o/fasldlsym.c.link, /cvsroot/gcl/gcl/o/faslhp800.c, /cvsroot/gcl/gcl/o/frame.ini, /cvsroot/gcl/gcl/o/gbc.ini, /cvsroot/gcl/gcl/o/iteration.ini, /cvsroot/gcl/gcl/o/let.ini, /cvsroot/gcl/gcl/o/lex.ini, /cvsroot/gcl/gcl/o/macros.ini, /cvsroot/gcl/gcl/o/malloc.c, /cvsroot/gcl/gcl/o/mapfun.ini, /cvsroot/gcl/gcl/o/predicate.ini, /cvsroot/gcl/gcl/o/reference.ini, /cvsroot/gcl/gcl/o/st, /cvsroot/gcl/gcl/o/typespec.ini: New file. * /cvsroot/gcl/gcl/misc/warn-slow.lsp, /cvsroot/gcl/gcl/mp/fplus.c, /cvsroot/gcl/gcl/mp/gcclab, /cvsroot/gcl/gcl/mp/gcclab.awk, /cvsroot/gcl/gcl/mp/gnulib1.c, /cvsroot/gcl/gcl/mp/lo-ibmrt.s, /cvsroot/gcl/gcl/mp/lo-rios1.s, /cvsroot/gcl/gcl/mp/lo-rios.s, /cvsroot/gcl/gcl/mp/lo-sgi4d.s, /cvsroot/gcl/gcl/mp/lo-u370_aix.s, /cvsroot/gcl/gcl/mp/make.defs, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/mp/mp2.c, /cvsroot/gcl/gcl/mp/mp_addmul.c, /cvsroot/gcl/gcl/mp/mp_bfffo.c, /cvsroot/gcl/gcl/mp/mp_dblrsl3.c, /cvsroot/gcl/gcl/mp/mp_dblrul3.c, /cvsroot/gcl/gcl/mp/mp_divul3.c, /cvsroot/gcl/gcl/mp/mp_divul3_word.c, /cvsroot/gcl/gcl/mp/mpi-386d.S, /cvsroot/gcl/gcl/mp/mpi-386_no_under.s, /cvsroot/gcl/gcl/mp/mpi-bsd68k.s, /cvsroot/gcl/gcl/mp/mpi.c, /cvsroot/gcl/gcl/mp/mpi-sol-sparc.s, /cvsroot/gcl/gcl/mp/mpi-sparc.s, /cvsroot/gcl/gcl/mp/mp_mulul3.c, /cvsroot/gcl/gcl/mp/mp_shiftl.c, /cvsroot/gcl/gcl/mp/mp_sl3todivul3.c, /cvsroot/gcl/gcl/mp/readme, /cvsroot/gcl/gcl/mp/sparcdivul3.s, /cvsroot/gcl/gcl/o/alloc.ini, /cvsroot/gcl/gcl/o/array.c1, /cvsroot/gcl/gcl/o/array.c, /cvsroot/gcl/gcl/o/array.c.prev, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.ini, /cvsroot/gcl/gcl/o/makefile: initial checkin * /cvsroot/gcl/gcl/misc/warn-slow.lsp, /cvsroot/gcl/gcl/mp/fplus.c, /cvsroot/gcl/gcl/mp/gcclab, /cvsroot/gcl/gcl/mp/gcclab.awk, /cvsroot/gcl/gcl/mp/gnulib1.c, /cvsroot/gcl/gcl/mp/lo-ibmrt.s, /cvsroot/gcl/gcl/mp/lo-rios1.s, /cvsroot/gcl/gcl/mp/lo-rios.s, /cvsroot/gcl/gcl/mp/lo-sgi4d.s, /cvsroot/gcl/gcl/mp/lo-u370_aix.s, /cvsroot/gcl/gcl/mp/make.defs, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/mp/mp2.c, /cvsroot/gcl/gcl/mp/mp_addmul.c, /cvsroot/gcl/gcl/mp/mp_bfffo.c, /cvsroot/gcl/gcl/mp/mp_dblrsl3.c, /cvsroot/gcl/gcl/mp/mp_dblrul3.c, /cvsroot/gcl/gcl/mp/mp_divul3.c, /cvsroot/gcl/gcl/mp/mp_divul3_word.c, /cvsroot/gcl/gcl/mp/mpi-386d.S, /cvsroot/gcl/gcl/mp/mpi-386_no_under.s, /cvsroot/gcl/gcl/mp/mpi-bsd68k.s, /cvsroot/gcl/gcl/mp/mpi.c, /cvsroot/gcl/gcl/mp/mpi-sol-sparc.s, /cvsroot/gcl/gcl/mp/mpi-sparc.s, /cvsroot/gcl/gcl/mp/mp_mulul3.c, /cvsroot/gcl/gcl/mp/mp_shiftl.c, /cvsroot/gcl/gcl/mp/mp_sl3todivul3.c, /cvsroot/gcl/gcl/mp/readme, /cvsroot/gcl/gcl/mp/sparcdivul3.s, /cvsroot/gcl/gcl/o/alloc.ini, /cvsroot/gcl/gcl/o/array.c1, /cvsroot/gcl/gcl/o/array.c, /cvsroot/gcl/gcl/o/array.c.prev, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.ini, /cvsroot/gcl/gcl/o/makefile: New file. * /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/lsp/serror.data, /cvsroot/gcl/gcl/lsp/serror.h, /cvsroot/gcl/gcl/lsp/sloop.data, /cvsroot/gcl/gcl/lsp/sloop.h, /cvsroot/gcl/gcl/lsp/sloop.lsp, /cvsroot/gcl/gcl/lsp/stack-problem.lsp, /cvsroot/gcl/gcl/lsp/stdlisp.lsp, /cvsroot/gcl/gcl/lsp/sys-proclaim.lisp, /cvsroot/gcl/gcl/lsp/top.c, /cvsroot/gcl/gcl/lsp/top.data, /cvsroot/gcl/gcl/lsp/top.h, /cvsroot/gcl/gcl/lsp/top.lsp, /cvsroot/gcl/gcl/lsp/trace.c, /cvsroot/gcl/gcl/lsp/trace.data, /cvsroot/gcl/gcl/lsp/trace.h, /cvsroot/gcl/gcl/lsp/trace.lsp, /cvsroot/gcl/gcl/lsp/ucall.lisp, /cvsroot/gcl/gcl/lsp/ustreams.lisp, /cvsroot/gcl/gcl/man/man1/gcl.1, /cvsroot/gcl/gcl/misc/check.c, /cvsroot/gcl/gcl/misc/check_obj.c, /cvsroot/gcl/gcl/misc/cstruct.lsp, /cvsroot/gcl/gcl/misc/foreign.lsp, /cvsroot/gcl/gcl/misc/mprotect.ch, /cvsroot/gcl/gcl/misc/rusage.lsp, /cvsroot/gcl/gcl/misc/test-seek.c, /cvsroot/gcl/gcl/misc/test-sgc.lsp: initial checkin * /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/lsp/serror.data, /cvsroot/gcl/gcl/lsp/serror.h, /cvsroot/gcl/gcl/lsp/sloop.data, /cvsroot/gcl/gcl/lsp/sloop.h, /cvsroot/gcl/gcl/lsp/sloop.lsp, /cvsroot/gcl/gcl/lsp/stack-problem.lsp, /cvsroot/gcl/gcl/lsp/stdlisp.lsp, /cvsroot/gcl/gcl/lsp/sys-proclaim.lisp, /cvsroot/gcl/gcl/lsp/top.c, /cvsroot/gcl/gcl/lsp/top.data, /cvsroot/gcl/gcl/lsp/top.h, /cvsroot/gcl/gcl/lsp/top.lsp, /cvsroot/gcl/gcl/lsp/trace.c, /cvsroot/gcl/gcl/lsp/trace.data, /cvsroot/gcl/gcl/lsp/trace.h, /cvsroot/gcl/gcl/lsp/trace.lsp, /cvsroot/gcl/gcl/lsp/ucall.lisp, /cvsroot/gcl/gcl/lsp/ustreams.lisp, /cvsroot/gcl/gcl/man/man1/gcl.1, /cvsroot/gcl/gcl/misc/check.c, /cvsroot/gcl/gcl/misc/check_obj.c, /cvsroot/gcl/gcl/misc/cstruct.lsp, /cvsroot/gcl/gcl/misc/foreign.lsp, /cvsroot/gcl/gcl/misc/mprotect.ch, /cvsroot/gcl/gcl/misc/rusage.lsp, /cvsroot/gcl/gcl/misc/test-seek.c, /cvsroot/gcl/gcl/misc/test-sgc.lsp: New file. * /cvsroot/gcl/gcl/lsp/littleXlsp.lsp, /cvsroot/gcl/gcl/lsp/loadcmp.lsp, /cvsroot/gcl/gcl/lsp/make-declare.lsp, /cvsroot/gcl/gcl/lsp/make.lisp, /cvsroot/gcl/gcl/lsp/mislib.c, /cvsroot/gcl/gcl/lsp/mislib.data, /cvsroot/gcl/gcl/lsp/mislib.h, /cvsroot/gcl/gcl/lsp/mislib.lsp, /cvsroot/gcl/gcl/lsp/module.c, /cvsroot/gcl/gcl/lsp/module.data, /cvsroot/gcl/gcl/lsp/module.h, /cvsroot/gcl/gcl/lsp/module.lsp, /cvsroot/gcl/gcl/lsp/numlib.c, /cvsroot/gcl/gcl/lsp/numlib.data, /cvsroot/gcl/gcl/lsp/numlib.h, /cvsroot/gcl/gcl/lsp/numlib.lsp, /cvsroot/gcl/gcl/lsp/packages.lsp, /cvsroot/gcl/gcl/lsp/packlib.c, /cvsroot/gcl/gcl/lsp/packlib.data, /cvsroot/gcl/gcl/lsp/packlib.h, /cvsroot/gcl/gcl/lsp/packlib.lsp, /cvsroot/gcl/gcl/lsp/predlib.c, /cvsroot/gcl/gcl/lsp/predlib.data, /cvsroot/gcl/gcl/lsp/predlib.h, /cvsroot/gcl/gcl/lsp/predlib.lsp, /cvsroot/gcl/gcl/lsp/profile.lsp, /cvsroot/gcl/gcl/lsp/seq.c, /cvsroot/gcl/gcl/lsp/seq.data, /cvsroot/gcl/gcl/lsp/seq.h, /cvsroot/gcl/gcl/lsp/seqlib.c, /cvsroot/gcl/gcl/lsp/seqlib.data, /cvsroot/gcl/gcl/lsp/seqlib.h, /cvsroot/gcl/gcl/lsp/seqlib.lsp, /cvsroot/gcl/gcl/lsp/seq.lsp, /cvsroot/gcl/gcl/lsp/serror.lsp, /cvsroot/gcl/gcl/lsp/setf.c, /cvsroot/gcl/gcl/lsp/setf.data, /cvsroot/gcl/gcl/lsp/setf.h, /cvsroot/gcl/gcl/lsp/setf.lsp, /cvsroot/gcl/gcl/lsp/sloop.c: initial checkin * /cvsroot/gcl/gcl/lsp/littleXlsp.lsp, /cvsroot/gcl/gcl/lsp/loadcmp.lsp, /cvsroot/gcl/gcl/lsp/make-declare.lsp, /cvsroot/gcl/gcl/lsp/make.lisp, /cvsroot/gcl/gcl/lsp/mislib.c, /cvsroot/gcl/gcl/lsp/mislib.data, /cvsroot/gcl/gcl/lsp/mislib.h, /cvsroot/gcl/gcl/lsp/mislib.lsp, /cvsroot/gcl/gcl/lsp/module.c, /cvsroot/gcl/gcl/lsp/module.data, /cvsroot/gcl/gcl/lsp/module.h, /cvsroot/gcl/gcl/lsp/module.lsp, /cvsroot/gcl/gcl/lsp/numlib.c, /cvsroot/gcl/gcl/lsp/numlib.data, /cvsroot/gcl/gcl/lsp/numlib.h, /cvsroot/gcl/gcl/lsp/numlib.lsp, /cvsroot/gcl/gcl/lsp/packages.lsp, /cvsroot/gcl/gcl/lsp/packlib.c, /cvsroot/gcl/gcl/lsp/packlib.data, /cvsroot/gcl/gcl/lsp/packlib.h, /cvsroot/gcl/gcl/lsp/packlib.lsp, /cvsroot/gcl/gcl/lsp/predlib.c, /cvsroot/gcl/gcl/lsp/predlib.data, /cvsroot/gcl/gcl/lsp/predlib.h, /cvsroot/gcl/gcl/lsp/predlib.lsp, /cvsroot/gcl/gcl/lsp/profile.lsp, /cvsroot/gcl/gcl/lsp/seq.c, /cvsroot/gcl/gcl/lsp/seq.data, /cvsroot/gcl/gcl/lsp/seq.h, /cvsroot/gcl/gcl/lsp/seqlib.c, /cvsroot/gcl/gcl/lsp/seqlib.data, /cvsroot/gcl/gcl/lsp/seqlib.h, /cvsroot/gcl/gcl/lsp/seqlib.lsp, /cvsroot/gcl/gcl/lsp/seq.lsp, /cvsroot/gcl/gcl/lsp/serror.lsp, /cvsroot/gcl/gcl/lsp/setf.c, /cvsroot/gcl/gcl/lsp/setf.data, /cvsroot/gcl/gcl/lsp/setf.h, /cvsroot/gcl/gcl/lsp/setf.lsp, /cvsroot/gcl/gcl/lsp/sloop.c: New file. * /cvsroot/gcl/gcl/lsp/debug.h, /cvsroot/gcl/gcl/lsp/debug.lsp, /cvsroot/gcl/gcl/lsp/defmacro.c, /cvsroot/gcl/gcl/lsp/defmacro.data, /cvsroot/gcl/gcl/lsp/defmacro.h, /cvsroot/gcl/gcl/lsp/defmacro.lsp, /cvsroot/gcl/gcl/lsp/defstruct.c, /cvsroot/gcl/gcl/lsp/defstruct.data, /cvsroot/gcl/gcl/lsp/defstruct.h, /cvsroot/gcl/gcl/lsp/defstruct.lsp, /cvsroot/gcl/gcl/lsp/describe.c, /cvsroot/gcl/gcl/lsp/describe.data, /cvsroot/gcl/gcl/lsp/describe.h, /cvsroot/gcl/gcl/lsp/describe.lsp, /cvsroot/gcl/gcl/lsp/desetq.lsp, /cvsroot/gcl/gcl/lsp/doc-file.lsp, /cvsroot/gcl/gcl/lsp/dummy.lisp, /cvsroot/gcl/gcl/lsp/evalmacros.c, /cvsroot/gcl/gcl/lsp/evalmacros.data, /cvsroot/gcl/gcl/lsp/evalmacros.h, /cvsroot/gcl/gcl/lsp/evalmacros.lsp, /cvsroot/gcl/gcl/lsp/export.lsp, /cvsroot/gcl/gcl/lsp/fasd.lisp, /cvsroot/gcl/gcl/lsp/fast-mv.lisp, /cvsroot/gcl/gcl/lsp/fdecl.lsp, /cvsroot/gcl/gcl/lsp/gprof1.lisp, /cvsroot/gcl/gcl/lsp/gprof_aix.hc, /cvsroot/gcl/gcl/lsp/gprof.hc, /cvsroot/gcl/gcl/lsp/gprof.lsp, /cvsroot/gcl/gcl/lsp/info.c, /cvsroot/gcl/gcl/lsp/info.data, /cvsroot/gcl/gcl/lsp/info.h, /cvsroot/gcl/gcl/lsp/info.lsp, /cvsroot/gcl/gcl/lsp/iolib.c, /cvsroot/gcl/gcl/lsp/iolib.data, /cvsroot/gcl/gcl/lsp/iolib.h, /cvsroot/gcl/gcl/lsp/iolib.lsp, /cvsroot/gcl/gcl/lsp/jim, /cvsroot/gcl/gcl/lsp/listlib.c, /cvsroot/gcl/gcl/lsp/listlib.data, /cvsroot/gcl/gcl/lsp/listlib.h, /cvsroot/gcl/gcl/lsp/listlib.lsp, /cvsroot/gcl/gcl/lsp/serror.c: initial checkin * /cvsroot/gcl/gcl/lsp/debug.h, /cvsroot/gcl/gcl/lsp/debug.lsp, /cvsroot/gcl/gcl/lsp/defmacro.c, /cvsroot/gcl/gcl/lsp/defmacro.data, /cvsroot/gcl/gcl/lsp/defmacro.h, /cvsroot/gcl/gcl/lsp/defmacro.lsp, /cvsroot/gcl/gcl/lsp/defstruct.c, /cvsroot/gcl/gcl/lsp/defstruct.data, /cvsroot/gcl/gcl/lsp/defstruct.h, /cvsroot/gcl/gcl/lsp/defstruct.lsp, /cvsroot/gcl/gcl/lsp/describe.c, /cvsroot/gcl/gcl/lsp/describe.data, /cvsroot/gcl/gcl/lsp/describe.h, /cvsroot/gcl/gcl/lsp/describe.lsp, /cvsroot/gcl/gcl/lsp/desetq.lsp, /cvsroot/gcl/gcl/lsp/doc-file.lsp, /cvsroot/gcl/gcl/lsp/dummy.lisp, /cvsroot/gcl/gcl/lsp/evalmacros.c, /cvsroot/gcl/gcl/lsp/evalmacros.data, /cvsroot/gcl/gcl/lsp/evalmacros.h, /cvsroot/gcl/gcl/lsp/evalmacros.lsp, /cvsroot/gcl/gcl/lsp/export.lsp, /cvsroot/gcl/gcl/lsp/fasd.lisp, /cvsroot/gcl/gcl/lsp/fast-mv.lisp, /cvsroot/gcl/gcl/lsp/fdecl.lsp, /cvsroot/gcl/gcl/lsp/gprof1.lisp, /cvsroot/gcl/gcl/lsp/gprof_aix.hc, /cvsroot/gcl/gcl/lsp/gprof.hc, /cvsroot/gcl/gcl/lsp/gprof.lsp, /cvsroot/gcl/gcl/lsp/info.c, /cvsroot/gcl/gcl/lsp/info.data, /cvsroot/gcl/gcl/lsp/info.h, /cvsroot/gcl/gcl/lsp/info.lsp, /cvsroot/gcl/gcl/lsp/iolib.c, /cvsroot/gcl/gcl/lsp/iolib.data, /cvsroot/gcl/gcl/lsp/iolib.h, /cvsroot/gcl/gcl/lsp/iolib.lsp, /cvsroot/gcl/gcl/lsp/jim, /cvsroot/gcl/gcl/lsp/listlib.c, /cvsroot/gcl/gcl/lsp/listlib.data, /cvsroot/gcl/gcl/lsp/listlib.h, /cvsroot/gcl/gcl/lsp/listlib.lsp, /cvsroot/gcl/gcl/lsp/serror.c: New file. * /cvsroot/gcl/gcl/info/gcl-si.info-1.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-1.gz, /cvsroot/gcl/gcl/info/sequence.texi, /cvsroot/gcl/gcl/info/si-defs.texi, /cvsroot/gcl/gcl/info/structure.texi, /cvsroot/gcl/gcl/info/symbol.texi, /cvsroot/gcl/gcl/info/system.texi, /cvsroot/gcl/gcl/info/texinfo.tex, /cvsroot/gcl/gcl/info/type.texi, /cvsroot/gcl/gcl/info/user-interface.texi, /cvsroot/gcl/gcl/info/widgets.texi, /cvsroot/gcl/gcl/lsp/arraylib.c, /cvsroot/gcl/gcl/lsp/arraylib.data, /cvsroot/gcl/gcl/lsp/arraylib.h, /cvsroot/gcl/gcl/lsp/arraylib.lsp, /cvsroot/gcl/gcl/lsp/assert.c, /cvsroot/gcl/gcl/lsp/assert.data, /cvsroot/gcl/gcl/lsp/assert.h, /cvsroot/gcl/gcl/lsp/assert.lsp, /cvsroot/gcl/gcl/lsp/autocmp.lsp, /cvsroot/gcl/gcl/lsp/autoload.lsp, /cvsroot/gcl/gcl/lsp/auto.lsp, /cvsroot/gcl/gcl/lsp/cmpinit.lsp, /cvsroot/gcl/gcl/lsp/dbind.lisp, /cvsroot/gcl/gcl/lsp/debug.c, /cvsroot/gcl/gcl/lsp/debug.data: initial checkin * /cvsroot/gcl/gcl/info/gcl-si.info-1.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-1.gz, /cvsroot/gcl/gcl/info/sequence.texi, /cvsroot/gcl/gcl/info/si-defs.texi, /cvsroot/gcl/gcl/info/structure.texi, /cvsroot/gcl/gcl/info/symbol.texi, /cvsroot/gcl/gcl/info/system.texi, /cvsroot/gcl/gcl/info/texinfo.tex, /cvsroot/gcl/gcl/info/type.texi, /cvsroot/gcl/gcl/info/user-interface.texi, /cvsroot/gcl/gcl/info/widgets.texi, /cvsroot/gcl/gcl/lsp/arraylib.c, /cvsroot/gcl/gcl/lsp/arraylib.data, /cvsroot/gcl/gcl/lsp/arraylib.h, /cvsroot/gcl/gcl/lsp/arraylib.lsp, /cvsroot/gcl/gcl/lsp/assert.c, /cvsroot/gcl/gcl/lsp/assert.data, /cvsroot/gcl/gcl/lsp/assert.h, /cvsroot/gcl/gcl/lsp/assert.lsp, /cvsroot/gcl/gcl/lsp/autocmp.lsp, /cvsroot/gcl/gcl/lsp/autoload.lsp, /cvsroot/gcl/gcl/lsp/auto.lsp, /cvsroot/gcl/gcl/lsp/cmpinit.lsp, /cvsroot/gcl/gcl/lsp/dbind.lisp, /cvsroot/gcl/gcl/lsp/debug.c, /cvsroot/gcl/gcl/lsp/debug.data: New file. * /cvsroot/gcl/gcl/info/character.texi, /cvsroot/gcl/gcl/info/compiler-defs.texi, /cvsroot/gcl/gcl/info/compile.texi, /cvsroot/gcl/gcl/info/control.texi, /cvsroot/gcl/gcl/info/debug.texi, /cvsroot/gcl/gcl/info/doc.texi, /cvsroot/gcl/gcl/info/form.texi, /cvsroot/gcl/gcl/info/gcl-si.cp, /cvsroot/gcl/gcl/info/gcl-si-index.texi, /cvsroot/gcl/gcl/info/gcl-si.info, /cvsroot/gcl/gcl/info/gcl-si.info-2.gz, /cvsroot/gcl/gcl/info/gcl-si.info-3.gz, /cvsroot/gcl/gcl/info/gcl-si.info-4.gz, /cvsroot/gcl/gcl/info/gcl-si.info-5.gz, /cvsroot/gcl/gcl/info/gcl-si.info-6.gz, /cvsroot/gcl/gcl/info/gcl-si.ky, /cvsroot/gcl/gcl/info/gcl-si.pg, /cvsroot/gcl/gcl/info/gcl-si.texi, /cvsroot/gcl/gcl/info/gcl-si.toc, /cvsroot/gcl/gcl/info/gcl-si.tp, /cvsroot/gcl/gcl/info/gcl-si.vr, /cvsroot/gcl/gcl/info/gcl-tk.cp, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/gcl-tk.info-2.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-3.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-4.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-5.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-6.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-7.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-8.gz, /cvsroot/gcl/gcl/info/gcl-tk.ky, /cvsroot/gcl/gcl/info/gcl-tk.pg, /cvsroot/gcl/gcl/info/gcl-tk.texi, /cvsroot/gcl/gcl/info/gcl-tk.toc, /cvsroot/gcl/gcl/info/gcl-tk.tp, /cvsroot/gcl/gcl/info/gcl-tk.vr, /cvsroot/gcl/gcl/info/general.texi, /cvsroot/gcl/gcl/info/internal.texi, /cvsroot/gcl/gcl/info/io.texi, /cvsroot/gcl/gcl/info/iteration.texi, /cvsroot/gcl/gcl/info/list.texi, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/info/misc.texi, /cvsroot/gcl/gcl/info/number.texi: initial checkin * /cvsroot/gcl/gcl/info/character.texi, /cvsroot/gcl/gcl/info/compiler-defs.texi, /cvsroot/gcl/gcl/info/compile.texi, /cvsroot/gcl/gcl/info/control.texi, /cvsroot/gcl/gcl/info/debug.texi, /cvsroot/gcl/gcl/info/doc.texi, /cvsroot/gcl/gcl/info/form.texi, /cvsroot/gcl/gcl/info/gcl-si.cp, /cvsroot/gcl/gcl/info/gcl-si-index.texi, /cvsroot/gcl/gcl/info/gcl-si.info, /cvsroot/gcl/gcl/info/gcl-si.info-2.gz, /cvsroot/gcl/gcl/info/gcl-si.info-3.gz, /cvsroot/gcl/gcl/info/gcl-si.info-4.gz, /cvsroot/gcl/gcl/info/gcl-si.info-5.gz, /cvsroot/gcl/gcl/info/gcl-si.info-6.gz, /cvsroot/gcl/gcl/info/gcl-si.ky, /cvsroot/gcl/gcl/info/gcl-si.pg, /cvsroot/gcl/gcl/info/gcl-si.texi, /cvsroot/gcl/gcl/info/gcl-si.toc, /cvsroot/gcl/gcl/info/gcl-si.tp, /cvsroot/gcl/gcl/info/gcl-si.vr, /cvsroot/gcl/gcl/info/gcl-tk.cp, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/gcl-tk.info-2.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-3.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-4.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-5.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-6.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-7.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-8.gz, /cvsroot/gcl/gcl/info/gcl-tk.ky, /cvsroot/gcl/gcl/info/gcl-tk.pg, /cvsroot/gcl/gcl/info/gcl-tk.texi, /cvsroot/gcl/gcl/info/gcl-tk.toc, /cvsroot/gcl/gcl/info/gcl-tk.tp, /cvsroot/gcl/gcl/info/gcl-tk.vr, /cvsroot/gcl/gcl/info/general.texi, /cvsroot/gcl/gcl/info/internal.texi, /cvsroot/gcl/gcl/info/io.texi, /cvsroot/gcl/gcl/info/iteration.texi, /cvsroot/gcl/gcl/info/list.texi, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/info/misc.texi, /cvsroot/gcl/gcl/info/number.texi: New file. * /cvsroot/gcl/gcl/h/att.h, /cvsroot/gcl/gcl/h/cmplrs/stsupport.h, /cvsroot/gcl/gcl/h/coff/i386.h, /cvsroot/gcl/gcl/h/cyglacks.h, /cvsroot/gcl/gcl/h/ext_sym.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/gnuwin95.defs, /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/h/options.h, /cvsroot/gcl/gcl/h/ptable.h, /cvsroot/gcl/gcl/h/rgbc.h, /cvsroot/gcl/gcl/h/rios-aix3.defs, /cvsroot/gcl/gcl/h/rios-aix3.h, /cvsroot/gcl/gcl/h/rios.defs, /cvsroot/gcl/gcl/h/rios.h, /cvsroot/gcl/gcl/h/rt_aix.defs, /cvsroot/gcl/gcl/h/rt_aix.h, /cvsroot/gcl/gcl/h/s3000.h, /cvsroot/gcl/gcl/h/secondary_sun_magic, /cvsroot/gcl/gcl/h/sfun_argd.h, /cvsroot/gcl/gcl/h/sgi4d.defs, /cvsroot/gcl/gcl/h/sgi4d.h, /cvsroot/gcl/gcl/h/sgi.defs, /cvsroot/gcl/gcl/h/sgi.h, /cvsroot/gcl/gcl/h/solaris.defs, /cvsroot/gcl/gcl/h/solaris.h, /cvsroot/gcl/gcl/h/solaris-i386.defs, /cvsroot/gcl/gcl/h/solaris-i386.h, /cvsroot/gcl/gcl/h/sparc.h, /cvsroot/gcl/gcl/h/sparc-linux.defs, /cvsroot/gcl/gcl/h/sparc-linux.h, /cvsroot/gcl/gcl/h/stacks.h, /cvsroot/gcl/gcl/h/sun2r3.defs, /cvsroot/gcl/gcl/h/sun2r3.h, /cvsroot/gcl/gcl/h/sun386i.defs, /cvsroot/gcl/gcl/h/sun386i.h, /cvsroot/gcl/gcl/h/sun3.defs, /cvsroot/gcl/gcl/h/sun3.h, /cvsroot/gcl/gcl/h/sun3-os4.defs, /cvsroot/gcl/gcl/h/sun3-os4.h, /cvsroot/gcl/gcl/h/sun4.defs, /cvsroot/gcl/gcl/h/sun4.h, /cvsroot/gcl/gcl/h/sun.h, /cvsroot/gcl/gcl/h/symbol.h, /cvsroot/gcl/gcl/h/symmetry.defs, /cvsroot/gcl/gcl/h/symmetry.h, /cvsroot/gcl/gcl/h/twelve_null, /cvsroot/gcl/gcl/h/u370_aix.defs, /cvsroot/gcl/gcl/h/u370_aix.h, /cvsroot/gcl/gcl/h/usig.h, /cvsroot/gcl/gcl/h/vax.defs, /cvsroot/gcl/gcl/h/vax.h, /cvsroot/gcl/gcl/h/vs.h, /cvsroot/gcl/gcl/h/wincoff.h, /cvsroot/gcl/gcl/info/bind.texi, /cvsroot/gcl/gcl/info/c-interface.texi: initial checkin * /cvsroot/gcl/gcl/h/att.h, /cvsroot/gcl/gcl/h/cmplrs/stsupport.h, /cvsroot/gcl/gcl/h/coff/i386.h, /cvsroot/gcl/gcl/h/cyglacks.h, /cvsroot/gcl/gcl/h/ext_sym.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/gnuwin95.defs, /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/h/options.h, /cvsroot/gcl/gcl/h/ptable.h, /cvsroot/gcl/gcl/h/rgbc.h, /cvsroot/gcl/gcl/h/rios-aix3.defs, /cvsroot/gcl/gcl/h/rios-aix3.h, /cvsroot/gcl/gcl/h/rios.defs, /cvsroot/gcl/gcl/h/rios.h, /cvsroot/gcl/gcl/h/rt_aix.defs, /cvsroot/gcl/gcl/h/rt_aix.h, /cvsroot/gcl/gcl/h/s3000.h, /cvsroot/gcl/gcl/h/secondary_sun_magic, /cvsroot/gcl/gcl/h/sfun_argd.h, /cvsroot/gcl/gcl/h/sgi4d.defs, /cvsroot/gcl/gcl/h/sgi4d.h, /cvsroot/gcl/gcl/h/sgi.defs, /cvsroot/gcl/gcl/h/sgi.h, /cvsroot/gcl/gcl/h/solaris.defs, /cvsroot/gcl/gcl/h/solaris.h, /cvsroot/gcl/gcl/h/solaris-i386.defs, /cvsroot/gcl/gcl/h/solaris-i386.h, /cvsroot/gcl/gcl/h/sparc.h, /cvsroot/gcl/gcl/h/sparc-linux.defs, /cvsroot/gcl/gcl/h/sparc-linux.h, /cvsroot/gcl/gcl/h/stacks.h, /cvsroot/gcl/gcl/h/sun2r3.defs, /cvsroot/gcl/gcl/h/sun2r3.h, /cvsroot/gcl/gcl/h/sun386i.defs, /cvsroot/gcl/gcl/h/sun386i.h, /cvsroot/gcl/gcl/h/sun3.defs, /cvsroot/gcl/gcl/h/sun3.h, /cvsroot/gcl/gcl/h/sun3-os4.defs, /cvsroot/gcl/gcl/h/sun3-os4.h, /cvsroot/gcl/gcl/h/sun4.defs, /cvsroot/gcl/gcl/h/sun4.h, /cvsroot/gcl/gcl/h/sun.h, /cvsroot/gcl/gcl/h/symbol.h, /cvsroot/gcl/gcl/h/symmetry.defs, /cvsroot/gcl/gcl/h/symmetry.h, /cvsroot/gcl/gcl/h/twelve_null, /cvsroot/gcl/gcl/h/u370_aix.defs, /cvsroot/gcl/gcl/h/u370_aix.h, /cvsroot/gcl/gcl/h/usig.h, /cvsroot/gcl/gcl/h/vax.defs, /cvsroot/gcl/gcl/h/vax.h, /cvsroot/gcl/gcl/h/vs.h, /cvsroot/gcl/gcl/h/wincoff.h, /cvsroot/gcl/gcl/info/bind.texi, /cvsroot/gcl/gcl/info/c-interface.texi: New file. * /cvsroot/gcl/gcl/h/cmponly.h, /cvsroot/gcl/gcl/h/coff_encap.h, /cvsroot/gcl/gcl/h/compat.h, /cvsroot/gcl/gcl/h/compbas2.h, /cvsroot/gcl/gcl/h/compbas.h, /cvsroot/gcl/gcl/h/convex.h, /cvsroot/gcl/gcl/h/dec3100.defs, /cvsroot/gcl/gcl/h/dec3100.h, /cvsroot/gcl/gcl/h/defun.h, /cvsroot/gcl/gcl/h/dos-go32.defs, /cvsroot/gcl/gcl/h/dos-go32.h, /cvsroot/gcl/gcl/h/e15.h, /cvsroot/gcl/gcl/h/enum.h, /cvsroot/gcl/gcl/h/erreurs.h, /cvsroot/gcl/gcl/h/eval.h, /cvsroot/gcl/gcl/h/frame.h, /cvsroot/gcl/gcl/h/FreeBSD.defs, /cvsroot/gcl/gcl/h/FreeBSD.h, /cvsroot/gcl/gcl/h/funlink.h, /cvsroot/gcl/gcl/h/gencom.h, /cvsroot/gcl/gcl/h/genpari.h, /cvsroot/gcl/gcl/h/genport.h, /cvsroot/gcl/gcl/h/getpagesize.h, /cvsroot/gcl/gcl/h/hp300-bsd.defs, /cvsroot/gcl/gcl/h/hp300-bsd.h, /cvsroot/gcl/gcl/h/hp300.defs, /cvsroot/gcl/gcl/h/hp300.h, /cvsroot/gcl/gcl/h/hp800.defs, /cvsroot/gcl/gcl/h/hp800.h, /cvsroot/gcl/gcl/h/include.h, /cvsroot/gcl/gcl/h/irix5.defs, /cvsroot/gcl/gcl/h/irix5.h, /cvsroot/gcl/gcl/h/irix6.defs, /cvsroot/gcl/gcl/h/irix6.h, /cvsroot/gcl/gcl/h/lex.h, /cvsroot/gcl/gcl/h/mac2.defs, /cvsroot/gcl/gcl/h/mac2.h, /cvsroot/gcl/gcl/h/make-decl.h, /cvsroot/gcl/gcl/h/make-init.h, /cvsroot/gcl/gcl/h/mc68k.h, /cvsroot/gcl/gcl/h/mdefs.h, /cvsroot/gcl/gcl/h/mips.h, /cvsroot/gcl/gcl/h/mp386.defs, /cvsroot/gcl/gcl/h/mp386.h, /cvsroot/gcl/gcl/h/mp.h, /cvsroot/gcl/gcl/h/ncr.defs, /cvsroot/gcl/gcl/h/ncr.h, /cvsroot/gcl/gcl/h/NetBSD.defs, /cvsroot/gcl/gcl/h/NetBSD.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/h/news.h, /cvsroot/gcl/gcl/h/NeXT30-m68k.defs, /cvsroot/gcl/gcl/h/NeXT30-m68k.h, /cvsroot/gcl/gcl/h/NeXT32-i386.defs, /cvsroot/gcl/gcl/h/NeXT32-i386.h, /cvsroot/gcl/gcl/h/NeXT32-m68k.defs, /cvsroot/gcl/gcl/h/NeXT32-m68k.h, /cvsroot/gcl/gcl/h/NeXT.defs, /cvsroot/gcl/gcl/h/NeXT.h, /cvsroot/gcl/gcl/h/notcomp.h, /cvsroot/gcl/gcl/h/num_include.h, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/h/page.h: initial checkin * /cvsroot/gcl/gcl/h/cmponly.h, /cvsroot/gcl/gcl/h/coff_encap.h, /cvsroot/gcl/gcl/h/compat.h, /cvsroot/gcl/gcl/h/compbas2.h, /cvsroot/gcl/gcl/h/compbas.h, /cvsroot/gcl/gcl/h/convex.h, /cvsroot/gcl/gcl/h/dec3100.defs, /cvsroot/gcl/gcl/h/dec3100.h, /cvsroot/gcl/gcl/h/defun.h, /cvsroot/gcl/gcl/h/dos-go32.defs, /cvsroot/gcl/gcl/h/dos-go32.h, /cvsroot/gcl/gcl/h/e15.h, /cvsroot/gcl/gcl/h/enum.h, /cvsroot/gcl/gcl/h/erreurs.h, /cvsroot/gcl/gcl/h/eval.h, /cvsroot/gcl/gcl/h/frame.h, /cvsroot/gcl/gcl/h/FreeBSD.defs, /cvsroot/gcl/gcl/h/FreeBSD.h, /cvsroot/gcl/gcl/h/funlink.h, /cvsroot/gcl/gcl/h/gencom.h, /cvsroot/gcl/gcl/h/genpari.h, /cvsroot/gcl/gcl/h/genport.h, /cvsroot/gcl/gcl/h/getpagesize.h, /cvsroot/gcl/gcl/h/hp300-bsd.defs, /cvsroot/gcl/gcl/h/hp300-bsd.h, /cvsroot/gcl/gcl/h/hp300.defs, /cvsroot/gcl/gcl/h/hp300.h, /cvsroot/gcl/gcl/h/hp800.defs, /cvsroot/gcl/gcl/h/hp800.h, /cvsroot/gcl/gcl/h/include.h, /cvsroot/gcl/gcl/h/irix5.defs, /cvsroot/gcl/gcl/h/irix5.h, /cvsroot/gcl/gcl/h/irix6.defs, /cvsroot/gcl/gcl/h/irix6.h, /cvsroot/gcl/gcl/h/lex.h, /cvsroot/gcl/gcl/h/mac2.defs, /cvsroot/gcl/gcl/h/mac2.h, /cvsroot/gcl/gcl/h/make-decl.h, /cvsroot/gcl/gcl/h/make-init.h, /cvsroot/gcl/gcl/h/mc68k.h, /cvsroot/gcl/gcl/h/mdefs.h, /cvsroot/gcl/gcl/h/mips.h, /cvsroot/gcl/gcl/h/mp386.defs, /cvsroot/gcl/gcl/h/mp386.h, /cvsroot/gcl/gcl/h/mp.h, /cvsroot/gcl/gcl/h/ncr.defs, /cvsroot/gcl/gcl/h/ncr.h, /cvsroot/gcl/gcl/h/NetBSD.defs, /cvsroot/gcl/gcl/h/NetBSD.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/h/news.h, /cvsroot/gcl/gcl/h/NeXT30-m68k.defs, /cvsroot/gcl/gcl/h/NeXT30-m68k.h, /cvsroot/gcl/gcl/h/NeXT32-i386.defs, /cvsroot/gcl/gcl/h/NeXT32-i386.h, /cvsroot/gcl/gcl/h/NeXT32-m68k.defs, /cvsroot/gcl/gcl/h/NeXT32-m68k.h, /cvsroot/gcl/gcl/h/NeXT.defs, /cvsroot/gcl/gcl/h/NeXT.h, /cvsroot/gcl/gcl/h/notcomp.h, /cvsroot/gcl/gcl/h/num_include.h, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/h/page.h: New file. * /cvsroot/gcl/gcl/gcl-tk/demos-4.1/items.lisp, /cvsroot/gcl/gcl/gcl-tk/demos-4.2/widget, /cvsroot/gcl/gcl/gcl-tk/demos-4.2/widget.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkForm.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkForm.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkHScale.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkHScale.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkIcon.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkItems.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkItems.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkLabel.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkLabel.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox2.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox3.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkPlot.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkPlot.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkPuzzle.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkRadio.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkRadio.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkRuler.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkRuler.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkScroll.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkSearch.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkSearch.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkStyles.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkStyles.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkTear.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkTextBind.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkTextBind.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkVScale.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkVScale.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/nqthm-stack.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/showVars.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/showVars.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/tclIndex, /cvsroot/gcl/gcl/gcl-tk/demos/widget.lisp, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-bsd.defs, /cvsroot/gcl/gcl/h/386-bsd.h, /cvsroot/gcl/gcl/h/386.h, /cvsroot/gcl/gcl/h/386-linux.defs, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/alpha-osf1.defs, /cvsroot/gcl/gcl/h/alpha-osf1.h, /cvsroot/gcl/gcl/h/arith.h, /cvsroot/gcl/gcl/h/att3b2.h, /cvsroot/gcl/gcl/h/att_ext.h, /cvsroot/gcl/gcl/h/bds.h, /cvsroot/gcl/gcl/h/bsd.h, /cvsroot/gcl/gcl/h/cmpincl1.h, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h: initial checkin * /cvsroot/gcl/gcl/gcl-tk/demos-4.1/items.lisp, /cvsroot/gcl/gcl/gcl-tk/demos-4.2/widget, /cvsroot/gcl/gcl/gcl-tk/demos-4.2/widget.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkForm.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkForm.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkHScale.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkHScale.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkIcon.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkItems.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkItems.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkLabel.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkLabel.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox2.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox3.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkPlot.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkPlot.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkPuzzle.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkRadio.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkRadio.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkRuler.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkRuler.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkScroll.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkSearch.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkSearch.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkStyles.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkStyles.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkTear.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkTextBind.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkTextBind.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkVScale.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkVScale.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/nqthm-stack.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/showVars.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/showVars.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/tclIndex, /cvsroot/gcl/gcl/gcl-tk/demos/widget.lisp, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-bsd.defs, /cvsroot/gcl/gcl/h/386-bsd.h, /cvsroot/gcl/gcl/h/386.h, /cvsroot/gcl/gcl/h/386-linux.defs, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/alpha-osf1.defs, /cvsroot/gcl/gcl/h/alpha-osf1.h, /cvsroot/gcl/gcl/h/arith.h, /cvsroot/gcl/gcl/h/att3b2.h, /cvsroot/gcl/gcl/h/att_ext.h, /cvsroot/gcl/gcl/h/bds.h, /cvsroot/gcl/gcl/h/bsd.h, /cvsroot/gcl/gcl/h/cmpincl1.h, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h: New file. * /cvsroot/gcl/gcl/gcl-tk/decode.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/gc-monitor.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/gcl-tk/demos/mkArrow.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkBasic.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkBasic.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkBitmaps.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkButton.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkCanvText.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkCanvText.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkCheck.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkdialog.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkDialog.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry2.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry2.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkFloor.tcl, /cvsroot/gcl/gcl/gcl-tk/gcl_guisl.h, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in.interp, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.prev, /cvsroot/gcl/gcl/gcl-tk/guis.c, /cvsroot/gcl/gcl/gcl-tk/guis.h, /cvsroot/gcl/gcl/gcl-tk/helpers.lisp, /cvsroot/gcl/gcl/gcl-tk/index.lsp, /cvsroot/gcl/gcl/gcl-tk/intrs.h, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile.prev, /cvsroot/gcl/gcl/gcl-tk/ngcltksrv, /cvsroot/gcl/gcl/gcl-tk/our_io.c, /cvsroot/gcl/gcl/gcl-tk/sheader.h, /cvsroot/gcl/gcl/gcl-tk/socketsl.lisp, /cvsroot/gcl/gcl/gcl-tk/socks.h, /cvsroot/gcl/gcl/gcl-tk/sysdep-sunos.h, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/gcl-tk/tinfo.lsp, /cvsroot/gcl/gcl/gcl-tk/tkAppInit.c, /cvsroot/gcl/gcl/gcl-tk/tkl.lisp, /cvsroot/gcl/gcl/gcl-tk/tkMain.c, /cvsroot/gcl/gcl/gcl-tk/tk-package.lsp, /cvsroot/gcl/gcl/gcl-tk/tktst.c, /cvsroot/gcl/gcl/gcl-tk/tkXAppInit.c, /cvsroot/gcl/gcl/gcl-tk/tkXshell.c: initial checkin * /cvsroot/gcl/gcl/gcl-tk/decode.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/gc-monitor.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/gcl-tk/demos/mkArrow.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkBasic.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkBasic.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkBitmaps.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkButton.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkCanvText.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkCanvText.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkCheck.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkdialog.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkDialog.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry2.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry2.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkFloor.tcl, /cvsroot/gcl/gcl/gcl-tk/gcl_guisl.h, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in.interp, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.prev, /cvsroot/gcl/gcl/gcl-tk/guis.c, /cvsroot/gcl/gcl/gcl-tk/guis.h, /cvsroot/gcl/gcl/gcl-tk/helpers.lisp, /cvsroot/gcl/gcl/gcl-tk/index.lsp, /cvsroot/gcl/gcl/gcl-tk/intrs.h, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile.prev, /cvsroot/gcl/gcl/gcl-tk/ngcltksrv, /cvsroot/gcl/gcl/gcl-tk/our_io.c, /cvsroot/gcl/gcl/gcl-tk/sheader.h, /cvsroot/gcl/gcl/gcl-tk/socketsl.lisp, /cvsroot/gcl/gcl/gcl-tk/socks.h, /cvsroot/gcl/gcl/gcl-tk/sysdep-sunos.h, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/gcl-tk/tinfo.lsp, /cvsroot/gcl/gcl/gcl-tk/tkAppInit.c, /cvsroot/gcl/gcl/gcl-tk/tkl.lisp, /cvsroot/gcl/gcl/gcl-tk/tkMain.c, /cvsroot/gcl/gcl/gcl-tk/tk-package.lsp, /cvsroot/gcl/gcl/gcl-tk/tktst.c, /cvsroot/gcl/gcl/gcl-tk/tkXAppInit.c, /cvsroot/gcl/gcl/gcl-tk/tkXshell.c: New file. * /cvsroot/gcl/gcl/comp/top1.lsp, /cvsroot/gcl/gcl/comp/top2.lsp, /cvsroot/gcl/gcl/comp/try1.lsp, /cvsroot/gcl/gcl/comp/try.lsp, /cvsroot/gcl/gcl/comp/utils.lsp, /cvsroot/gcl/gcl/comp/var.lsp, /cvsroot/gcl/gcl/comp/wr.lsp, /cvsroot/gcl/gcl/doc/bignum, /cvsroot/gcl/gcl/doc/c-gc, /cvsroot/gcl/gcl/doc/c-gc.doc, /cvsroot/gcl/gcl/doc/compile-file-handling-of-top-level-forms, /cvsroot/gcl/gcl/doc/contributors, /cvsroot/gcl/gcl/doc/debug, /cvsroot/gcl/gcl/doc/enhancements, /cvsroot/gcl/gcl/doc/fast-link, /cvsroot/gcl/gcl/doc/format, /cvsroot/gcl/gcl/doc/funcall-comp, /cvsroot/gcl/gcl/doc/funcall.lsp, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/doc/multiple-values, /cvsroot/gcl/gcl/doc/profile, /cvsroot/gcl/gcl/dos/dostimes.c, /cvsroot/gcl/gcl/dos/dum_dos.c, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/dos/readme, /cvsroot/gcl/gcl/dos/read.s, /cvsroot/gcl/gcl/dos/sigman.s, /cvsroot/gcl/gcl/dos/signal.c, /cvsroot/gcl/gcl/dos/signal.h, /cvsroot/gcl/gcl/elisp/add-default.el, /cvsroot/gcl/gcl/elisp/ansi-doc.el, /cvsroot/gcl/gcl/elisp/dbl.el, /cvsroot/gcl/gcl/elisp/doc-to-texi.el, /cvsroot/gcl/gcl/elisp/gcl.el, /cvsroot/gcl/gcl/elisp/lisp-complete.el, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/elisp/man1-to-texi.el, /cvsroot/gcl/gcl/elisp/readme, /cvsroot/gcl/gcl/elisp/smart-complete.el, /cvsroot/gcl/gcl/elisp/sshell.el, /cvsroot/gcl/gcl/gcl-tk/cmpinit.lsp, /cvsroot/gcl/gcl/gcl-tk/comm.c, /cvsroot/gcl/gcl/gcl-tk/convert.el, /cvsroot/gcl/gcl/gcl-tk/dir.sed, /cvsroot/gcl/gcl/gcl-tk/gcl-1.tcl, /cvsroot/gcl/gcl/gcl-tk/gcl.tcl, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in: initial checkin * /cvsroot/gcl/gcl/comp/top1.lsp, /cvsroot/gcl/gcl/comp/top2.lsp, /cvsroot/gcl/gcl/comp/try1.lsp, /cvsroot/gcl/gcl/comp/try.lsp, /cvsroot/gcl/gcl/comp/utils.lsp, /cvsroot/gcl/gcl/comp/var.lsp, /cvsroot/gcl/gcl/comp/wr.lsp, /cvsroot/gcl/gcl/doc/bignum, /cvsroot/gcl/gcl/doc/c-gc, /cvsroot/gcl/gcl/doc/c-gc.doc, /cvsroot/gcl/gcl/doc/compile-file-handling-of-top-level-forms, /cvsroot/gcl/gcl/doc/contributors, /cvsroot/gcl/gcl/doc/debug, /cvsroot/gcl/gcl/doc/enhancements, /cvsroot/gcl/gcl/doc/fast-link, /cvsroot/gcl/gcl/doc/format, /cvsroot/gcl/gcl/doc/funcall-comp, /cvsroot/gcl/gcl/doc/funcall.lsp, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/doc/multiple-values, /cvsroot/gcl/gcl/doc/profile, /cvsroot/gcl/gcl/dos/dostimes.c, /cvsroot/gcl/gcl/dos/dum_dos.c, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/dos/readme, /cvsroot/gcl/gcl/dos/read.s, /cvsroot/gcl/gcl/dos/sigman.s, /cvsroot/gcl/gcl/dos/signal.c, /cvsroot/gcl/gcl/dos/signal.h, /cvsroot/gcl/gcl/elisp/add-default.el, /cvsroot/gcl/gcl/elisp/ansi-doc.el, /cvsroot/gcl/gcl/elisp/dbl.el, /cvsroot/gcl/gcl/elisp/doc-to-texi.el, /cvsroot/gcl/gcl/elisp/gcl.el, /cvsroot/gcl/gcl/elisp/lisp-complete.el, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/elisp/man1-to-texi.el, /cvsroot/gcl/gcl/elisp/readme, /cvsroot/gcl/gcl/elisp/smart-complete.el, /cvsroot/gcl/gcl/elisp/sshell.el, /cvsroot/gcl/gcl/gcl-tk/cmpinit.lsp, /cvsroot/gcl/gcl/gcl-tk/comm.c, /cvsroot/gcl/gcl/gcl-tk/convert.el, /cvsroot/gcl/gcl/gcl-tk/dir.sed, /cvsroot/gcl/gcl/gcl-tk/gcl-1.tcl, /cvsroot/gcl/gcl/gcl-tk/gcl.tcl, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in: New file. * /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/cmpnew/cmptype.h, /cvsroot/gcl/gcl/cmpnew/cmptype.lsp, /cvsroot/gcl/gcl/cmpnew/cmputil.c, /cvsroot/gcl/gcl/cmpnew/cmputil.data, /cvsroot/gcl/gcl/cmpnew/cmputil.h, /cvsroot/gcl/gcl/cmpnew/cmputil.lsp, /cvsroot/gcl/gcl/cmpnew/cmpvar.c, /cvsroot/gcl/gcl/cmpnew/cmpvar.data, /cvsroot/gcl/gcl/cmpnew/cmpvar.h, /cvsroot/gcl/gcl/cmpnew/cmpvar.lsp, /cvsroot/gcl/gcl/cmpnew/cmpvs.c, /cvsroot/gcl/gcl/cmpnew/cmpvs.data, /cvsroot/gcl/gcl/cmpnew/cmpvs.h, /cvsroot/gcl/gcl/cmpnew/cmpvs.lsp, /cvsroot/gcl/gcl/cmpnew/cmpwt.c, /cvsroot/gcl/gcl/cmpnew/cmpwt.data, /cvsroot/gcl/gcl/cmpnew/cmpwt.h, /cvsroot/gcl/gcl/cmpnew/cmpwt.lsp, /cvsroot/gcl/gcl/cmpnew/collectfn.lsp, /cvsroot/gcl/gcl/cmpnew/fasdmacros.lsp, /cvsroot/gcl/gcl/cmpnew/init.lsp, /cvsroot/gcl/gcl/cmpnew/lfun_list.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/cmpnew/make-fn.lsp, /cvsroot/gcl/gcl/cmpnew/make_ufun.lsp, /cvsroot/gcl/gcl/cmpnew/nocmpinc.lsp, /cvsroot/gcl/gcl/cmpnew/so_locations, /cvsroot/gcl/gcl/cmpnew/sys-proclaim.lisp, /cvsroot/gcl/gcl/comp/bo1.lsp, /cvsroot/gcl/gcl/comp/cmpinit.lsp, /cvsroot/gcl/gcl/comp/comptype.lsp, /cvsroot/gcl/gcl/comp/c-pass1.lsp, /cvsroot/gcl/gcl/comp/data.lsp, /cvsroot/gcl/gcl/comp/defmacro.lsp, /cvsroot/gcl/gcl/comp/defs.lsp, /cvsroot/gcl/gcl/comp/exit.lsp, /cvsroot/gcl/gcl/comp/fasdmacros.lsp, /cvsroot/gcl/gcl/comp/inline.lsp, /cvsroot/gcl/gcl/comp/integer.doc, /cvsroot/gcl/gcl/comp/lambda.lsp, /cvsroot/gcl/gcl/comp/lisp-decls.doc, /cvsroot/gcl/gcl/comp/macros.lsp, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/comp/mangle.lsp, /cvsroot/gcl/gcl/comp/opts-base.lsp, /cvsroot/gcl/gcl/comp/opts.lsp, /cvsroot/gcl/gcl/comp/proclaim.lsp, /cvsroot/gcl/gcl/comp/smash-oldcmp.lsp, /cvsroot/gcl/gcl/comp/stmt.lsp, /cvsroot/gcl/gcl/comp/sysdef.lsp, /cvsroot/gcl/gcl/comp/top.lsp: initial checkin * /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/cmpnew/cmptype.h, /cvsroot/gcl/gcl/cmpnew/cmptype.lsp, /cvsroot/gcl/gcl/cmpnew/cmputil.c, /cvsroot/gcl/gcl/cmpnew/cmputil.data, /cvsroot/gcl/gcl/cmpnew/cmputil.h, /cvsroot/gcl/gcl/cmpnew/cmputil.lsp, /cvsroot/gcl/gcl/cmpnew/cmpvar.c, /cvsroot/gcl/gcl/cmpnew/cmpvar.data, /cvsroot/gcl/gcl/cmpnew/cmpvar.h, /cvsroot/gcl/gcl/cmpnew/cmpvar.lsp, /cvsroot/gcl/gcl/cmpnew/cmpvs.c, /cvsroot/gcl/gcl/cmpnew/cmpvs.data, /cvsroot/gcl/gcl/cmpnew/cmpvs.h, /cvsroot/gcl/gcl/cmpnew/cmpvs.lsp, /cvsroot/gcl/gcl/cmpnew/cmpwt.c, /cvsroot/gcl/gcl/cmpnew/cmpwt.data, /cvsroot/gcl/gcl/cmpnew/cmpwt.h, /cvsroot/gcl/gcl/cmpnew/cmpwt.lsp, /cvsroot/gcl/gcl/cmpnew/collectfn.lsp, /cvsroot/gcl/gcl/cmpnew/fasdmacros.lsp, /cvsroot/gcl/gcl/cmpnew/init.lsp, /cvsroot/gcl/gcl/cmpnew/lfun_list.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/cmpnew/make-fn.lsp, /cvsroot/gcl/gcl/cmpnew/make_ufun.lsp, /cvsroot/gcl/gcl/cmpnew/nocmpinc.lsp, /cvsroot/gcl/gcl/cmpnew/so_locations, /cvsroot/gcl/gcl/cmpnew/sys-proclaim.lisp, /cvsroot/gcl/gcl/comp/bo1.lsp, /cvsroot/gcl/gcl/comp/cmpinit.lsp, /cvsroot/gcl/gcl/comp/comptype.lsp, /cvsroot/gcl/gcl/comp/c-pass1.lsp, /cvsroot/gcl/gcl/comp/data.lsp, /cvsroot/gcl/gcl/comp/defmacro.lsp, /cvsroot/gcl/gcl/comp/defs.lsp, /cvsroot/gcl/gcl/comp/exit.lsp, /cvsroot/gcl/gcl/comp/fasdmacros.lsp, /cvsroot/gcl/gcl/comp/inline.lsp, /cvsroot/gcl/gcl/comp/integer.doc, /cvsroot/gcl/gcl/comp/lambda.lsp, /cvsroot/gcl/gcl/comp/lisp-decls.doc, /cvsroot/gcl/gcl/comp/macros.lsp, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/comp/mangle.lsp, /cvsroot/gcl/gcl/comp/opts-base.lsp, /cvsroot/gcl/gcl/comp/opts.lsp, /cvsroot/gcl/gcl/comp/proclaim.lsp, /cvsroot/gcl/gcl/comp/smash-oldcmp.lsp, /cvsroot/gcl/gcl/comp/stmt.lsp, /cvsroot/gcl/gcl/comp/sysdef.lsp, /cvsroot/gcl/gcl/comp/top.lsp: New file. * /cvsroot/gcl/gcl/cmpnew/cmplam.data, /cvsroot/gcl/gcl/cmpnew/cmplam.h, /cvsroot/gcl/gcl/cmpnew/cmplam.lsp, /cvsroot/gcl/gcl/cmpnew/cmplet.c, /cvsroot/gcl/gcl/cmpnew/cmplet.data, /cvsroot/gcl/gcl/cmpnew/cmplet.h, /cvsroot/gcl/gcl/cmpnew/cmplet.lsp, /cvsroot/gcl/gcl/cmpnew/cmploc.c, /cvsroot/gcl/gcl/cmpnew/cmploc.data, /cvsroot/gcl/gcl/cmpnew/cmploc.h, /cvsroot/gcl/gcl/cmpnew/cmploc.lsp, /cvsroot/gcl/gcl/cmpnew/cmpmap.c, /cvsroot/gcl/gcl/cmpnew/cmpmap.data, /cvsroot/gcl/gcl/cmpnew/cmpmap.h, /cvsroot/gcl/gcl/cmpnew/cmpmap.lsp, /cvsroot/gcl/gcl/cmpnew/cmpmulti.c, /cvsroot/gcl/gcl/cmpnew/cmpmulti.data, /cvsroot/gcl/gcl/cmpnew/cmpmulti.h, /cvsroot/gcl/gcl/cmpnew/cmpmulti.lsp, /cvsroot/gcl/gcl/cmpnew/cmpopt.lsp, /cvsroot/gcl/gcl/cmpnew/cmpspecial.c, /cvsroot/gcl/gcl/cmpnew/cmpspecial.data, /cvsroot/gcl/gcl/cmpnew/cmpspecial.h, /cvsroot/gcl/gcl/cmpnew/cmpspecial.lsp, /cvsroot/gcl/gcl/cmpnew/cmptag.c, /cvsroot/gcl/gcl/cmpnew/cmptag.data, /cvsroot/gcl/gcl/cmpnew/cmptag.h, /cvsroot/gcl/gcl/cmpnew/cmptag.lsp, /cvsroot/gcl/gcl/cmpnew/cmptest.lsp, /cvsroot/gcl/gcl/cmpnew/cmptop.c, /cvsroot/gcl/gcl/cmpnew/cmptop.data, /cvsroot/gcl/gcl/cmpnew/cmptop.h, /cvsroot/gcl/gcl/cmpnew/cmptop.lsp, /cvsroot/gcl/gcl/cmpnew/cmptype.c, /cvsroot/gcl/gcl/cmpnew/cmptype.data: initial checkin * /cvsroot/gcl/gcl/cmpnew/cmplam.data, /cvsroot/gcl/gcl/cmpnew/cmplam.h, /cvsroot/gcl/gcl/cmpnew/cmplam.lsp, /cvsroot/gcl/gcl/cmpnew/cmplet.c, /cvsroot/gcl/gcl/cmpnew/cmplet.data, /cvsroot/gcl/gcl/cmpnew/cmplet.h, /cvsroot/gcl/gcl/cmpnew/cmplet.lsp, /cvsroot/gcl/gcl/cmpnew/cmploc.c, /cvsroot/gcl/gcl/cmpnew/cmploc.data, /cvsroot/gcl/gcl/cmpnew/cmploc.h, /cvsroot/gcl/gcl/cmpnew/cmploc.lsp, /cvsroot/gcl/gcl/cmpnew/cmpmap.c, /cvsroot/gcl/gcl/cmpnew/cmpmap.data, /cvsroot/gcl/gcl/cmpnew/cmpmap.h, /cvsroot/gcl/gcl/cmpnew/cmpmap.lsp, /cvsroot/gcl/gcl/cmpnew/cmpmulti.c, /cvsroot/gcl/gcl/cmpnew/cmpmulti.data, /cvsroot/gcl/gcl/cmpnew/cmpmulti.h, /cvsroot/gcl/gcl/cmpnew/cmpmulti.lsp, /cvsroot/gcl/gcl/cmpnew/cmpopt.lsp, /cvsroot/gcl/gcl/cmpnew/cmpspecial.c, /cvsroot/gcl/gcl/cmpnew/cmpspecial.data, /cvsroot/gcl/gcl/cmpnew/cmpspecial.h, /cvsroot/gcl/gcl/cmpnew/cmpspecial.lsp, /cvsroot/gcl/gcl/cmpnew/cmptag.c, /cvsroot/gcl/gcl/cmpnew/cmptag.data, /cvsroot/gcl/gcl/cmpnew/cmptag.h, /cvsroot/gcl/gcl/cmpnew/cmptag.lsp, /cvsroot/gcl/gcl/cmpnew/cmptest.lsp, /cvsroot/gcl/gcl/cmpnew/cmptop.c, /cvsroot/gcl/gcl/cmpnew/cmptop.data, /cvsroot/gcl/gcl/cmpnew/cmptop.h, /cvsroot/gcl/gcl/cmpnew/cmptop.lsp, /cvsroot/gcl/gcl/cmpnew/cmptype.c, /cvsroot/gcl/gcl/cmpnew/cmptype.data: New file. * /cvsroot/gcl/gcl/cmpnew/cmpenv.c, /cvsroot/gcl/gcl/cmpnew/cmpenv.data, /cvsroot/gcl/gcl/cmpnew/cmpenv.h, /cvsroot/gcl/gcl/cmpnew/cmpenv.lsp, /cvsroot/gcl/gcl/cmpnew/cmpeval.c, /cvsroot/gcl/gcl/cmpnew/cmpeval.data, /cvsroot/gcl/gcl/cmpnew/cmpeval.h, /cvsroot/gcl/gcl/cmpnew/cmpeval.lsp, /cvsroot/gcl/gcl/cmpnew/cmpflet.c, /cvsroot/gcl/gcl/cmpnew/cmpflet.data, /cvsroot/gcl/gcl/cmpnew/cmpflet.h, /cvsroot/gcl/gcl/cmpnew/cmpflet.lsp, /cvsroot/gcl/gcl/cmpnew/cmpfun.c, /cvsroot/gcl/gcl/cmpnew/cmpfun.data, /cvsroot/gcl/gcl/cmpnew/cmpfun.h, /cvsroot/gcl/gcl/cmpnew/cmpfun.lsp, /cvsroot/gcl/gcl/cmpnew/cmpif.c, /cvsroot/gcl/gcl/cmpnew/cmpif.data, /cvsroot/gcl/gcl/cmpnew/cmpif.h, /cvsroot/gcl/gcl/cmpnew/cmpif.lsp, /cvsroot/gcl/gcl/cmpnew/cmpinit.lsp, /cvsroot/gcl/gcl/cmpnew/cmpinline.c, /cvsroot/gcl/gcl/cmpnew/cmpinline.data, /cvsroot/gcl/gcl/cmpnew/cmpinline.h, /cvsroot/gcl/gcl/cmpnew/cmpinline.lsp, /cvsroot/gcl/gcl/cmpnew/cmplabel.c, /cvsroot/gcl/gcl/cmpnew/cmplabel.data, /cvsroot/gcl/gcl/cmpnew/cmplabel.h, /cvsroot/gcl/gcl/cmpnew/cmplabel.lsp, /cvsroot/gcl/gcl/cmpnew/cmplam.c: initial checkin * /cvsroot/gcl/gcl/cmpnew/cmpenv.c, /cvsroot/gcl/gcl/cmpnew/cmpenv.data, /cvsroot/gcl/gcl/cmpnew/cmpenv.h, /cvsroot/gcl/gcl/cmpnew/cmpenv.lsp, /cvsroot/gcl/gcl/cmpnew/cmpeval.c, /cvsroot/gcl/gcl/cmpnew/cmpeval.data, /cvsroot/gcl/gcl/cmpnew/cmpeval.h, /cvsroot/gcl/gcl/cmpnew/cmpeval.lsp, /cvsroot/gcl/gcl/cmpnew/cmpflet.c, /cvsroot/gcl/gcl/cmpnew/cmpflet.data, /cvsroot/gcl/gcl/cmpnew/cmpflet.h, /cvsroot/gcl/gcl/cmpnew/cmpflet.lsp, /cvsroot/gcl/gcl/cmpnew/cmpfun.c, /cvsroot/gcl/gcl/cmpnew/cmpfun.data, /cvsroot/gcl/gcl/cmpnew/cmpfun.h, /cvsroot/gcl/gcl/cmpnew/cmpfun.lsp, /cvsroot/gcl/gcl/cmpnew/cmpif.c, /cvsroot/gcl/gcl/cmpnew/cmpif.data, /cvsroot/gcl/gcl/cmpnew/cmpif.h, /cvsroot/gcl/gcl/cmpnew/cmpif.lsp, /cvsroot/gcl/gcl/cmpnew/cmpinit.lsp, /cvsroot/gcl/gcl/cmpnew/cmpinline.c, /cvsroot/gcl/gcl/cmpnew/cmpinline.data, /cvsroot/gcl/gcl/cmpnew/cmpinline.h, /cvsroot/gcl/gcl/cmpnew/cmpinline.lsp, /cvsroot/gcl/gcl/cmpnew/cmplabel.c, /cvsroot/gcl/gcl/cmpnew/cmplabel.data, /cvsroot/gcl/gcl/cmpnew/cmplabel.h, /cvsroot/gcl/gcl/cmpnew/cmplabel.lsp, /cvsroot/gcl/gcl/cmpnew/cmplam.c: New file. * /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/append.c, /cvsroot/gcl/gcl/bin/dpp.c, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/info1, /cvsroot/gcl/gcl/bin/info, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/bin/tkinfo, /cvsroot/gcl/gcl/clcs/condition-definitions.lisp, /cvsroot/gcl/gcl/clcs/condition-precom.lisp, /cvsroot/gcl/gcl/clcs/conditions.lisp, /cvsroot/gcl/gcl/clcs/debugger.lisp, /cvsroot/gcl/gcl/clcs/doload.lisp, /cvsroot/gcl/gcl/clcs/handler.lisp, /cvsroot/gcl/gcl/clcs/install.lisp, /cvsroot/gcl/gcl/clcs/kcl-cond.lisp, /cvsroot/gcl/gcl/clcs/loading.lisp, /cvsroot/gcl/gcl/clcs/macros.lisp, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/clcs/package.lisp, /cvsroot/gcl/gcl/clcs/precom.lisp, /cvsroot/gcl/gcl/clcs/readme, /cvsroot/gcl/gcl/clcs/reload.lisp, /cvsroot/gcl/gcl/clcs/restart.lisp, /cvsroot/gcl/gcl/clcs/sysdef.lisp, /cvsroot/gcl/gcl/clcs/test2.lisp, /cvsroot/gcl/gcl/clcs/test3.lisp, /cvsroot/gcl/gcl/clcs/test4.lisp, /cvsroot/gcl/gcl/clcs/test5.lisp, /cvsroot/gcl/gcl/clcs/tester.lisp, /cvsroot/gcl/gcl/clcs/test.lisp, /cvsroot/gcl/gcl/clcs/top-patches.lisp, /cvsroot/gcl/gcl/cmpnew/cmpbind.c, /cvsroot/gcl/gcl/cmpnew/cmpbind.data, /cvsroot/gcl/gcl/cmpnew/cmpbind.h, /cvsroot/gcl/gcl/cmpnew/cmpbind.lsp, /cvsroot/gcl/gcl/cmpnew/cmpblock.c, /cvsroot/gcl/gcl/cmpnew/cmpblock.data, /cvsroot/gcl/gcl/cmpnew/cmpblock.h, /cvsroot/gcl/gcl/cmpnew/cmpblock.lsp, /cvsroot/gcl/gcl/cmpnew/cmpcall.c, /cvsroot/gcl/gcl/cmpnew/cmpcall.data, /cvsroot/gcl/gcl/cmpnew/cmpcall.h, /cvsroot/gcl/gcl/cmpnew/cmpcall.lsp, /cvsroot/gcl/gcl/cmpnew/cmpcatch.c, /cvsroot/gcl/gcl/cmpnew/cmpcatch.data, /cvsroot/gcl/gcl/cmpnew/cmpcatch.h, /cvsroot/gcl/gcl/cmpnew/cmpcatch.lsp, /cvsroot/gcl/gcl/gcl1.jpg, /cvsroot/gcl/gcl/gcl2.jpg, /cvsroot/gcl/gcl/gcl.gif, /cvsroot/gcl/gcl/gcl.jpg: initial checkin * /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/append.c, /cvsroot/gcl/gcl/bin/dpp.c, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/info1, /cvsroot/gcl/gcl/bin/info, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/bin/tkinfo, /cvsroot/gcl/gcl/clcs/condition-definitions.lisp, /cvsroot/gcl/gcl/clcs/condition-precom.lisp, /cvsroot/gcl/gcl/clcs/conditions.lisp, /cvsroot/gcl/gcl/clcs/debugger.lisp, /cvsroot/gcl/gcl/clcs/doload.lisp, /cvsroot/gcl/gcl/clcs/handler.lisp, /cvsroot/gcl/gcl/clcs/install.lisp, /cvsroot/gcl/gcl/clcs/kcl-cond.lisp, /cvsroot/gcl/gcl/clcs/loading.lisp, /cvsroot/gcl/gcl/clcs/macros.lisp, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/clcs/package.lisp, /cvsroot/gcl/gcl/clcs/precom.lisp, /cvsroot/gcl/gcl/clcs/readme, /cvsroot/gcl/gcl/clcs/reload.lisp, /cvsroot/gcl/gcl/clcs/restart.lisp, /cvsroot/gcl/gcl/clcs/sysdef.lisp, /cvsroot/gcl/gcl/clcs/test2.lisp, /cvsroot/gcl/gcl/clcs/test3.lisp, /cvsroot/gcl/gcl/clcs/test4.lisp, /cvsroot/gcl/gcl/clcs/test5.lisp, /cvsroot/gcl/gcl/clcs/tester.lisp, /cvsroot/gcl/gcl/clcs/test.lisp, /cvsroot/gcl/gcl/clcs/top-patches.lisp, /cvsroot/gcl/gcl/cmpnew/cmpbind.c, /cvsroot/gcl/gcl/cmpnew/cmpbind.data, /cvsroot/gcl/gcl/cmpnew/cmpbind.h, /cvsroot/gcl/gcl/cmpnew/cmpbind.lsp, /cvsroot/gcl/gcl/cmpnew/cmpblock.c, /cvsroot/gcl/gcl/cmpnew/cmpblock.data, /cvsroot/gcl/gcl/cmpnew/cmpblock.h, /cvsroot/gcl/gcl/cmpnew/cmpblock.lsp, /cvsroot/gcl/gcl/cmpnew/cmpcall.c, /cvsroot/gcl/gcl/cmpnew/cmpcall.data, /cvsroot/gcl/gcl/cmpnew/cmpcall.h, /cvsroot/gcl/gcl/cmpnew/cmpcall.lsp, /cvsroot/gcl/gcl/cmpnew/cmpcatch.c, /cvsroot/gcl/gcl/cmpnew/cmpcatch.data, /cvsroot/gcl/gcl/cmpnew/cmpcatch.h, /cvsroot/gcl/gcl/cmpnew/cmpcatch.lsp, /cvsroot/gcl/gcl/gcl1.jpg, /cvsroot/gcl/gcl/gcl2.jpg, /cvsroot/gcl/gcl/gcl.gif, /cvsroot/gcl/gcl/gcl.jpg: New file. * /cvsroot/gcl/gcl/AC_FD_CC, /cvsroot/gcl/gcl/AC_FD_MSG, /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/add-defs, /cvsroot/gcl/gcl/add-defs.bat, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/config.guess, /cvsroot/gcl/gcl/config.sub, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/COPYING.LIB-2.0, /cvsroot/gcl/gcl/eval.html, /cvsroot/gcl/gcl/eval.tcl, /cvsroot/gcl/gcl/faq, /cvsroot/gcl/gcl/install.sh, /cvsroot/gcl/gcl/machine, /cvsroot/gcl/gcl/machines, /cvsroot/gcl/gcl/majvers, /cvsroot/gcl/gcl/makdefs, /cvsroot/gcl/gcl/makedefs.in, /cvsroot/gcl/gcl/makedf, /cvsroot/gcl/gcl/makedf.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/merge.c, /cvsroot/gcl/gcl/minvers, /cvsroot/gcl/gcl/readme: initial checkin * /cvsroot/gcl/gcl/AC_FD_CC, /cvsroot/gcl/gcl/AC_FD_MSG, /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/add-defs, /cvsroot/gcl/gcl/add-defs.bat, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/config.guess, /cvsroot/gcl/gcl/config.sub, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/COPYING.LIB-2.0, /cvsroot/gcl/gcl/eval.html, /cvsroot/gcl/gcl/eval.tcl, /cvsroot/gcl/gcl/faq, /cvsroot/gcl/gcl/install.sh, /cvsroot/gcl/gcl/machine, /cvsroot/gcl/gcl/machines, /cvsroot/gcl/gcl/majvers, /cvsroot/gcl/gcl/makdefs, /cvsroot/gcl/gcl/makedefs.in, /cvsroot/gcl/gcl/makedf, /cvsroot/gcl/gcl/makedf.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/merge.c, /cvsroot/gcl/gcl/minvers, /cvsroot/gcl/gcl/readme: New file. gcl/ChangeLog.old000077500000000000000000000161141242227143400141610ustar00rootroot000000000000002001-12-29 Camm Maguire * gmp/configure.in update for darwin * #ifdef'ed R_386_NUM in sfaslelf.c for old libc * changes to configure.in and elisp/makefile to handle emacs not being present * fix to gmp/ltconfig to avoid exec'ing '""' * Added DESTDIR to makefiles to support installing under arbitrary subdir * good 'clean' targets * correct building in absense of tcl/tk 2001-12-18 David Billinghurst * h/gnuwin95.h: Cruft removal and update (SA_RESTART): Surround by #if 0/#endif (fopen_binary): Remove (fopen): Remove redefinition to fopen_binary 2001-04-15 Bill Schelter * Added changes to allow the loading .o files compiled on -O4 under linux, and also added this to be the default optimize level if speed = 3. speed = 2 gives -O still 2001-04-13 Bill Schelter * fix the NULL_OR_ON_C_STACK macro for x86 linux in notcomp.h and in 386-linux.h 2001-01-30 Bill Schelter * many changes added for MS windows version.. * add check on CSTACK_ADDRESS to configure for NULL_OR_ON_C_STACK 2000-10-27 Bill Schelter * o/file.d bug in close_stream * add xbin/386-linux-fix to knock the -O4 flag off of gcc if it is version 2.96 because of a C compiler bug * fixes to configure.in to better find the tcl tk stuff. 2000-06-01 Bill Schelter * o/print.d: change printing of pathnames to use the more standard #p"foo.bar" instead of #"foo.bar" * o/read.d: allow pathnames #p"foo.bar" instead of just #"foo.bar" as many implementations do. 2000-05-13 Bill Schelter * fix readme file * update gcl-2.3/mp/mpi-sol-sparc.s for the 'sparc' version. * number of changes to 'configure.in' to handle finding paths correctly. 2000-05-02 Bill Schelter * rsym_elf.c (out;): strip off the @@GLIB* from symbols, in the base image, since this is not added to .o files With advent of GLIB2.0 this addition to the symbol was made. This will allow dynamic linking of the raw_gcl with the C library. * remove the -static default from the 386-linux.defs file, so that links will by default be dynamic for libc .. Fri Mar 28 16:23:18 1997 Bill Schelter * fix o/unexelf.c for section following bss overlapping it. * fix some of the install sections in makefile * add man page. Wed Mar 12 14:11:01 1997 Bill Schelter * makefile (go): change to remove typo o${..} in makefile in the install script * change DIR= to GCL_TK_DIR= in gcl-tk/gcltksrv* and in makefile, gcl-tk/makefile. Plain DIR= was causing the replacement (in sed in makefiles) of other other variables ending in DIR= .. Sun Dec 8 18:31:38 1996 Bill Schelter * release 2.2.1 contains various fixes to unexec and to makefiles, for building on current systems. Mon Dec 2 20:36:28 1996 Bill Schelter * o/gbc.c: make the marking of MVloc go in the right direction. important for problems that use mv_ref methods.. Thu Nov 9 18:09:01 1995 Bill Schelter * fixes for format and structure printing. * fixes to calls to FEerror * arrange so that static arrays stay static on growing via adjust-array or via output with string stream stuff Mon Oct 30 20:42:17 1995 Bill Schelter * o/print.d (BEGIN): fix (defstruct (foo (:print-function print-foo)) junk) (defun print-foo (foo stream depth) (format stream "#" (foo-junk foo))) bug. [with the printStructBufp value being nulled] * add-defs sets TCL_LIBRARY, and gcltksrv sets it.. * fixes to support solaris-i386 [in rsym_elf.c, sfaslelf.c * ./add-defs fix order of tests of paths... Fri Oct 20 01:15:47 1995 Bill Schelter * fix initialization of *link-array* to be a string.. [remove from cmptop.lsp] * misc fixes in gbc.c and sgbc.c * fix to profiling. Wed Oct 18 00:16:59 1995 Bill Schelter * (format nil "~5,,X" 10) made to work. Note the ansi draft neither condones nor prohibits this. Normally the , is a place holder and there is a argument after the last , and then comes the directive. Here the commas dont hold a place. * fix bv.bv_offset problem... the move to 64 bit machines caused it to be impossible to have some structure fields overlap the way they once did. added BV_OFFSET(x) and SET_BV_OFFSET(x,val) macros. * fix add-defs to make clxsocket.o not be compiled in case of no X11 include files found. Tue Oct 17 13:21:38 1995 Bill Schelter * fix the (write 3) bug... in print.d Wed Oct 11 23:00:34 1995 Bill Schelter * merge in billm's elf support for linux, and repair the changes effects on regular a.out linux * switch to unexec from 19.29 for versions using either the regular or elf unexec from emacs Sun Oct 1 19:52:45 1995 Bill Schelter * Many changes to gcl 2.1 to support 64 bit machines (eg Dec alpha). Layout of structures etc changed. * a gcl-2.2 beta was released in the summer. since then there have been several bugs fixed. One in cmpfun.lsp affecting write, and another in init_gcl.lsp to make sure the link array is a string array (changed from fixnum which are no longer sufficient to hold pointers). * changes to fix for PA risc hpux in the hp800.h * changes to unexec-19.27.c to allow MUCH faster saving in NFS environment. * testing with maxima 5.1 * reworking makefiles * (write 2) bug fixed. (in compiler) * (aref #*11111 0) fixed (was different bv_elttype field) Sun Apr 30 18:28:07 1995 Bill Schelter * various fixes to array.c for bitarrays and non 1 dimensional arrays * fix to Ieval * verify that pcl and clx work with these changes. Sun Apr 9 21:24:38 1995 Bill Schelter * (ln): Sat Apr 1 14:01:35 1995 Bill Schelter * There have been an infinite number of changes for gcl-2.0 * GCL now contains a tcl/tk windowing interface. It is based on TCL 7.3 and TK 3.6 available from ftp.cs.berkeley.edu and many mirrors. See the gcl-tk/demos/widget.lisp file for the demos. * support for gzipped files (setq si::*allow-gzipped-file* t) to allow it. (load "foo.o") will look for "foo.o.gz" if it does not find foo.o. Writing gzipped files is not supported. * Command line args: See the documentaion in the info directory under command line. `-eval' `-load' etc. `-f' allows shell scripts to be made such as ================== #!/usr/local/bin/gcl.exe -f (print "hello world") ================== * All documentation converted to texinfo, info format and extended. Ansi common lisp documentation converted to texinfo * interrupts completely changed, to be more robust and to allow communication with tk. * regexp matching introduced see 'string-match' gcl/README.macosx000066400000000000000000000004401242227143400137730ustar00rootroot00000000000000On some recent mac boxes (e.g. 10.6) running 64bit capable processors, the default configure scripts detect the cpu as 32bit only. To get a 64bit build, do: ./configure --build=x86_64-apple-darwin10.4.0 .... where the key item is the x86_64, and some darwin string in the last place. gcl/README.openbsd000066400000000000000000000022711242227143400141370ustar00rootroot00000000000000Building and using GCL 2.6.2 on OpenBSD PLATFORMS --------- GCL has only been tested on OpenBSD/i386 3.4. Newer versions should work as well. Other hardware platforms are unchartered land. TOOLS ----- You need GNU make to compile GCL. If you have installed the ports tree, you can get it by running the following as root: cd /usr/ports/devel/gmake make install It is then installed as `gmake'. The sed that ships with OpenBSD 3.4 has a bug (PR 3677) which is triggered by the GCL makefiles. You can use either the sed of 3.5 or GNU sed. Make sure the correct sed comes first in your PATH. BUILDING -------- There's nothing special to do for OpenBSD; GCL should build out of the box. The OpenBSD version shares makefiles with FreeBSD, so don't be surprised when you see "FreeBSD" in the output. NOTES ----- The default limits on data segment size are 64MB (soft) and 256MB (hard). GCL will automatically raise the soft limit to the hard limit, but you may find that it runs out of memory anyway. If so, you can change the limits in /etc/login.conf. For the record, the W^X feature of OpenBSD is disabled, since it interfers with the way GCL dumps its executable. Magnus Henoch, 12 June 2004 gcl/README.wine000066400000000000000000000005331242227143400134460ustar00rootroot00000000000000On Debian, for example, gcl can be run and tested under wine as follows: (as root) aptitude install mingw32 mingw32-runtime mingw32-binutils wine If necessary, as root update-binfmts --enable wine Then as a normal user, export PATH=/usr/i586-mingw32msvc/bin:$PATH export CC=/usr/bin/i586-mingw32msvc-gcc ./configure --host=mingw32 && make gcl/RELEASE-2.5.1000066400000000000000000000124251242227143400132740ustar00rootroot00000000000000RELEASE NOTES FOR 2.5.1: ======================== The GNU Common Lisp (GCL) development team is pleased to release Version 2.5.1, the first major release since the untimely death of the former maintainer Dr William Schelter over a year ago. This release is dedicated to his memory. The project is now hosted on http://savannah.gnu.org/projects/gcl/ and is maintained and developed by a team of thirteen programmers. Our home page lives at http://www.gnu.org/software/gcl/. This release stabilizes the CLtL1 compliant build of GCL on most major Unices including 11 Debian Linux 64 and 32 bit architectures and modern versions of Microsoft Windows (TM). A rapidly progressing, partially ANSI compliant version is also available on the Linux platforms. GCL plays a substantial role in development of the Maxima computer algebra system (http://maxima.sourceforge.net/), ACL2, a computational logic system (http://www.cs.utexas.edu/users/moore/acl2/), and the forthcoming public release of the Axiom computer algebra system.. The compiler is a descendant of the famous KCL and AKCL Common Lisp compilers and is licensed under version two of the GNU Library General Public License. As with any Lisp system GCL is a lot of fun to work with. We welcome all comments and feedback. Developers are particularly welcome too. You will find that the project offers a wide variety of challenges on various platforms to anyone with an interest in compilers, low level C programming or Common Lisp. ----- Features: * Compiles itself, maxima, and acl2, passing all tests, on 11 Debian GNU/Linux platforms (i386, sparc, powerpc, s390, ia64, alpha, mips, mipsel, hppa, arm, and m68k), Sparc Solaris, and recent Windows systems. * Compilation to native object code. Lisp disassembly shows intermediate C source and native assembler. * Native code relocation on all supported platforms except alpha, mips, mipsel, ia64, and hppa. * Can save its running memory image to a file on all systems where native object code relocation is supported, thus producing standalone executables. * Compiles Lisp function calls to C function calls with inlined arguments, when function proclamation/declamations are made. * Quite fast, particularly if one pre-allocates memory to be commensurate with that typically available on modern computer systems. (see below) * A foreign function interface as flexible in principle as the C interface. * Socket support via streams * Support for numbers of arbitrary precision via the GNU Multiprecision Library. If you build GCL on your own system, multiprecision numerical support will make use of ISA extension instructions available on your system for maximum large number performance. * An exact garbage collector with no (known) leaks. * An ANSI mode on Unix systems which passes approximately 97% of the ANSI compliance tests currently developed for the project. On Debian GNU/Linux systems, this mode can be selected by setting the GCL_ANSI environment variable to any non-empty string. See /usr/share/doc/gcl/test_results on Debian GNU/Linux systems. * An MPI extension for cluster computing support. See the website for details. * A long history of leveraging GCC compiler technology for use in production lisp applications. ----- GCL is one of the oldest Lisp systems still in use, and as such has served as the basis for large lisp applications when computers were much more limited than they are today, particularly in terms of available memory. Considerable effort was therefore made in the past to keep the memory image as small as possible. As of the present time, the GCL team has not tuned the default memory allocation scheme to be more in line with modern systems. One can therefore often get significant performance increases by preallocating memory, as in for example (progn (si::allocate 'cons 10000 t) (si::allocate 'fixnum 200 t) (si::allocate 'symbol 100 t) (si::allocate-relocatable-pages 2000 t) (si::allocate 'cfun 1000 t)) Optimal values will no doubt vary by application and machine. One user/developer reports effects of the following magnitude when using preallocation: ######## Take a look on some funny numbers below. This is time and RAM required to compute ratsimp((x+y+z)^300)$ on Linux AthlonXP 2400+. For GCL run time is in the form T - G = N, where T is the total time as shown by showtime:true; G is total GC tome and N is run time without GC. Lisp Time RAM RAM RAM [sec] before max after T - G = N [Mb] [Mb] [Mb] ===================================================== CLISP 4.6 5.5 29 16 CMUCL 1.6 6.5 31 31 GCL class 5.9 - 5.2 = 0.7 8 24 24 GCL ansi 9.5 - 8.9 = 0.6 9.5 29 29 GCL class 1.0 - 0.4 = 0.6 24 31 31 GCL ansi 1.1 - 0.6 = 0.5 25 32 32 GCL class 0.7 - 0.1 = 0.6 48 55 55 GCL ansi 0.5 - 0.0 = 0.5 49 56 56 ==================================================== ######## TO DO: 1) Full ANSI compliance 2) Native optimized blas support 3) Integrate MPI support 4) GCL as a suported GCC front end. 5) Performance/memory optimization gcl/RELEASE-2.6.2.html000066400000000000000000001632551242227143400142510ustar00rootroot00000000000000 GCL 2.6.2 tests

GCL 2.6.2 RELEASE NOTES

The GCL team is happy to announce the release of version 2.6.2, the latest achievement in the 'stable' series.  While strictly speaking a bug-fix only release, 2.6.2 incorporates several major improvements over the last stable release, 2.5.3.  Some highlights:

  • The development of a 'lisp compiler torture tester' by GCL developer Paul Dietz which repeatedly compiles randomly generated forms of specifiable length to test the compiler for correctness.
  • The application of several significant corrections to the GCL lisp compiler to remove every known instance of miscompilation uncovered by this tester.  To our knowledge, GCL is alone with CLISP in passing this torture test for runs of effectively indefinite length.
  • Major performance improvements were applied to the lisp compiler to enable it to complete random tests of great length in a reasonable amount of time. 
  • Corrections to the GCL core files to enable very large image sizes in 64 bits, in which more than a billion cons cells can be allocated.  Current 64bit options include amd64, ia64, and alpha running most flavors of GNU/Linux.
  • Corrections to the heap scaling behavior of the garbage collector, resulting in significant performance gains in many instances.
  • Support for the latest gcc and binutils versions on all platforms but mingw
  • The elimination of many instances of unnecessary internal garbage generation bringing the associated performance gains
  • Native support for execstack protected linux kernels, such as on Fedora core systems
  • Native support for FreeBSD, OpenBSD, and MacOSX
  • Static function pointer support to stabilize dynamic library usage on Itanium systems
  • Transparent readline initialization when compiled in
  • Support for profiling via gprof
  • Automatic disabling of SGC (stratified garbage collection) if the image is executed on a kernel not supporting fault address recovery
  • Remove a memory leak associated with heavy bignum usage via the introduction of SGC contiguous pages
  • Several significant internal bug fixes, epecially in the mingw port.
  • Alter the build process to perform a full self compile with full function proclamation at build time.
  • GCL now compiles Axiom from scratch and carries it to all supported platforms with the current exception of mingw
  • GCL's ANSI build now in use for its first end-user application -- maxima (current cvs)
  • New 64bit platform support -- amd64, with full native object relocation
The full changelog can be found in the source tree in the file 'debian/changelog'.

 
The GCL team has subjected this release to a wide variety of tests and benchmarks.  While all such results are necessarily incomplete, one can nevertheless usefully summarize the approximate state of affairs as follows:
  • GCL is about as portable as CLISP
  • The GCL lisp compiler is about as robust/correct as that of CLISP, at least as measured by the random tester, which at present only covers a mostly integer subset of lisp.
  • GCL is about as fast as CMUCL
  • GCL plays a major role in carrying the primary large open source lisp end user applications to a wide variety of systems
  • GCL is still the least ANSI compliant of the freely available lisp systems,  though a modest level of compliance has been achieved in this release.  Much greater compliance has been achieved in the 2.7.x (cvs unstable) series yet to be officially released.

The specific test results are arranged in the following table.  Some terms need defining:

BFD
 the method of relocating compiled lisp object modules into the running executable using the BFD library
custreloc
 the method of relocating compiled lisp object modules into the running executable using the native GCL code.  This method as well as the BFD method preserve the module loading across image saving and re-execution
dlopen
 the method of dynamically linking in compiled lisp object modules into the existing session only via the system dynamic linker loader, ld.so.
SGC
 Stratified Garbage Collection -- an optional accelerated generational garbage collection algorithm employing read-only memory
CLtL1
 Common Lisp, the Language vol I, referring to the book of the same name by Steele defining a widely used lisp language standard prior to the ANSI standardization process in 1994.
ANSI
 the work in progress image build attempting to eventually extend traditional GCL into full ANSI complaince
Ansi tests
 the results of the work in progress ansi compliance test suite written by GCL developer Paul Dietz presented as the number of failures divided by the total number of tests run
Random tests
 the results of the random 'compiler torture tester' presented as the number of tests/the size of the random forms/the number of variables passed to the random function


In the table below, green denotes a pass, yellow denotes an as yet unimplemented option, and red indicates failure.  Blank cells indicate tests that have not been run.

System
 CPU
 Self Build
 BFD
 dlopen
 custreloc
 Preferred
Linking
 SGC
 CLtL1
 ANSI
 ANSI tests
 Random tests
 Maxima 5.9.0/CLtL1
(4)
 Maxima CVS/ANSI
(4)
 ACL2 2.8/CLtL1
(5)
 Axiom CVS/CLtL1
(6)
 nqthm
CLtL1
 pc-nqthm
CLtL1
Debian GNU/Linux (sid)
 i386



bfd
or
custreloc


303/
10697
 50000/10000/8
500000/1000/8




(setq si::*multiply-stacks* 16)
Debian GNU/Linux (sid)
 sparc



bfd
or
custreloc


303/
10697






Debian GNU/Linux (sid)
 powerpc



bfd


303/
10697






Debian GNU/Linux (sid)
 amd64



bfd


303/
10697






Debian GNU/Linux (sid)
 arm



bfd


303/
10697






Debian GNU/Linux (sid)
 m68k



bfd


303/
10697






Debian GNU/Linux (sid)
 s390



bfd


303/
10697






Debian GNU/Linux (sid)
 ia64



dlopen


303/
10697



(1)

Debian GNU/Linux (sid)
 hppa
 -O0


dlopen


303/
10697



(1)

Debian GNU/Linux (sid)
 mips



dlopen


303/
10697



(1)

Debian GNU/Linux (sid)
 mipsel



dlopen


303/
10697



(1)

Debian GNU/Linux (sid)
 alpha



dlopen


303/
10697



(1)

Fedora FC1
 i386



bfd or
custreloc


303/
10697
 12000/1000/8





Solaris
 sparc



bfd or
custreloc


303/
10697
 4000/1000/8
(4)





Windows MINGW(a)
 i386



custreloc



303/
10697
 57000/1000/8


(2)

MacOSX
 powerpc



bfd
 (3)

303/
10697






OpenBSD
 i386



bfd


303/
10697






FreeBSD
 i386



custreloc


303/
10697

























Notes:

(1) dlopen builds use file descriptors for each object load.  The step in the Axiom build process which regenerates its databases consumes more than the conventional maximum of 1024 file descriptors available by default on most UNIX systems.
(2) An AXIOMsys executable can be produced, and is basically functional, but experiences sporadic errors of a type as yet unknown.
(3) This is known to work on at least some versions of the OS, but others report a hang (infinite loop) when enabling SGC.  It is possible that this is due to a mprotect bug in older versions of the Darwin system shared libraries.  'compatibility version of user 6.0.0' appears to work.
(4) On this machine, the underlying gcc was old (3.0) and segfaulted outside of GCL when attempting to compile its produced C code after a few thousand        iterations.

(a) The preferred build environment for Mingw/Windows is gcc 3.3.1, binutils 2.14.90, and the latest msys release.



The following table presents the results of the popular gabriel benchmarks of three freely available lisp systems, GCL, CLISP and CMUCL.  Times are presented as multiples of the time GCL took in completing the tests.  Green  indicates tests on which GCL is the fastest, while red indicates tests on which GCLwas not the fastest.   The benchmark code can be found in ftp://ftp.ma.utexas.edu/gcl/gabriel.tgz.  The number of test iterations has been increased by a factor of 400 to overcome granularity issues on modern machines.  The '(print (time ...))' statements around each test iteration were removed, again due to granularity and relative i/o load.  Likewise the special init.lsp file conventionally used to preallocate GCL memory in such cases was removed as it is now mostly obsolete.  Finally the tests were modified slightly to place the optimization declamations at the top of each file being compiled as suggested by a CMUCL expert.

As with any benchmark, results can vary somewhat with the details of the executing machine.  With lisp in particular, the ratios of the cache sizes, cpu speed, and memory bandwidths can impact such tests significantly.  We present the results for two popular configurations below.  While the precise details of the differences are as yet known, it is speculated that the first result is more dominated by in-cache cpu performance, while the latter is more dominated by memory access efficiency.

Dual Intel Xeon 2.4Ghz, 512 Mb, Linux 2.4.20
 Athlon XP 3000+ (2.1Ghz), 512 Mb, Linux 2.4.26
Benchmark
 GCL
2.6.2
 CMUCL 18e-9
 CLISP
2.33-2

BOYER
1.000
2.200
9.869

BROWSE
1.000
2.240
NA

CTAK
1.000
0.230
1.890

DDERIV
1.000
2.148
2.909

DERIV
1.000
2.083
3.640

DESTRU-MOD
1.000
2.043
9.880

DESTRU
1.000
1.168
5.743

DIV2
1.000
2.222
3.911

FFT-MOD
1.000
1.585
206.057

FFT
1.000
1.544
176.088

FPRINT
1.000
2.136
3.742

FREAD
1.000
1.746
2.111

FRPOLY
1.000
1.524
5.112

PUZZLE-MOD
1.000
10.824
41.618

PUZZLE
1.000
11.324
37.671

STAK
1.000
1.536
9.836

TAK-MOD
1.000
1.465
15.053

TAK
1.000
1.486
14.629

TAKL
1.000
1.419
14.965

TAKR
1.000
1.933
12.327

TPRINT
1.000
0.937
1.263

TRAVERSE
1.000
0.875
8.378

TRIANG-MOD
1.000
7.067
26.814

TRIANG
1.000
1.281
18.565
GEOMETRIC
AVERAGE
1.00
1.86
10.33
MEDIAN
 1.00
 1.67
 9.87
Benchmark
 GCL
2.6.2
 CMUCL 18e
 CLISP
2.33

BOYER
1.000
0.892
6.316

BROWSE
1.000
0.965
NA

CTAK
1.000
0.435
3.489

DDERIV
1.000
0.822
1.579

DERIV
1.000
0.651
1.639

DESTRU-MOD
1.000
0.812
4.779

DESTRU
1.000
0.550
3.239

DIV2
1.000
0.599
1.525

FFT-MOD
1.000
2.655
337.207

FFT
1.000
1.923
251.026

FPRINT
1.000
2.322
3.508

FREAD
1.000
1.890
1.900

FRPOLY
1.000
1.013
3.606

PUZZLE-MOD
1.000
5.976
20.350

PUZZLE
1.000
5.472
19.387

STAK
1.000
1.655
8.064

TAK-MOD
1.000
1.382
14.775

TAK
1.000
1.399
14.514

TAKL
1.000
1.281
12.877

TAKR
1.000
1.735
15.500

TPRINT
1.000
2.008
1.674

TRAVERSE
1.000
0.770
8.013

TRIANG-MOD
1.000
6.639
25.182

TRIANG
1.000
1.186
16.948
GEOMETRIC
AVERAGE
1.00
1.40
8.46
MEDIAN
 1.00
 1.33
 8.01


Many improvements are planned for the 2.7.x development series time permitting, the most important of which is to complete the task of building an ANSI compliant GCL image. 







gcl/add-defs000077500000000000000000000077741242227143400132400ustar00rootroot00000000000000#!/bin/sh if [ $# -le 0 ] ; then echo usage: ./add-defs machine-type; echo or ' ' ./add-defs machine-type directory echo where directory might be '/usr/local' or '/public' or '/lusr' -- a place to find various local includes or libs echo see echo h/*.defs exit 1 ; fi if [ -f h/$1.defs ] ; then echo using $1.defs ; else echo h/$1.defs does not exist echo Build one or use one of `ls h/*.defs` exit 1 fi echo $1 > machine rm -f makedefs echo > makedefs echo "# begin makedefs" >> makedefs echo "# constructed by ${USER} using: $0 $1 $2 $3 $4 $5" >> makdefs if [ -d ${PWD}/unixport ] ; then echo "GCLDIR=${PWD}" >> makedefs ; else echo "GCLDIR=`pwd`" >> makedefs ; fi echo "SHELL=/bin/sh" >> makedefs echo "MACHINE=$1" >> makedefs # a place where you keep local things. Changing this may help to # find things, otherwise edit the "LIST-OF-DIRECTORIES" for the # given item. if [ "$2x" != "x" ] ; then PUBLIC=$2 ; else PUBLIC=/public fi export PUBLIC TK_XINCLUDES=-Iunknown # `add-dir' searches for ITEM in LIST-OF-DIRECTORIES and then sets the # directory in VARIABLE-SETTING-TEMPLATE #Usage: ./xbin/add-dir ITEM LIST-OF-DIRECTORIES VARIABLE-SETTING-TEMPLATE ./xbin/add-dir tkConfig.sh "${PUBLIC}/lib /usr/lib /usr/local/lib" 'TK_CONFIG_PREFIX="$v"' ./xbin/add-dir tclConfig.sh "${PUBLIC}/lib /usr/lib /usr/local/lib" 'TCL_CONFIG_PREFIX="$v"' ./xbin/add-dir dir "/usr/local/lib/info ${PUBLIC}/lib/info /usr/lib/info" 'INFO_DIR="$v"' SOURCE=. ${SOURCE} makedefs if [ -f ${TK_CONFIG_PREFIX}/tkConfig.sh -a \ -f ${TCL_CONFIG_PREFIX}/tclConfig.sh ] ; then ${SOURCE} ${TK_CONFIG_PREFIX}/tkConfig.sh ; ${SOURCE} ${TK_CONFIG_PREFIX}/tclConfig.sh ; ./xbin/add-dir tk.h "${PUBLIC}/include /usr/include /usr/local/include" 'TK_INCLUDE="-I$v"' echo "TK_VERSION=${TK_VERSION}" >> makedefs echo "TCL_VERSION=${TCL_VERSION}" >> makedefs echo "TK_LIB_SPEC=${TK_LIB_SPEC}" >> makedefs echo "TK_LIBRARY=${TK_CONFIG_PREFIX}/tk${TK_VERSION}" >> makedefs echo "TCL_LIBRARY=${TCL_CONFIG_PREFIX}/tcl${TCL_VERSION}" >> makedefs echo "TK_BUILD_LIB_SPEC=${TK_BUILD_LIB_SPEC}" >> makedefs echo "TK_XLIBSW=${TK_XLIBSW}" >> makedefs TK_XLIB_DIR=`echo ${TK_XLIBSW} | sed "s:-L\\([^ ]*\\) .*:\\1:g"` echo "TK_XLIB_DIR=${TK_XLIB_DIR}" >> makedefs echo "TK_XINCLUDES=${TK_XINCLUDES}" >> makedefs echo "TCL_LIB_SPEC=${TCL_LIB_SPEC}" >> makedefs echo "TCL_DL_LIBS=${TCL_DL_LIBS}" >> makedefs echo "TCL_LIBS=${TCL_LIBS}" >> makedefs echo "HAVE_X11=-DHAVE_X11" >> makedefs else echo "TK_CONFIG_PREFIX=unknown" >> makedefs ./xbin/add-dir X11/Xos.h "${PUBLIC}/include /usr/include /usr/local/X11R6/include /usr/local/X11/include " 'TK_XINCLUDES="-I$v"' . makedefs if [ "$TK_XINCLUDES" = "-Iunknown" ] ; then echo "cant find X11 includes so not defining HAVE_X11" else echo HAVE_X11=-DHAVE_X11 >> makedefs fi echo unable to find tkConfig.sh and tclConfig.sh so not configuring tcl/tk fi ####machine specific .defs files may over ride the above#### ####### insert the h/machine.defs file ############ cat h/$1.defs >> makedefs if [ -f ${HOME}/local_gcl.defs ] ; then cat ${HOME}/local_gcl.defs >> makedefs fi echo "# end makedefs" >> makedefs echo inserting h/$1.defs in .. for v in makefile unixport/make_kcn */makefile ; do echo " $v," ./bin/file-sub makedefs $v "# begin makedefs" "# end makedefs" tmpx mv tmpx $v done echo "" # Copy the config.h over. cat h/$1.h > tmpx if [ -f ${HOME}/local_gcl.h ] ; then cat ${HOME}/local_gcl.h >> tmpx fi if fgrep =unknown makedefs > /dev/null ; then echo " if the 'unknown' directories exist you may provide a second argument to ./add-defs of a local directory where things might be, or edit ./add-defs so that it can find them. Otherwise just continue and the portions with unknown will not be compiled." fi if cmp tmpx h/config.h > /dev/null 2>&1 ;then true; else rm -f h/config.h cp tmpx h/config.h fi rm -f tmpx # machine specific stuff that cant be handled normally... if [ -f ./xbin/$1-fix ] ; then ./xbin/$1-fix ; fi gcl/add-defs.bat000077500000000000000000000031571242227143400137740ustar00rootroot00000000000000@echo off if .%1==. goto err_param if NOT EXIST h\%1.def goto err_not_found IF EXIST unixport\saved_kc.exe goto found_saved_kcl_exe echo WARNING : unixport/saved_kcl.exe file not found echo _ you will not be able to recompile the .lsp files echo _ nor start akcl :found_saved_kcl_exe echo %1 > machine if .%2==. goto only_1_param if exist %2\c\print.d goto only_1_param echo %2 is not the main kcl directory :only_1_param make -f Smakefile merge copy tmpxx_.tem tmpxx del makedefs echo AKCLDIR=/akcl >makedefs echo SHELL=/bin/sh >>makedefs echo MACHINE=%1 >>makedefs type h\%1.def >>makedefs if exist %2\c\print.d echo MAINDIR = %2 >> makedefs type makedefs >>tmpxx echo # end makedefs >>tmpxx echo @s] >> tmpxx echo inserting h\%1.def in .. for %%v in (Smakefile mp\makefile o\makefile lsp\makefile cmpnew\makefile dos\makefile) do go32 merge %%v tmpxx %%v.new for %%v in (Smakefile mp\makefile o\makefile lsp\makefile cmpnew\makefile dos\makefile) do if exist %%v.new mv %%v %%v.bak for %%v in (Smakefile mp\makefile o\makefile lsp\makefile cmpnew\makefile dos\makefile) do if exist %%v.new mv %%v.new %%v go32 merge unixport\makefile.dos tmpxx unixport\makefile.new if exist unixport\makefile.new mv unixport\makefile.dos unixport\makefile.bak if exist unixport\makefile.new mv unixport\makefile.new unixport\makefile.dos rem rm -f Vmakefile rem rm -f tmpxx rem Copy the config.h over. copy h\%1.h h\config.h rem fix the cmpinclude.h goto end :err_param echo usage: Provide a machine name as arg goto end :err_not_found echo h\%1.def does not exist echo Build one or use one of `ls h\*.def` goto end :end gcl/add-defs1000077500000000000000000000042301242227143400133010ustar00rootroot00000000000000#!/bin/sh #CC=cc if test "$1" = "mingw" -o "$1" = "gnuwin95" ; then EXE=.exe ; # CC=gcc rm -f o/*.ini fi #(cd bin ; make file-sub EXE=${EXE} CC=${CC}) if [ $# -le 0 ] ; then echo usage: ./add-defs machine-type; echo or ' ' ./add-defs machine-type directory echo where directory might be '/usr/local' or '/public' or '/lusr' -- a place to find various local includes or libs echo see echo h/*.defs exit 1 ; fi if [ -f h/$1.defs ] ; then echo using $1.defs ; else echo h/$1.defs does not exist echo Build one or use one of `ls h/*.defs` exit 1 fi echo $1 > machine # rm -f makedefs # echo > makedefs # echo "# begin makedefs" >> makedefs # echo "# constructed by ${USER} using: $0 $1 $2 $3 $4 $5" >> makdefs rm -f makedefs cp makedefc makedefs if [ -d ${PWD}/unixport ] ; then echo "GCLDIR=${PWD}" >> makedefs ; else echo "GCLDIR=`pwd`" >> makedefs ; fi echo "SHELL=/bin/sh" >> makedefs echo "MACHINE=$1" >> makedefs ####machine specific .defs files may over ride the above#### ####### insert the h/machine.defs file ############ cat h/$1.defs >> makedefs if [ -f makedefsafter ] ; then cat makedefsafter >> makedefs ; fi if [ -f ${HOME}/local_gcl.defs ] ; then cat ${HOME}/local_gcl.defs >> makedefs fi echo "" >> makedefs echo "# end makedefs" >> makedefs # echo inserting h/$1.defs in .. # for v in makefile unixport/make_kcn */makefile ; # do # echo " $v," # ./bin/file-sub makedefs $v "# begin makedefs" "# end makedefs" tmpx # mv tmpx $v # done # #echo "" # Copy the config.h over. cat h/$1.h > tmpx if [ -f ${HOME}/local_gcl.h ] ; then cat ${HOME}/local_gcl.h >> tmpx fi if fgrep =unknown makedefs > /dev/null ; then echo " if the 'unknown' directories exist you may provide a second argument to ./add-defs of a local directory where things might be, or edit ./add-defs so that it can find them. Otherwise just continue and the portions with unknown will not be compiled." fi if cmp tmpx h/config.h > /dev/null 2>&1 ;then true; else rm -f h/config.h cp tmpx h/config.h fi rm -f tmpx # machine specific stuff that cant be handled normally... if [ -f ./xbin/$1-fix ] ; then ./xbin/$1-fix ; fi gcl/ansi-tests/000077500000000000000000000000001242227143400137165ustar00rootroot00000000000000gcl/ansi-tests/.cvsignore000066400000000000000000000000411242227143400157110ustar00rootroot00000000000000*.fn *.x86f *.fasl *.ufsl binary gcl/ansi-tests/README000066400000000000000000000005401242227143400145750ustar00rootroot00000000000000This directory contains a partial Common Lisp standards compliance test suite. To run the tests, load gclload.lsp. This will load and run the tests. To just load the tests, load gclload1.lsp and gclload2.lsp. Individual tests may be run by (rt:do-test '). Please tell me when you find incorrect test cases. Paul Dietz dietz@dls.net gcl/ansi-tests/adjustable-array-p.lsp000066400000000000000000000032061242227143400201260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 20 21:25:22 2003 ;;;; Contains: Tests for ADJUSTABLE-ARRAY-P (in-package :cl-test) (deftest adjustable-array-p.1 (notnot (adjustable-array-p (make-array '(5) :adjustable t))) t) (deftest adjustable-array-p.2 (notnot (adjustable-array-p (make-array nil :adjustable t))) t) (deftest adjustable-array-p.3 (notnot (adjustable-array-p (make-array '(2 3) :adjustable t))) t) (deftest adjustable-array-p.4 (notnot (adjustable-array-p (make-array '(2 2 2) :adjustable t))) t) (deftest adjustable-array-p.5 (notnot (adjustable-array-p (make-array '(2 2 2 2) :adjustable t))) t) (deftest adjustable-array-p.order.1 (let ((i 0) x) (values (notnot (adjustable-array-p (progn (setf x (incf i)) (make-array '(5) :adjustable t)))) i x)) t 1 1) ;;; Error tests (deftest adjustable-array-p.error.1 (classify-error (adjustable-array-p)) program-error) (deftest adjustable-array-p.error.2 (classify-error (adjustable-array-p "aaa" nil)) program-error) (deftest adjustable-array-p.error.3 (classify-error (adjustable-array-p 10)) type-error) (deftest adjustable-array-p.error.4 (let (why) (loop for e in *mini-universe* unless (or (typep e 'array) (eq 'type-error (setq why (classify-error** `(adjustable-array-p ',e))))) collect (list e why))) nil) (deftest adjustable-array-p.error.5 (classify-error (locally (adjustable-array-p 10))) type-error) (deftest adjustable-array-p.error.6 (classify-error (let ((x 10)) (locally (declare (optimize (safety 3))) (adjustable-array-p x)))) type-error) gcl/ansi-tests/and.lsp000066400000000000000000000014401242227143400151770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 07:23:48 2002 ;;;; Contains: Tests for AND (in-package :cl-test) (deftest and.1 (and) t) (deftest and.2 (and nil) nil) (deftest and.3 (and 'a) a) (deftest and.4 (and (values 'a 'b 'c)) a b c) (deftest and.5 (and (values))) (deftest and.6 (and (values t nil) 'a) a) (deftest and.7 (and nil (values 'a 'b 'c)) nil) (deftest and.8 (and (values 1 nil) (values nil 2)) nil 2) (deftest and.9 (and (values nil t) t) nil) (deftest and.order.1 (let ((x 0)) (values (and nil (incf x)) x)) nil 0) (deftest and.order.2 (let ((i 0) a b c d) (values (and (setf a (incf i)) (setf b (incf i)) (setf c (incf i)) (setf d (incf i))) i a b c d)) 4 4 1 2 3 4) gcl/ansi-tests/ansi-aux.lsp000066400000000000000000001300461242227143400161670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 17:10:18 1998 ;;;; Contains: Aux. functions for CL-TEST (in-package :cl-test) (declaim (optimize (safety 3))) ;;; A function for coercing truth values to BOOLEAN (defun notnot (x) (not (not x))) (defmacro notnot-mv (form) `(notnot-mv-fn (multiple-value-list ,form))) (defun notnot-mv-fn (results) (if (null results) (values) (apply #'values (not (not (first results))) (rest results)))) (defmacro not-mv (form) `(not-mv-fn (multiple-value-list ,form))) (defun not-mv-fn (results) (if (null results) (values) (apply #'values (not (first results)) (rest results)))) ;;; Macro to check that a function is returning a specified number of values ;;; (defaults to 1) (defmacro check-values (form &optional (num 1)) (let ((v (gensym)) (n (gensym))) `(let ((,v (multiple-value-list ,form)) (,n ,num)) (check-values-length ,v ,n ',form) (car ,v)))) (defun check-values-length (results expected-number form) (declare (type fixnum expected-number)) (let ((n expected-number)) (declare (type fixnum n)) (dolist (e results) (declare (ignore e)) (decf n)) (unless (= n 0) (error "Expected ~A results from ~A, got ~A results instead.~%~ Results: ~A~%" expected-number form n results)))) ;;; Do multiple-value-bind, but check # of arguments (defmacro multiple-value-bind* ((&rest vars) form &body body) (let ((len (length vars)) (v (gensym))) `(let ((,v (multiple-value-list ,form))) (check-values-length ,v ,len ',form) (destructuring-bind ,vars ,v ,@body)))) ;;; Comparison functions that are like various builtins, ;;; but are guaranteed to return T for true. (defun eqt (x y) "Like EQ, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (eq x y))))) (defun eqlt (x y) "Like EQL, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (eql x y))))) (defun equalt (x y) "Like EQUAL, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (equal x y))))) (defun equalpt (x y) "Like EQUALP, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (equalp x y))))) (defun =t (x &rest args) "Like =, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (apply #'= x args))))) (defun make-int-list (n) (loop for i from 0 below n collect i)) (defun make-int-array (n &optional (fn #'make-array)) (let ((a (funcall fn n))) (loop for i from 0 below n do (setf (aref a i) i)) a)) ;;; Return true if A1 and A2 are arrays with the same rank ;;; and dimensions whose elements are EQUAL (defun equal-array (a1 a2) (and (typep a1 'array) (typep a2 'array) (= (array-rank a1) (array-rank a2)) (if (= (array-rank a1) 0) (equal (aref a1) (aref a2)) (let ((ad (array-dimensions a1))) (and (equal ad (array-dimensions a2)) (if (= (array-rank a1) 1) (let ((as (first ad))) (loop for i from 0 below as always (equal (aref a1 i) (aref a2 i)))) (let ((as (array-total-size a1))) (and (= as (array-total-size a2)) (loop for i from 0 below as always (equal (row-major-aref a1 i) (row-major-aref a2 i))))))))))) ;;; *universe* is defined elsewhere -- it is a list of various ;;; lisp objects used when stimulating things in various tests. (declaim (special *universe*)) ;;; The function EMPIRICAL-SUBTYPEP checks two types ;;; for subtypeness, first using SUBTYPEP*, then (if that ;;; fails) empirically against all the elements of *universe*, ;;; checking if all that are in the first are also in the second. ;;; Return T if this is the case, NIL otherwise. This will ;;; always return T if type1 is truly a subtype of type2, ;;; but may return T even if this is not the case. (defun empirical-subtypep (type1 type2) (multiple-value-bind (sub good) (subtypep* type1 type2) (if good sub (loop for e in *universe* always (or (not (typep e type1)) (typep e type2)))))) ;;; Check that the subtype relationships implied ;;; by disjointness are not contradicted. Return NIL ;;; if ok, or a list of error messages if not. ;;; Assumes the types are nonempty. (defun check-disjointness (type1 type2) (append (check-subtypep type1 type2 nil) (check-subtypep type2 type1 nil) (check-subtypep type1 `(not ,type2) t) (check-subtypep type2 `(not ,type1) t) (check-subtypep `(and ,type1 ,type2) nil t) (check-subtypep `(and ,type2 ,type1) nil t) (check-subtypep `(and ,type1 (not ,type2)) type1 t) (check-subtypep `(and (not ,type2) ,type1) type1 t) (check-subtypep `(and ,type2 (not ,type1)) type2 t) (check-subtypep `(and (not ,type1) ,type2) type2 t) ;;; (check-subtypep type1 `(or ,type1 (not ,type2)) t) ;;; (check-subtypep type1 `(or (not ,type2) ,type1) t) ;;; (check-subtypep type2 `(or ,type2 (not ,type1)) t) ;;; (check-subtypep type2 `(or (not ,type1) ,type2) t) (check-subtypep t `(or (not ,type1) (not ,type2)) t) (check-subtypep t `(or (not ,type2) (not ,type1)) t) )) (defun check-equivalence (type1 type2) (append (check-subtypep type1 type2 t) (check-subtypep type2 type1 t) (check-subtypep `(not ,type1) `(not ,type2) t) (check-subtypep `(not ,type2) `(not ,type1) t) (check-subtypep `(and ,type1 (not ,type2)) nil t) (check-subtypep `(and ,type2 (not ,type1)) nil t) (check-subtypep `(and (not ,type2) ,type1) nil t) (check-subtypep `(and (not ,type1) ,type2) nil t) (check-subtypep t `(or ,type1 (not ,type2)) t) (check-subtypep t `(or ,type2 (not ,type1)) t) (check-subtypep t `(or (not ,type2) ,type1) t) (check-subtypep t `(or (not ,type1) ,type2) t))) (defun check-all-subtypep (type1 type2) (append (check-subtypep type1 type2 t) (check-subtypep `(not ,type2) `(not ,type1) t) (check-subtypep `(and ,type1 (not ,type2)) nil t) (check-subtypep t `(or (not ,type1) ,type2) t))) (defun check-all-not-subtypep (type1 type2) (append (check-subtypep type1 type2 nil) (check-subtypep `(not ,type2) `(not ,type1) nil))) (defun check-subtypep (type1 type2 is-sub &optional should-be-valid) (multiple-value-bind (sub valid) (subtypep type1 type2) (unless (constantp type1) (setq type1 (list 'quote type1))) (unless (constantp type2) (setq type2 (list 'quote type2))) (if (or (and valid sub (not is-sub)) (and valid (not sub) is-sub) (and (not valid) should-be-valid)) `(((SUBTYPEP ,type1 ,type2) cl-user::==> ,sub ,valid)) nil))) (defun check-type-predicate (P TYPE) "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE)) by applying both to all elements of *UNIVERSE*. Print message when a mismatch is found, and return number of mistakes." (loop for x in *universe* count (block failed (let ((p1 (handler-case (funcall P x) (error () (format t "(FUNCALL ~S ~S) failed~%" P x) (return-from failed t)))) (p2 (handler-case (typep x TYPE) (error () (format t "(TYPEP ~S '~S) failed~%" x TYPE) (return-from failed t))))) (when (or (and p1 (not p2)) (and (not p1) p2)) (format t "(FUNCALL ~S ~S) = ~S, (TYPEP ~S '~S) = ~S~%" P x p1 x TYPE p2) t))))) (declaim (special *catch-error-type*)) (defun catch-continue-debugger-hook (condition dbh) "Function that when used as *debugger-hook*, causes continuable errors to be continued without user intervention." (declare (ignore dbh)) (let ((r (find-restart 'continue condition))) (cond ((and *catch-error-type* (not (typep condition *catch-error-type*))) (format t "Condition ~S is not a ~A~%" condition *catch-error-type*) (cond (r (format t "Its continue restart is ~S~%" r)) (t (format t "It has no continue restart~%"))) (throw 'continue-failed nil)) (r (invoke-restart r)) (t (throw 'continue-failed nil))))) #| (defun safe (fn &rest args) "Apply fn to args, trapping errors. Convert type-errors to the symbol type-error." (declare (optimize (safety 3))) (handler-case (apply fn args) (type-error () 'type-error) (error (c) c))) |# ;;; Use the next macro in place of SAFE (defmacro catch-type-error (form) "Evaluate form in safe mode, returning its value if there is no error. If an error does occur, return type-error on TYPE-ERRORs, or the error condition itself on other errors." `(locally (declare (optimize (safety 3))) (handler-case ,form (type-error () 'type-error) (error (c) c)))) (defmacro classify-error* (form) "Evaluate form in safe mode, returning its value if there is no error. If an error does occur, return a symbol classify the error, or allow the condition to go uncaught if it cannot be classified." `(locally (declare (optimize (safety 3))) (handler-case ,form (undefined-function () 'undefined-function) (program-error () 'program-error) (package-error () 'package-error) (type-error () 'type-error) (control-error () 'control-error) (stream-error () 'stream-error) (reader-error () 'reader-error) (file-error () 'file-error) (control-error () 'control-error) (cell-error () 'cell-error) (error () 'error) ))) (defun classify-error** (form) (handler-bind ((warning #'(lambda (c) (declare (ignore c)) (muffle-warning)))) (proclaim '(optimize (safety 3))) (classify-error* (if regression-test::*compile-tests* (funcall (compile nil `(lambda () (declare (optimize (safety 3))) ,form))) (eval form)) ))) (defmacro classify-error (form) `(classify-error** ',form)) ;;; ;;; A scaffold is a structure that is used to remember the object ;;; identities of the cons cells in a (noncircular) data structure. ;;; This lets us check if the data structure has been changed by ;;; an operation. ;;; (defstruct scaffold node car cdr) (defun make-scaffold-copy (x) "Make a tree that will be used to check if a tree has been changed." (if (consp x) (make-scaffold :node x :car (make-scaffold-copy (car x)) :cdr (make-scaffold-copy (cdr x))) (make-scaffold :node x :car nil :cdr nil))) (defun check-scaffold-copy (x xcopy) "Return t if xcopy were produced from x by make-scaffold-copy, and none of the cons cells in the tree rooted at x have been changed." (and (eq x (scaffold-node xcopy)) (or (not (consp x)) (and (check-scaffold-copy (car x) (scaffold-car xcopy)) (check-scaffold-copy (cdr x) (scaffold-cdr xcopy)))))) (defun create-c*r-test (n) (cond ((<= n 0) 'none) (t (cons (create-c*r-test (1- n)) (create-c*r-test (1- n)))))) (defun nth-1-body (x) (loop for e in x and i from 0 count (not (eqt e (nth i x))))) ;;; ;;; The function SUBTYPEP should return two generalized booleans. ;;; This auxiliary function returns booleans instead ;;; (which makes it easier to write tests). ;;; (defun subtypep* (type1 type2) (apply #'values (mapcar #'notnot (multiple-value-list (subtypep type1 type2))))) (defun subtypep*-or-fail (type1 type2) (let ((results (multiple-value-list (subtypep type1 type2)))) (and (= (length results) 2) (or (not (second results)) (notnot (first results)))))) (defun subtypep*-not-or-fail (type1 type2) (let ((results (multiple-value-list (subtypep type1 type2)))) (and (= (length results) 2) (or (not (second results)) (not (first results)))))) ;;; (eval-when (load eval compile) ;;; (unless (fboundp 'complement) ;;; (defun complement (fn) ;;; #'(lambda (&rest args) (not (apply fn args)))))) (defun compose (&rest fns) (let ((rfns (reverse fns))) #'(lambda (x) (loop for f in rfns do (setf x (funcall f x))) x))) (defun evendigitp (c) (notnot (find c "02468"))) (defun odddigitp (c) (notnot (find c "13579"))) (defun nextdigit (c) (cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))) (defun is-eq-p (x) #'(lambda (y) (eqt x y))) (defun is-not-eq-p (x) #'(lambda (y) (not (eqt x y)))) (defun is-eql-p (x) #'(lambda (y) (eqlt x y))) (defun is-not-eql-p (x) #'(lambda (y) (not (eqlt x y)))) (defun onep (x) (eql x 1)) (defun char-invertcase (c) (if (upper-case-p c) (char-downcase c) (char-upcase c))) (defun string-invertcase (s) (map 'string #'char-invertcase s)) (defun symbol< (x &rest args) (apply #'string< (symbol-name x) (mapcar #'symbol-name args))) (defun random-from-seq (seq) "Generate a random member of a sequence." (let ((len (length seq))) (assert (> len 0)) (elt seq (random len)))) (defmacro random-case (&body cases) (let ((len (length cases))) (assert (> len 0)) `(case (random ,len) ,@(loop for i from 0 for e in cases collect `(,i ,e)) (t (error "Can't happen?! (in random-case~%"))))) (defun coin (&optional (n 2)) "Flip an n-sided coin." (eql (random n) 0)) ;;; Randomly permute a sequence (defun random-permute (seq) (setq seq (copy-seq seq)) (let ((len (length seq))) (loop for i from len downto 2 do (let ((r (random i))) (rotatef (elt seq r) (elt seq (1- i)))))) seq) (defun make-list-expr (args) "Build an expression for computing (LIST . args), but that evades CALL-ARGUMENTS-LIMIT." (if (cddddr args) (list 'list* (first args) (second args) (third args) (fourth args) (make-list-expr (cddddr args))) (cons 'list args))) (defparameter +standard-chars+ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./ ") (defparameter +base-chars+ #.(concatenate 'string "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "0123456789" "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|")) (defparameter +num-base-chars+ (length +base-chars+)) (defparameter +alpha-chars+ (subseq +standard-chars+ 0 52)) (defparameter +lower-case-chars+ (subseq +alpha-chars+ 0 26)) (defparameter +upper-case-chars+ (subseq +alpha-chars+ 26 52)) (defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62)) (defparameter +digit-chars+ "0123456789") (defparameter +extended-digit-chars+ "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ") (defparameter +code-chars+ (coerce (loop for i from 0 below 256 for c = (code-char i) when c collect c) 'string)) (defparameter +rev-code-chars+ (reverse +code-chars+)) ;;; Used in checking for continuable errors (defun has-non-abort-restart (c) (throw 'handled (if (position 'abort (compute-restarts c) :key #'restart-name :test-not #'eq) 'success 'fail))) (defmacro handle-non-abort-restart (&body body) `(catch 'handled (handler-bind ((error #'has-non-abort-restart)) ,@body))) ;;; used in elt.lsp (defun elt-v-6-body () (let ((x (make-int-list 1000))) (let ((a (make-array '(1000) :initial-contents x))) (loop for i from 0 to 999 do (unless (eql i (elt a i)) (return nil)) finally (return t))))) (defun make-adj-array (n &key initial-contents) (if initial-contents (make-array n :adjustable t :initial-contents initial-contents) (make-array n :adjustable t))) ;;; used in elt.lsp (defun elt-adj-array-6-body () (let ((x (make-int-list 1000))) (let ((a (make-adj-array '(1000) :initial-contents x))) (loop for i from 0 to 999 do (unless (eql i (elt a i)) (return nil)) finally (return t))))) (defparameter *displaced* (make-int-array 100000)) (defun make-displaced-array (n displacement) (make-array n :displaced-to *displaced* :displaced-index-offset displacement)) ;;; used in fill.lsp (defun array-unsigned-byte-fill-test-fn (byte-size &rest fill-args) (let* ((a (make-array '(5) :element-type (list 'unsigned-byte byte-size) :initial-contents '(1 2 3 4 5))) (b (apply #'fill a fill-args))) (values (eqt a b) (map 'list #'identity a)))) ;;; used in fill-strings.lsp (defun array-string-fill-test-fn (a &rest fill-args) (setq a (copy-seq a)) (let ((b (apply #'fill a fill-args))) (values (eqt a b) b))) ;;; From types-and-class.lsp (defparameter +float-types+ '(long-float double-float short-float single-float)) (defparameter *subtype-table* (let ((table '( (null symbol) (symbol t) (boolean symbol) (standard-object t) (function t) (compiled-function function) (generic-function function) (standard-generic-function generic-function) (class standard-object) (built-in-class class) (structure-class class) (standard-class class) (method standard-object) (standard-method method) (structure-object t) (method-combination t) (condition t) (serious-condition condition) (error serious-condition) (type-error error) (simple-type-error type-error) (simple-condition condition) (simple-type-error simple-condition) (parse-error error) (hash-table t) (cell-error error) (unbound-slot cell-error) (warning condition) (style-warning warning) (storage-condition serious-condition) (simple-warning warning) (simple-warning simple-condition) (keyword symbol) (unbound-variable cell-error) (control-error error) (program-error error) (undefined-function cell-error) (package t) (package-error error) (random-state t) (number t) (real number) (complex number) (float real) (short-float float) (single-float float) (double-float float) (long-float float) (rational real) (integer rational) (ratio rational) (signed-byte integer) (integer signed-byte) (unsigned-byte signed-byte) (bit unsigned-byte) (fixnum integer) (bignum integer) (bit fixnum) (arithmetic-error error) (division-by-zero arithmetic-error) (floating-point-invalid-operation arithmetic-error) (floating-point-inexact arithmetic-error) (floating-point-overflow arithmetic-error) (floating-point-underflow arithmetic-error) (character t) (base-char character) (standard-char base-char) (extended-char character) (sequence t) (list sequence) (null list) (null boolean) (cons list) (array t) (simple-array array) (vector sequence) (vector array) (string vector) (bit-vector vector) (simple-vector vector) (simple-vector simple-array) (simple-bit-vector bit-vector) (simple-bit-vector simple-array) (base-string string) (simple-string string) (simple-string simple-array) (simple-base-string base-string) (simple-base-string simple-string) (pathname t) (logical-pathname pathname) (file-error error) (stream t) (broadcast-stream stream) (concatenated-stream stream) (echo-stream stream) (file-stream stream) (string-stream stream) (synonym-stream stream) (two-way-stream stream) (stream-error error) (end-of-file stream-error) (print-not-readable error) (readtable t) (reader-error parse-error) (reader-error stream-error) ))) (when (subtypep* 'character 'base-char) (setq table (append '((character base-char) (string base-string) (simple-string simple-base-string)) table))) table)) (defparameter *disjoint-types-list* '(cons symbol array number character hash-table function readtable package pathname stream random-state condition restart)) (defparameter *disjoint-types-list2* `((cons (cons t t) (cons t (cons t t)) (eql (nil))) (symbol keyword boolean null (eql a) (eql nil) (eql t) (eql *)) (array vector simple-array simple-vector string simple-string base-string simple-base-string (eql #())) (character base-char standard-char (eql #\a) ,@(if (subtypep 'character 'base-char) nil (list 'extended-char))) (function compiled-function generic-function standard-generic-function (eql ,#'car)) (package (eql ,(find-package "COMMON-LISP"))) (pathname logical-pathname (eql #p"")) (stream broadcast-stream concatenated-stream echo-stream file-stream string-stream synonym-stream two-way-stream) (number real complex float integer rational ratio fixnum bit (integer 0 100) (float 0.0 100.0) (integer 0 *) (rational 0 *) (mod 10) (eql 0) ,@(and (not (subtypep 'bignum nil)) (list 'bignum))) (random-state) ,*condition-types* (restart) (readtable))) (defparameter *types-list3* (reduce #'append *disjoint-types-list2* :from-end t)) (defun trim-list (list n) (let ((len (length list))) (if (<= len n) list (append (subseq list 0 n) (format nil "And ~A more omitted." (- len n)))))) (defun is-t-or-nil (e) (or (eqt e t) (eqt e nil))) (defun is-builtin-class (type) (when (symbolp type) (setq type (find-class type nil))) (typep type 'built-in-class)) (defun classes-are-disjoint (c1 c2) "If either c1 or c2 is a builtin class or the name of a builtin class, then check for disjointness. Return a non-NIL list of failed subtypep relationships, if any." (and (or (is-builtin-class c1) (is-builtin-class c2)) (check-disjointness c1 c2))) (declaim (special *subtype-table*)) (defun types.6-body () (loop for p in *subtype-table* for tp = (car p) append (and (not (member tp '(sequence cons list t))) (let ((message (check-subtypep tp 'atom t t))) (if message (list message)))))) (defparameter *type-list* nil) (defparameter *supertype-table* nil) (declaim (special *subtype-table*)) (defun types.9-body () (let ((tp-list (append '(keyword atom list) (loop for p in *subtype-table* collect (car p)))) (result-list)) (setf tp-list (remove-duplicates tp-list)) ;; TP-LIST is now a list of unique CL type names ;; Store it in *TYPE-LIST* so we can inspect it later if this test ;; fails. The variable is also used in test TYPES.9A (setf *type-list* tp-list) ;; Compute all pairwise SUBTYPEP relationships among ;; the elements of *TYPE-LIST*. (let ((subs (make-hash-table :test #'eq)) (sups (make-hash-table :test #'eq))) (loop for x in tp-list do (loop for y in tp-list do (multiple-value-bind (result good) (subtypep* x y) (declare (ignore good)) (when result (pushnew x (gethash y subs)) (pushnew y (gethash x sups)))))) ;; Store the supertype relations for later inspection ;; and use in test TYPES.9A (setf *supertype-table* sups) ;; Check that the relation we just computed is transitive. ;; Return a list of triples on which transitivity fails. (loop for x in tp-list do (let ((sub-list (gethash x subs)) (sup-list (gethash x sups))) (loop for t1 in sub-list do (loop for t2 in sup-list do (multiple-value-bind (result good) (subtypep* t1 t2) (when (and good (not result)) (pushnew (list t1 x t2) result-list :test #'equal))))))) result-list))) ;;; TYPES.9-BODY returns a list of triples (T1 T2 T3) ;;; where (AND (SUBTYPEP T1 T2) (SUBTYPEP T2 T3) (NOT (SUBTYPEP T1 T3))) ;;; (and where SUBTYPEP succeeds in each case, returning true as its ;;; second return value.) (defun types.9a-body () (cond ((not (and *type-list* *supertype-table*)) (format nil "Run test type.9 first~%") nil) (t (loop for tp in *type-list* sum (let ((sups (gethash tp *supertype-table*))) (loop for x in *universe* sum (handler-case (cond ((not (typep x tp)) 0) (t (loop for tp2 in sups count (handler-case (and (not (typep x tp2)) (progn (format t "Found element of ~S not in ~S: ~S~%" tp tp2 x) t)) (condition (c) (format t "Error ~S occured: ~S~%" c tp2) t))))) (condition (c) (format t "Error ~S occured: ~S~%" c tp) 1)))))))) (defun even-size-p (a) (some #'evenp (array-dimensions a))) (defun check-cons-copy (x y) "Check that the tree x is a copy of the tree y, returning t if it is, nil if not." (cond ((consp x) (and (consp y) (not (eqt x y)) (check-cons-copy (car x) (car y)) (check-cons-copy (cdr x) (cdr y)))) ((eqt x y) t) (t nil))) (defun check-sublis (a al &key (key 'no-key) test test-not) "Apply sublis al a with various keys. Check that the arguments are not themselves changed. Return nil if the arguments do get changed." (setf a (copy-tree a)) (setf al (copy-tree al)) (let ((acopy (make-scaffold-copy a)) (alcopy (make-scaffold-copy al))) (let ((as (apply #'sublis al a `(,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not)) ,@(unless (eqt key 'no-key) `(:key ,key)))))) (and (check-scaffold-copy a acopy) (check-scaffold-copy al alcopy) as)))) (defun check-nsublis (a al &key (key 'no-key) test test-not) "Apply nsublis al a, copying these arguments first." (setf a (copy-tree a)) (setf al (copy-tree al)) (let ((as (apply #'sublis (copy-tree al) (copy-tree a) `(,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not)) ,@(unless (eqt key 'no-key) `(:key ,key)))))) as)) (defun check-subst (new old tree &key (key 'no-key) test test-not) "Call subst new old tree, with keyword arguments if present. Check that the arguments are not changed." (setf new (copy-tree new)) (setf old (copy-tree old)) (setf tree (copy-tree tree)) (let ((newcopy (make-scaffold-copy new)) (oldcopy (make-scaffold-copy old)) (treecopy (make-scaffold-copy tree))) (let ((result (apply #'subst new old tree `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not)))))) (and (check-scaffold-copy new newcopy) (check-scaffold-copy old oldcopy) (check-scaffold-copy tree treecopy) result)))) (defun check-subst-if (new pred tree &key (key 'no-key)) "Call subst-if new pred tree, with various keyword arguments if present. Check that the arguments are not changed." (setf new (copy-tree new)) (setf tree (copy-tree tree)) (let ((newcopy (make-scaffold-copy new)) (predcopy (make-scaffold-copy pred)) (treecopy (make-scaffold-copy tree))) (let ((result (apply #'subst-if new pred tree (unless (eqt key 'no-key) `(:key ,key))))) (and (check-scaffold-copy new newcopy) (check-scaffold-copy pred predcopy) (check-scaffold-copy tree treecopy) result)))) (defun check-subst-if-not (new pred tree &key (key 'no-key)) "Call subst-if-not new pred tree, with various keyword arguments if present. Check that the arguments are not changed." (setf new (copy-tree new)) (setf tree (copy-tree tree)) (let ((newcopy (make-scaffold-copy new)) (predcopy (make-scaffold-copy pred)) (treecopy (make-scaffold-copy tree))) (let ((result (apply #'subst-if-not new pred tree (unless (eqt key 'no-key) `(:key ,key))))) (and (check-scaffold-copy new newcopy) (check-scaffold-copy pred predcopy) (check-scaffold-copy tree treecopy) result)))) (defun check-nsubst (new old tree &key (key 'no-key) test test-not) "Call nsubst new old tree, with keyword arguments if present." (setf new (copy-tree new)) (setf old (copy-tree old)) (setf tree (copy-tree tree)) (apply #'nsubst new old tree `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not))))) (defun check-nsubst-if (new pred tree &key (key 'no-key)) "Call nsubst-if new pred tree, with keyword arguments if present." (setf new (copy-tree new)) (setf tree (copy-tree tree)) (apply #'nsubst-if new pred tree (unless (eqt key 'no-key) `(:key ,key)))) (defun check-nsubst-if-not (new pred tree &key (key 'no-key)) "Call nsubst-if-not new pred tree, with keyword arguments if present." (setf new (copy-tree new)) (setf tree (copy-tree tree)) (apply #'nsubst-if-not new pred tree (unless (eqt key 'no-key) `(:key ,key)))) (defun check-copy-list-copy (x y) "Check that y is a copy of the list x." (if (consp x) (and (consp y) (not (eqt x y)) (eqt (car x) (car y)) (check-copy-list-copy (cdr x) (cdr y))) (and (eqt x y) t))) (defun check-copy-list (x) "Apply copy-list, checking that it properly copies, and checking that it does not change its argument." (let ((xcopy (make-scaffold-copy x))) (let ((y (copy-list x))) (and (check-scaffold-copy x xcopy) (check-copy-list-copy x y) y)))) (defun append-6-body () (let* ((cal (min 2048 call-arguments-limit)) (step (max 1 (floor (/ cal) 64)))) (loop for n from 0 below cal by step count (not (equal (apply #'append (loop for i from 1 to n collect '(a))) (make-list n :initial-element 'a)))))) (defun is-intersection (x y z) "Check that z is the intersection of x and y." (and (listp x) (listp y) (listp z) (loop for e in x always (or (not (member e y)) (member e z))) (loop for e in y always (or (not (member e x)) (member e z))) (loop for e in z always (and (member e x) (member e y))) t)) (defun shuffle (x) (cond ((null x) nil) ((null (cdr x)) x) (t (multiple-value-bind (y z) (split-list x) (append (shuffle y) (shuffle z)))))) (defun split-list (x) (cond ((null x) (values nil nil)) ((null (cdr x)) (values x nil)) (t (multiple-value-bind (y z) (split-list (cddr x)) (values (cons (car x) y) (cons (cadr x) z)))))) (defun intersection-12-body (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (intersection x y))) (let ((is-good (is-intersection x y z))) (unless is-good (return (values x y z))))))) nil)) (defun nintersection-with-check (x y &key test) (let ((ycopy (make-scaffold-copy y))) (let ((result (if test (nintersection x y :test test) (nintersection x y)))) (if (check-scaffold-copy y ycopy) result 'failed)))) (defun nintersection-12-body (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state t))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (nintersection-with-check (copy-list x) y))) (when (eqt z 'failed) (return (values x y z))) (let ((is-good (is-intersection x y z))) (unless is-good (return (values x y z))))))) nil)) (defun union-with-check (x y &key test test-not) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (let ((result (cond (test (union x y :test test)) (test-not (union x y :test-not test-not)) (t (union x y))))) (if (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy)) result 'failed)))) (defun union-with-check-and-key (x y key &key test test-not) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (let ((result (cond (test (union x y :key key :test test)) (test-not (union x y :key key :test-not test-not)) (t (union x y :key key))))) (if (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy)) result 'failed)))) (defun check-union (x y z) (and (listp x) (listp y) (listp z) (loop for e in z always (or (member e x) (member e y))) (loop for e in x always (member e z)) (loop for e in y always (member e z)) t)) (defun do-random-unions (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (union x y))) (let ((is-good (check-union x y z))) (unless is-good (return (values x y z))))))) nil)) (defun nunion-with-copy (x y &key test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (cond (test (nunion x y :test test)) (test-not (nunion x y :test-not test-not)) (t (nunion x y)))) (defun nunion-with-copy-and-key (x y key &key test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (cond (test (nunion x y :key key :test test)) (test-not (nunion x y :key key :test-not test-not)) (t (nunion x y :key key)))) (defun do-random-nunions (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (nunion-with-copy x y))) (let ((is-good (check-union x y z))) (unless is-good (return (values x y z))))))) nil)) (defun set-difference-with-check (x y &key (key 'no-key) test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (let ((result (apply #'set-difference x y `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not)))))) (cond ((and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy)) result) (t 'failed))))) (defun check-set-difference (x y z &key (key #'identity) (test #'eql)) (and ;; (not (eqt 'failed z)) (listp x) (listp y) (listp z) (loop for e in z always (member e x :key key :test test)) (loop for e in x always (or (member e y :key key :test test) (member e z :key key :test test))) (loop for e in y never (member e z :key key :test test)) t)) (defun do-random-set-differences (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (set-difference-with-check x y))) (let ((is-good (check-set-difference x y z))) (unless is-good (return (values x y z))))))) nil)) (defun nset-difference-with-check (x y &key (key 'no-key) test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (apply #'nset-difference x y `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not))))) (defun check-nset-difference (x y z &key (key #'identity) (test #'eql)) (and (listp x) (listp y) (listp z) (loop for e in z always (member e x :key key :test test)) (loop for e in x always (or (member e y :key key :test test) (member e z :key key :test test))) (loop for e in y never (member e z :key key :test test)) t)) (defun do-random-nset-differences (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (nset-difference-with-check x y))) (let ((is-good (check-nset-difference x y z))) (unless is-good (return (values x y z))))))) nil)) (defun set-exclusive-or-with-check (x y &key (key 'no-key) test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (let ((result (apply #'set-exclusive-or x y `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not)))))) (cond ((and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy)) result) (t 'failed))))) (defun check-set-exclusive-or (x y z &key (key #'identity) (test #'eql)) (and ;; (not (eqt 'failed z)) (listp x) (listp y) (listp z) (loop for e in z always (or (member e x :key key :test test) (member e y :key key :test test))) (loop for e in x always (if (member e y :key key :test test) (not (member e z :key key :test test)) (member e z :key key :test test))) (loop for e in y always (if (member e x :key key :test test) (not (member e z :key key :test test)) (member e z :key key :test test))) t)) (defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (set-exclusive-or-with-check x y))) (let ((is-good (check-set-exclusive-or x y z))) (unless is-good (return (values x y z))))))) nil)) (defun nset-exclusive-or-with-check (x y &key (key 'no-key) test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (apply #'nset-exclusive-or x y `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not))))) (defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (nset-exclusive-or-with-check x y))) (let ((is-good (check-set-exclusive-or x y z))) (unless is-good (return (values x y z))))))) nil)) (defun subsetp-with-check (x y &key (key 'no-key) test test-not) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (let ((result (apply #'subsetp x y `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not)))))) (cond ((and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy)) (not (not result))) (t 'failed))))) (defun safe-elt (x n) (classify-error* (elt x n))) (defmacro defstruct* (&body args) `(eval-when (load eval compile) (ignore-errors (defstruct ,@args)))) (defun sort-package-list (x) (sort (copy-list x) #'string< :key #'package-name)) (defun sort-symbols (sl) (sort (copy-list sl) #'(lambda (x y) (or (string< (symbol-name x) (symbol-name y)) (and (string= (symbol-name x) (symbol-name y)) (string< (package-name (symbol-package x)) (package-name (symbol-package y)))))))) (defun num-symbols-in-package (p) (let ((num 0)) (declare (fixnum num)) (do-symbols (s p num) (incf num)))) (defun num-external-symbols-in-package (p) (let ((num 0)) (declare (fixnum num)) (do-external-symbols (s p num) (incf num)))) (defun safely-delete-package (package-designator) (let ((package (find-package package-designator))) (when package (let ((used-by (package-used-by-list package))) (dolist (using-package used-by) (unuse-package package using-package))) (delete-package package)))) (defconstant +fail-count-limit+ 20) (defmacro test-with-package-iterator (package-list-expr &rest symbol-types) "Build an expression that tests the with-package-iterator form." (let ((name (gensym)) (cht-var (gensym)) (pkg-list-var (gensym))) `(let ((,cht-var (make-hash-table)) (,pkg-list-var ,package-list-expr) (fail-count 0)) (with-package-iterator (,name ,pkg-list-var ,@(copy-list symbol-types)) ;; For each symbol, check that name is returning appropriate ;; things (loop (block fail (multiple-value-bind (more sym access pkg) (,name) (unless more (return nil)) (setf (gethash sym ,cht-var) t) ;; note presence of symbol ;; Check that its access status is in the list, ;; that pkg is a package, ;; that the symbol is in the package, ;; and that (in the package) it has the correct access type (unless (member access (quote ,(copy-list symbol-types))) (unless (> fail-count +fail-count-limit+) (format t "Bad access type: ~S ==> ~A~%" sym access)) (when (= fail-count +fail-count-limit+) (format t "Further messages suppressed~%")) (incf fail-count) (return-from fail nil)) (unless (packagep pkg) (unless (> fail-count +fail-count-limit+) (format t "Not a package: ~S ==> ~S~%" sym pkg)) (when (= fail-count +fail-count-limit+) (format t "Further messages suppressed~%")) (incf fail-count) (return-from fail nil)) (multiple-value-bind (sym2 access2) (find-symbol (symbol-name sym) pkg) (unless (or (eqt sym sym2) (member sym2 (package-shadowing-symbols pkg))) (unless (> fail-count +fail-count-limit+) (format t "Not same symbol: ~S ~S~%" sym sym2)) (when (= fail-count +fail-count-limit+) (format t "Further messages suppressed~%")) (incf fail-count) (return-from fail nil)) (unless (eqt access access2) (unless (> fail-count +fail-count-limit+) (format t "Not same access type: ~S ~S ~S~%" sym access access2)) (when (= fail-count +fail-count-limit+) (format t "Further messages suppressed~%")) (incf fail-count) (return-from fail nil))))))) ;; now, check that each symbol in each package has ;; been properly found (loop for p in ,pkg-list-var do (block fail (do-symbols (sym p) (multiple-value-bind (sym2 access) (find-symbol (symbol-name sym) p) (unless (eqt sym sym2) (unless (> fail-count +fail-count-limit+) (format t "Not same symbol (2): ~S ~S~%" sym sym2)) (when (= fail-count +fail-count-limit+) (format t "Further messages suppressed~%")) (incf fail-count) (return-from fail nil)) (unless (or (not (member access (quote ,(copy-list symbol-types)))) (gethash sym ,cht-var)) (format t "Symbol not found: ~S~%" sym) (incf fail-count) (return-from fail nil)))))) (or (zerop fail-count) fail-count)))) (defun with-package-iterator-internal (packages) (test-with-package-iterator packages :internal)) (defun with-package-iterator-external (packages) (test-with-package-iterator packages :external)) (defun with-package-iterator-inherited (packages) (test-with-package-iterator packages :inherited)) (defun with-package-iterator-all (packages) (test-with-package-iterator packages :internal :external :inherited)) (defun frob-simple-condition (c expected-fmt &rest expected-args) "Try out the format control and format arguments of a simple-condition C, but make no assumptions about what they print as, only that they do print." (declare (ignore expected-fmt expected-args)) (and (typep c 'simple-condition) (let ((fc (simple-condition-format-control c)) (args (simple-condition-format-arguments c))) (and (stringp (apply #'format nil fc args)) t)))) (defun frob-simple-error (c expected-fmt &rest expected-args) (and (typep c 'simple-error) (apply #'frob-simple-condition c expected-fmt expected-args))) (defun frob-simple-warning (c expected-fmt &rest expected-args) (and (typep c 'simple-warning) (apply #'frob-simple-condition c expected-fmt expected-args))) (defparameter *array-element-types* '(t (integer 0 0) bit (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) float short-float single-float double-float long-float nil character base-char symbol boolean null)) (defun random-partition (n p) "Partition n into p numbers, each >= 1. Return list of numbers." (assert (<= 1 p)) #| (cond ((= p 1) (list n)) ((< n p) (make-list p :initial-element 1)) (t (let ((n1 (1+ (random (floor n p))))) (cons n1 (random-partition (- n n1) (1- p))))))) |# (cond ((= p 1) (list n)) ((= n 0) (make-list p :initial-element 0)) (t (let* ((r (random p)) (n1 (random (1+ n)))) (cond ((= r 0) (cons n1 (random-partition (- n n1) (1- p)))) ((= r (1- p)) (append (random-partition (- n n1) (1- p)) (list n1))) (t (let* ((n2 (random (1+ (- n n1)))) (n3 (- n n1 n2))) (append (random-partition n2 r) (list n1) (random-partition n3 (- p 1 r)))))))))) gcl/ansi-tests/apply.lsp000066400000000000000000000021231242227143400155610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 15:13:07 2003 ;;;; Contains: Tests of APPLY (in-package :cl-test) ;;; Error cases (deftest apply.error.1 (classify-error (apply)) program-error) (deftest apply.error.2 (classify-error (apply #'cons)) program-error) (deftest apply.error.3 (classify-error (apply #'cons nil)) program-error) (deftest apply.error.4 (classify-error (apply #'cons (list 1 2 3))) program-error) ;;; Non-error cases (deftest apply.1 (apply #'cons 'a 'b nil) (a . b)) (deftest apply.2 (apply #'cons 'a '(b)) (a . b)) (deftest apply.3 (apply #'cons '(a b)) (a . b)) (deftest apply.4 (let ((zeros (make-list (min 10000 (1- call-arguments-limit)) :initial-element 1))) (apply #'+ zeros)) #.(min 10000 (1- call-arguments-limit))) (deftest apply.5 (apply 'cons '(a b)) (a . b)) (deftest apply.order.1 (let ((i 0) x y z) (values (apply (progn (setf x (incf i)) #'list) (progn (setf y (incf i)) 'b) (progn (setf z (incf i)) (list 'a))) i x y z)) (b a) 3 1 2 3) gcl/ansi-tests/aref.lsp000066400000000000000000000055031242227143400153560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Feb 11 17:33:24 2003 ;;;; Contains: Tests for AREF (in-package :cl-test) ;;; AREF is also tested in many other places (deftest aref.1 (aref #0aT) T) (deftest aref.2 (aref #(1 2 3 4) 2) 3) (deftest aref.3 (aref #2a((a b c d)(e f g h)) 1 2) g) (deftest aref.4 (loop for i from 0 below 6 collect (aref "abcdef" i)) (#\a #\b #\c #\d #\e #\f)) (deftest aref.5 (let ((a (make-array '(2 3) :element-type 'base-char :initial-contents '("abc" "def")))) (loop for i below 2 collect (loop for j below 3 collect (aref a i j)))) ((#\a #\b #\c) (#\d #\e #\f))) (deftest aref.6 (loop for i below 10 collect (aref #*1101100010 i)) (1 1 0 1 1 0 0 0 1 0)) (deftest aref.7 (let ((a (make-array '(2 5) :element-type 'bit :initial-contents '((1 1 0 0 1) (0 1 0 1 0))))) (loop for i below 2 collect (loop for j below 5 collect (aref a i j)))) ((1 1 0 0 1) (0 1 0 1 0))) ;;; Order of argument evaluation (deftest aref.order.1 (let ((i 0) x y (a #(a b c d))) (values (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 2)) i x y)) c 2 1 2) (deftest aref.order.2 (let ((i 0) x y z (a #2a((a b c)(d e f)))) (values (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 1) (progn (setf z (incf i)) 2)) i x y z)) f 3 1 2 3) ;;; Setf of aref (deftest setf-aref.1 (let ((a (copy-seq #(1 2 3 4)))) (values (setf (aref a 2) 'z) a)) z #(1 2 z 4)) (deftest setf-aref.2 (let ((a (make-array nil :initial-element 1))) (values (setf (aref a) 'z) a)) z #0az) (deftest setf-aref.3 (let ((a (make-array '(2 3) :initial-element 'a))) (values (setf (aref a 0 1) 'z) a)) z #2a((a z a)(a a a))) (deftest setf-aref.4 (let ((a (copy-seq "abcd"))) (values (setf (aref a 0) #\z) a)) #\z "zbcd") (deftest setf-aref.5 (let ((a (copy-seq #*0011))) (values (setf (aref a 0) 1) a)) 1 #*1011) (deftest setf-aref.6 (let ((a (make-array '(2 3) :initial-element #\a :element-type 'base-char))) (values (setf (aref a 0 1) #\z) a)) #\z #2a((#\a #\z #\a)(#\a #\a #\a))) (deftest setf-aref.7 (let ((a (make-array '(2 3) :initial-element 1 :element-type 'bit))) (values (setf (aref a 0 1) 0) a)) 0 #2a((1 0 1)(1 1 1))) (deftest setf-aref.order.1 (let ((i 0) x y z (a (copy-seq #(a b c d)))) (values (setf (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 2)) (progn (setf z (incf i)) 'z)) a i x y z)) z #(a b z d) 3 1 2 3) ;;; To add: aref on displaced arrays, arrays with fill pointers, etc. (deftest aref.error.1 (classify-error (aref)) program-error) (deftest aref.error.2 (classify-error (funcall #'aref)) program-error) gcl/ansi-tests/array-as-class.lsp000066400000000000000000000025001242227143400172550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 07:45:25 2003 ;;;; Contains: Tests for ARRAY as a class (in-package :cl-test) (deftest array-as-class.1 (notnot-mv (typep #() (find-class 'array))) t) (deftest array-as-class.2 (notnot-mv (typep #(a b c) (find-class 'array))) t) (deftest array-as-class.3 (notnot-mv (typep #0aNIL (find-class 'array))) t) (deftest array-as-class.4 (notnot-mv (typep #2a((a b)(c d)) (find-class 'array))) t) (deftest array-as-class.5 (notnot-mv (typep "abcde" (find-class 'array))) t) (deftest array-as-class.6 (notnot-mv (typep #*0011101 (find-class 'array))) t) (deftest array-as-class.7 (subtypep* 'array (find-class 'array)) t t) (deftest array-as-class.8 (subtypep* (find-class 'array) 'array) t t) (deftest array-as-class.9 (typep nil (find-class 'array)) nil) (deftest array-as-class.10 (typep 'x (find-class 'array)) nil) (deftest array-as-class.11 (typep '(a b c) (find-class 'array)) nil) (deftest array-as-class.12 (typep 10.0 (find-class 'array)) nil) (deftest array-as-class.13 (typep #'(lambda (x) (cons x nil)) (find-class 'array)) nil) (deftest array-as-class.14 (typep 1 (find-class 'array)) nil) (deftest array-as-class.15 (typep (1+ most-positive-fixnum) (find-class 'array)) nil) gcl/ansi-tests/array-aux.lsp000066400000000000000000000151601242227143400163520ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 05:11:31 2003 ;;;; Contains: Auxiliary functions for array tests (in-package :cl-test) (defun make-array-check-upgrading (type) (subtypep* type (array-element-type (make-array 0 :element-type type)))) (defun subtypep-or-unknown (subtype supertype) (multiple-value-bind* (is-subtype is-known) (subtypep subtype supertype) (or (not is-known) (notnot is-subtype)))) (defun make-array-with-checks (dimensions &rest options &key (element-type t element-type-p) (initial-contents nil initial-contents-p) (initial-element nil initial-element-p) (adjustable nil) (fill-pointer nil) (displaced-to nil) (displaced-index-offset 0 dio-p) &aux (dimensions-list (if (listp dimensions) dimensions (list dimensions)))) "Call MAKE-ARRAY and do sanity tests on the output." (declare (ignore element-type-p initial-contents initial-contents-p initial-element initial-element-p dio-p)) (let ((a (check-values (apply #'make-array dimensions options))) (rank (length dimensions-list))) (cond ((not (typep a 'array)) :fail-not-array) ((not (typep a (find-class 'array))) :fail-not-array-class) ((not (typep a '(array *))) :fail-not-array2) ((not (typep a `(array * ,dimensions-list))) :fail-not-array3) ((not (typep a `(array * *))) :fail-not-array4) ((not (typep a `(array ,element-type))) :fail-not-array5) ((not (typep a `(array ,element-type *))) :fail-not-array6) #-gcl ((not (typep a `(array ,element-type ,rank))) :fail-not-array7) ((not (typep a `(array ,element-type ,dimensions-list))) :fail-not-array8) ((not (typep a `(array ,element-type ,(mapcar (constantly '*) dimensions-list)))) :fail-not-array9) ((loop for i from 0 below (min 10 rank) thereis (let ((x (append (subseq dimensions-list 0 i) (list '*) (subseq dimensions-list (1+ i))))) (or (not (typep a `(array * ,x))) (not (typep a `(array ,element-type ,x)))))) :fail-not-array10) ((not (check-values (arrayp a))) :fail-not-arrayp) ((and ;; (eq t element-type) (not adjustable) (not fill-pointer) (not displaced-to) (cond ((not (typep a 'simple-array)) :fail-not-simple-array) ((not (typep a '(simple-array *))) :fail-not-simple-array2) ((not (typep a `(simple-array * ,dimensions-list))) :fail-not-simple-array3) ((not (typep a `(simple-array * *))) :fail-not-simple-array4) ((not (typep a `(simple-array ,element-type))) :fail-not-simple-array5) ((not (typep a `(simple-array ,element-type *))) :fail-not-simple-array6) #-gcl ((not (typep a `(simple-array ,element-type ,rank))) :fail-not-array7) ((not (typep a `(simple-array ,element-type ,dimensions-list))) :fail-not-simple-array8) ((not (typep a `(simple-array ,element-type ,(mapcar (constantly '*) dimensions-list)))) :fail-not-simple-array9) ))) ;; If the array is a vector, check that... ((and (eql rank 1) (cond ;; ...It's in type vector ((not (typep a 'vector)) :fail-not-vector) ;; ...If the element type is a subtype of BIT, then it's a ;; bit vector... ((and (subtypep 'bit element-type) (subtypep element-type 'bit) (or (not (bit-vector-p a)) (not (typep a 'bit-vector)))) :fail-not-bit-vector) ;; ...If not adjustable, fill pointered, or displaced, ;; then it's a simple vector or simple bit vector ;; (if the element-type is appropriate) ((and (not adjustable) (not fill-pointer) (not displaced-to) (cond ((and (eq t element-type) (or (not (simple-vector-p a)) (not (typep a 'simple-vector)))) :fail-not-simple-vector) ((and (subtypep 'bit element-type) (subtypep element-type 'bit) (or (not (simple-bit-vector-p a)) (not (typep a 'simple-bit-vector)))) :fail-not-simple-bit-vector) ))) ))) ;; The dimensions of the array must be initialized properly ((not (equal (array-dimensions a) dimensions-list)) :fail-array-dimensions) ;; The rank of the array must equal the number of dimensions ((not (equal (array-rank a) rank)) :fail-array-rank) ;; Arrays other than vectors cannot have fill pointers ((and (not (equal (array-rank a) 1)) (array-has-fill-pointer-p a)) :fail-non-vector-fill-pointer) ;; The actual element type must be a supertype of the element-type ;; argument ((not (subtypep-or-unknown element-type (array-element-type a))) :failed-array-element-type) ;; If :adjustable is given, the array must be adjustable. ((and adjustable (not (check-values (adjustable-array-p a))) :fail-adjustable)) ;; If :fill-pointer is given, the array must have a fill pointer ((and fill-pointer (not (check-values (array-has-fill-pointer-p a))) :fail-has-fill-pointer)) ;; If the fill pointer is given as an integer, it must be the value ;; of the fill pointer of the new array ((and (check-values (integerp fill-pointer)) (not (eql fill-pointer (check-values (fill-pointer a)))) :fail-fill-pointer-1)) ;; If the fill-pointer argument is t, the fill pointer must be ;; set to the vector size. ((and (eq fill-pointer t) (not (eql (first dimensions-list) (fill-pointer a))) :fail-fill-pointer-2)) ;; If displaced-to another array, check that this is proper ((and displaced-to (multiple-value-bind* (actual-dt actual-dio) (array-displacement a) (cond ((not (eq actual-dt displaced-to)) :fail-displacement-1) ((not (eql actual-dio displaced-index-offset)) :fail-displaced-index-offset))))) ;; Test of array-total-size ((not (eql (check-values (array-total-size a)) (reduce #'* dimensions-list :initial-value 1))) :fail-array-total-size) ;; Test array-row-major-index on all zeros ((and (> (array-total-size a) 0) (not (eql (check-values (apply #'array-row-major-index a (make-list (array-rank a) :initial-element 0))) 0))) :fail-array-row-major-index-0) ;; For the last entry ((and (> (array-total-size a) 0) (not (eql (apply #'array-row-major-index a (mapcar #'1- dimensions-list)) (1- (reduce #'* dimensions-list :initial-value 1))))) :fail-array-row-major-index-last) ;; No problems -- return the array (t a)))) gcl/ansi-tests/array-dimension.lsp000066400000000000000000000024321242227143400175400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 06:55:14 2003 ;;;; Contains: Tests of ARRAY-DIMENSION (in-package :cl-test) ;;; array-dimension is also tested by the tests in make-array.lsp (deftest array-dimension.1 (array-dimension #(0 1 2 3) 0) 4) (deftest array-dimension.2 (array-dimension "abcdef" 0) 6) (deftest array-dimension.3 (array-dimension #2a((1 2 3 4)(5 6 7 8)) 0) 2) (deftest array-dimension.4 (array-dimension #2a((1 2 3 4)(5 6 7 8)) 1) 4) (deftest array-dimension.5 (let ((a (make-array '(10) :fill-pointer 5))) (array-dimension a 0)) 10) (deftest array-dimension.6 (let ((a (make-array '(10) :adjustable t))) (values (array-dimension a 0) (progn (adjust-array a '(20)) (array-dimension a 0)))) 10 20) (deftest array-dimension.order.1 (let ((i 0) a b) (values (array-dimension (progn (setf a (incf i)) #(a b c d)) (progn (setf b (incf i)) 0)) i a b)) 4 2 1 2) ;;; Error tests (deftest array-dimension.error.1 (classify-error (array-dimension)) program-error) (deftest array-dimension.error.2 (classify-error (array-dimension #(a b c))) program-error) (deftest array-dimension.error.3 (classify-error (array-dimension #(a b c) 0 nil)) program-error) gcl/ansi-tests/array-dimensions.lsp000066400000000000000000000027361242227143400177320ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 06:59:37 2003 ;;;; Contains: Tests of ARRAY-DIMENSIONS (in-package :cl-test) ;;; The tests in make-array.lsp also test this function (deftest array-dimensions.1 (array-dimensions #0aX) nil) (deftest array-dimensions.2 (array-dimensions #(a b c d)) (4)) (deftest array-dimensions.3 (array-dimensions #*0011011011) (10)) (deftest array-dimensions.4 (array-dimensions "abcdef") (6)) (deftest array-dimensions.5 (array-dimensions #2a((1 2 3)(4 5 6)(7 8 9)(10 11 12))) (4 3)) (deftest array-dimensions.6 (let ((a (make-array '(2 3 4) :adjustable t))) (values (array-dimension a 0) (array-dimension a 1) (array-dimension a 2))) 2 3 4) (deftest array-dimensions.7 (let ((a (make-array '(10) :fill-pointer 5))) (array-dimension a 0)) 10) ;;; Error tests (deftest array-dimensions.error.1 (classify-error (array-dimensions)) program-error) (deftest array-dimensions.error.2 (classify-error (array-dimensions #(a b c) nil)) program-error) (deftest array-dimensions.error.3 (let (why) (loop for e in *mini-universe* unless (or (typep e 'array) (eq 'type-error (setq why (classify-error** `(array-dimensions ',e))))) collect (list e why))) nil) (deftest array-dimensions.error.4 (classify-error (array-dimensions nil)) type-error) (deftest array-dimensions.error.5 (classify-error (locally (array-dimensions nil))) type-error) gcl/ansi-tests/array-displacement.lsp000066400000000000000000000071401242227143400202240ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 06:20:51 2003 ;;;; Contains: Tests for ARRAY-DISPLACEMENT (in-package :cl-test) ;;; The tests in make-array.lsp also test array-displacement ;;; The standard is contradictory about whether arrays created with ;;; :displaced-to NIL should return NIL as their primary value or ;;; not. I will assume (as per Kent Pitman's comment on comp.lang.lisp) ;;; that an implementation is free to implement all arrays as actually ;;; displaced. Therefore, I've omitted all the tests of not-expressly ;;; displaced arrays. ;;; Behavior on expressly displaced arrays (deftest array-displacement.7 (let* ((a (make-array '(10))) (b (make-array '(10) :displaced-to a))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 0)))) t) (deftest array-displacement.8 (let* ((a (make-array '(10))) (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 2)))) t) (deftest array-displacement.9 (let* ((a (make-array '(10) :element-type 'base-char)) (b (make-array '(5) :displaced-to a :displaced-index-offset 2 :element-type 'base-char))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 2)))) t) (deftest array-displacement.10 (let* ((a (make-array '(10) :element-type 'base-char)) (b (make-array '(5) :displaced-to a :element-type 'base-char))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 0)))) t) (deftest array-displacement.11 (let* ((a (make-array '(10) :element-type 'bit)) (b (make-array '(5) :displaced-to a :displaced-index-offset 2 :element-type 'bit))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 2)))) t) (deftest array-displacement.12 (let* ((a (make-array '(10) :element-type 'bit)) (b (make-array '(5) :displaced-to a :element-type 'bit))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 0)))) t) (deftest array-displacement.13 (let* ((a (make-array '(10) :element-type '(integer 0 255))) (b (make-array '(5) :displaced-to a :displaced-index-offset 2 :element-type '(integer 0 255)))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 2)))) t) (deftest array-displacement.14 (let* ((a (make-array '(10) :element-type '(integer 0 255))) (b (make-array '(5) :displaced-to a :element-type '(integer 0 255)))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 0)))) t) (deftest array-displacement.order.1 (let* ((a (make-array '(10))) (b (make-array '(10) :displaced-to a)) (i 0)) (multiple-value-bind* (dt disp) (array-displacement (progn (incf i) b)) (and (eql i 1) (eqt a dt) (eqlt disp 0)))) t) ;;; Error tests (deftest array-displacement.error.1 (classify-error (array-displacement)) program-error) (deftest array-displacement.error.2 (classify-error (array-displacement #(a b c) nil)) program-error) (deftest array-displacement.error.3 (let (why) (loop for e in *mini-universe* unless (or (typep e 'array) (eq 'type-error (setq why (classify-error** `(array-displacement ',e))))) collect (list e why))) nil) (deftest array-displacement.error.4 (classify-error (array-displacement nil)) type-error) (deftest array-displacement.error.5 (classify-error (let ((x nil)) (array-displacement x))) type-error) gcl/ansi-tests/array-in-bounds-p.lsp000066400000000000000000000100721242227143400177050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 19:57:29 2003 ;;;; Contains: Tests for ARRAY-IN-BOUNDS-P (in-package :cl-test) (deftest array-in-bounds-p.1 (array-in-bounds-p #() 0) nil) (deftest array-in-bounds-p.2 (array-in-bounds-p #() -1) nil) (deftest array-in-bounds-p.3 (let ((a #(a b c d))) (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) (t t t t nil)) (deftest array-in-bounds-p.4 (notnot (array-in-bounds-p #0aNIL)) t) (deftest array-in-bounds-p.5 (array-in-bounds-p "" 0) nil) (deftest array-in-bounds-p.6 (array-in-bounds-p "" -1) nil) (deftest array-in-bounds-p.7 (let ((a "abcd")) (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) (t t t t nil)) (deftest array-in-bounds-p.8 (array-in-bounds-p #* 0) nil) (deftest array-in-bounds-p.9 (array-in-bounds-p #* -1) nil) (deftest array-in-bounds-p.10 (let ((a #*0110)) (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) (t t t t nil)) ;; Fill pointer tests (deftest array-in-bounds-p.11 (let ((a (make-array '(10) :fill-pointer 5))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) (nil t t t t t t t t t t nil)) (deftest array-in-bounds-p.12 (let ((a (make-array '(10) :fill-pointer 5 :element-type 'bit :initial-element 0))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) (nil t t t t t t t t t t nil)) (deftest array-in-bounds-p.13 (let ((a (make-array '(10) :fill-pointer 5 :element-type 'base-char :initial-element #\x))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) (nil t t t t t t t t t t nil)) (deftest array-in-bounds-p.14 (let ((a (make-array '(10) :fill-pointer 5 :element-type 'character :initial-element #\x))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) (nil t t t t t t t t t t nil)) ;;; Displaced arrays (deftest array-in-bounds-p.15 (let* ((a1 (make-array '(20))) (a2 (make-array '(10) :displaced-to a1))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) (nil t t t t t t t t t t nil)) (deftest array-in-bounds-p.16 (let* ((a1 (make-array '(20) :element-type 'bit :initial-element 0)) (a2 (make-array '(10) :displaced-to a1 :element-type 'bit))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) (nil t t t t t t t t t t nil)) (deftest array-in-bounds-p.17 (let* ((a1 (make-array '(20) :element-type 'character :initial-element #\x)) (a2 (make-array '(10) :displaced-to a1 :element-type 'character))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) (nil t t t t t t t t t t nil)) ;;; Multidimensional arrays (deftest array-in-bounds-p.18 (let ((a (make-array '(3 4)))) (loop for i from -1 to 3 collect (loop for j from -1 to 4 collect (notnot (array-in-bounds-p a i j))))) ((nil nil nil nil nil nil) (nil t t t t nil) (nil t t t t nil) (nil t t t t nil) (nil nil nil nil nil nil))) (deftest array-in-bounds-p.19 (let ((a (make-array '(1 3 4) :adjustable t))) (loop for i from -1 to 3 collect (loop for j from -1 to 4 collect (notnot (array-in-bounds-p a 0 i j))))) ((nil nil nil nil nil nil) (nil t t t t nil) (nil t t t t nil) (nil t t t t nil) (nil nil nil nil nil nil))) ;;; Very large indices (deftest array-in-bounds-p.20 (array-in-bounds-p #(a b c) (1+ most-positive-fixnum)) nil) (deftest array-in-bounds-p.21 (array-in-bounds-p #(a b c) (1- most-negative-fixnum)) nil) (deftest array-in-bounds-p.22 (array-in-bounds-p #(a b c) 1000000000000000000) nil) (deftest array-in-bounds-p.23 (array-in-bounds-p #(a b c) -1000000000000000000) nil) ;;; Order of evaluation tests (deftest array-in-bounds-p.order.1 (let ((x 0) y z) (values (array-in-bounds-p (progn (setf y (incf x)) #()) (progn (setf z (incf x)) 10)) x y z)) nil 2 1 2) ;;; Error tests (deftest array-in-bounds-p.error.1 (classify-error (array-in-bounds-p)) program-error) gcl/ansi-tests/array-misc.lsp000066400000000000000000000012031242227143400165010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 22 21:17:25 2003 ;;;; Contains: Misc. tests of array features (in-package :cl-test) (deftest array-dimension-limit.1 (and (<= 1024 array-dimension-limit) t) t) (deftest array-dimension-limit.2 (and (typep array-dimension-limit 'fixnum) t) t) (deftest array-total-size-limit.1 (and (<= 1024 array-total-size-limit) t) t) (deftest array-total-size-limit.2 (and (typep array-total-size-limit 'fixnum) t) t) (deftest array-rank-limit.1 (and (<= 8 array-rank-limit) t) t) (deftest array-rank-limit.2 (and (typep array-rank-limit 'fixnum) t) t) gcl/ansi-tests/array-rank.lsp000066400000000000000000000020401242227143400165010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 20:32:57 2003 ;;;; Contains: Tests for ARRAY-RANK (in-package :cl-test) ;;; Most tests for ARRAY-RANK are in make-array.lsp (deftest array-rank.1 (array-rank #0aNIL) 0) (deftest array-rank.2 (loop for e in *universe* when (and (typep e 'vector) (not (eql (array-rank e) 1))) collect e) nil) (deftest array-rank.order.1 (let ((i 0) a) (values (array-rank (progn (setf a (incf i)) "abcd")) i a)) 1 1 1) ;;; Error tests (deftest array-rank.error.1 (classify-error (array-rank)) program-error) (deftest array-rank.error.2 (classify-error (array-rank #(a b c) nil)) program-error) (deftest array-rank.error.3 (loop for e in *mini-universe* when (and (not (typep e 'array)) (not (eq (classify-error** `(array-rank ',e)) 'type-error))) collect e) nil) (deftest array-rank.error.4 (classify-error (array-rank nil)) type-error) (deftest array-rank.error.5 (classify-error (locally (array-rank nil) t)) type-error) gcl/ansi-tests/array-row-major-index.lsp000066400000000000000000000016151242227143400205770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 21:37:03 2003 ;;;; Contains: Tests of ARRAY-ROW-MAJOR-INDEX (in-package :cl-test) ;;; More array-row-major-index tests are in make-array.lsp (deftest array-row-major-index.1 (array-row-major-index #0aNIL) 0) (deftest array-row-major-index.2 (loop for i from 0 to 4 collect (array-row-major-index #(a b c d e) i)) (0 1 2 3 4)) (deftest array-row-major-index.3 (let ((a (make-array '(5) :fill-pointer 1))) (loop for i from 0 to 4 collect (array-row-major-index a i))) (0 1 2 3 4)) (deftest array-row-major-index.order.1 (let ((x 0) y z (a #(a b c d e f))) (values (array-row-major-index (progn (setf y (incf x)) a) (progn (setf z (incf x)) 0)) x y z)) 0 2 1 2) ;;; Error tests (deftest array-row-major-index.error.1 (classify-error (array-row-major-index)) program-error) gcl/ansi-tests/array-t.lsp000066400000000000000000000107611242227143400160220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 25 11:55:48 2003 ;;;; Contains: Tests of (array t ...) type specifiers (in-package :cl-test) ;;; Tests of (array t) (deftest array-t.2.1 (notnot-mv (typep #() '(array t))) t) (deftest array-t.2.2 (notnot-mv (typep #0aX '(array t))) t) (deftest array-t.2.3 (notnot-mv (typep #2a(()) '(array t))) t) (deftest array-t.2.4 (notnot-mv (typep #(1 2 3) '(array t))) t) (deftest array-t.2.5 (typep "abcd" '(array t)) nil) (deftest array-t.2.6 (typep #*010101 '(array t)) nil) ;;; Tests of (array t ()) (deftest array-t.3.1 (notnot-mv (typep #() '(array t nil))) nil) (deftest array-t.3.2 (notnot-mv (typep #0aX '(array t nil))) t) (deftest array-t.3.3 (typep #2a(()) '(array t nil)) nil) (deftest array-t.3.4 (typep #(1 2 3) '(array t nil)) nil) (deftest array-t.3.5 (typep "abcd" '(array t nil)) nil) (deftest array-t.3.6 (typep #*010101 '(array t nil)) nil) ;;; Tests of (array t 1) ;;; The '1' indicates rank, so this is equivalent to 'vector' (deftest array-t.4.1 (notnot-mv (typep #() '(array t 1))) t) (deftest array-t.4.2 (typep #0aX '(array t 1)) nil) (deftest array-t.4.3 (typep #2a(()) '(array t 1)) nil) (deftest array-t.4.4 (notnot-mv (typep #(1 2 3) '(array t 1))) t) (deftest array-t.4.5 (typep "abcd" '(array t 1)) nil) (deftest array-t.4.6 (typep #*010101 '(array t 1)) nil) ;;; Tests of (array t 0) (deftest array-t.5.1 (typep #() '(array t 0)) nil) (deftest array-t.5.2 (notnot-mv (typep #0aX '(array t 0))) t) (deftest array-t.5.3 (typep #2a(()) '(array t 0)) nil) (deftest array-t.5.4 (typep #(1 2 3) '(array t 0)) nil) (deftest array-t.5.5 (typep "abcd" '(array t 0)) nil) (deftest array-t.5.6 (typep #*010101 '(array t 0)) nil) ;;; Tests of (array t *) (deftest array-t.6.1 (notnot-mv (typep #() '(array t *))) t) (deftest array-t.6.2 (notnot-mv (typep #0aX '(array t *))) t) (deftest array-t.6.3 (notnot-mv (typep #2a(()) '(array t *))) t) (deftest array-t.6.4 (notnot-mv (typep #(1 2 3) '(array t *))) t) (deftest array-t.6.5 (typep "abcd" '(array t *)) nil) (deftest array-t.6.6 (typep #*010101 '(array t *)) nil) ;;; Tests of (array t 2) (deftest array-t.7.1 (typep #() '(array t 2)) nil) (deftest array-t.7.2 (typep #0aX '(array t 2)) nil) (deftest array-t.7.3 (notnot-mv (typep #2a(()) '(array t 2))) t) (deftest array-t.7.4 (typep #(1 2 3) '(array t 2)) nil) (deftest array-t.7.5 (typep "abcd" '(array t 2)) nil) (deftest array-t.7.6 (typep #*010101 '(array t 2)) nil) ;;; Testing '(array t (--)) (deftest array-t.8.1 (typep #() '(array t (1))) nil) (deftest array-t.8.2 (notnot-mv (typep #() '(array t (0)))) t) (deftest array-t.8.3 (notnot-mv (typep #() '(array t (*)))) t) (deftest array-t.8.4 (typep #(a b c) '(array t (2))) nil) (deftest array-t.8.5 (notnot-mv (typep #(a b c) '(array t (3)))) t) (deftest array-t.8.6 (notnot-mv (typep #(a b c) '(array t (*)))) t) (deftest array-t.8.7 (typep #(a b c) '(array t (4))) nil) (deftest array-t.8.8 (typep #2a((a b c)) '(array t (*))) nil) (deftest array-t.8.9 (typep #2a((a b c)) '(array t (3))) nil) (deftest array-t.8.10 (typep #2a((a b c)) '(array t (1))) nil) (deftest array-t.8.11 (typep "abc" '(array t (2))) nil) (deftest array-t.8.12 (typep "abc" '(array t (3))) nil) (deftest array-t.8.13 (typep "abc" '(array t (*))) nil) (deftest array-t.8.14 (typep "abc" '(array t (4))) nil) ;;; Two dimensional array type tests (deftest array-t.9.1 (typep #() '(array t (* *))) nil) (deftest array-t.9.2 (typep "abc" '(array t (* *))) nil) (deftest array-t.9.3 (typep #(a b c) '(array t (3 *))) nil) (deftest array-t.9.4 (typep #(a b c) '(array t (* 3))) nil) (deftest array-t.9.5 (typep "abc" '(array t (3 *))) nil) (deftest array-t.9.6 (typep "abc" '(array t (* 3))) nil) (deftest array-t.9.7 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (* *)))) t) (deftest array-t.9.8 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (3 *)))) t) (deftest array-t.9.9 (typep #2a((a b)(c d)(e f)) '(array t (2 *))) nil) (deftest array-t.9.10 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (* 2)))) t) (deftest array-t.9.11 (typep #2a((a b)(c d)(e f)) '(array t (* 3))) nil) (deftest array-t.9.12 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (3 2)))) t) (deftest array-t.9.13 (typep #2a((a b)(c d)(e f)) '(array t (2 3))) nil) gcl/ansi-tests/array-total-size.lsp000066400000000000000000000025131242227143400176460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 22:01:09 2003 ;;;; Contains: Tests of ARRAY-TOTAL-SIZE (in-package :cl-test) ;;; More tests of ARRAY-TOTAL-SIZE are in make-array.lsp (deftest array-total-size.1 (array-total-size #0aNIL) 1) (deftest array-total-size.2 (array-total-size "abcdef") 6) (deftest array-total-size.3 (array-total-size #(a b c)) 3) (deftest array-total-size.4 (array-total-size #*0011010) 7) (deftest array-total-size.5 (array-total-size #2a((1 2 3)(4 5 6)(7 8 9)(a b c))) 12) (deftest array-total-size.order.1 (let ((i 0) a) (values (array-total-size (progn (setf a (incf i)) #(a b c d))) i a)) 4 1 1) ;;; Error tests (deftest array-total-size.error.1 (classify-error (array-total-size)) program-error) (deftest array-total-size.error.2 (classify-error (array-total-size #(a b c) nil)) program-error) (deftest array-total-size.error.3 (let (why) (loop for e in *mini-universe* when (and (not (typep e 'array)) (not (eql (setq why (classify-error** `(array-total-size ',e))) 'type-error))) collect (list e why))) nil) (deftest array-total-size.error.4 (classify-error (array-total-size 0)) type-error) (deftest array-total-size.error.5 (classify-error (locally (array-total-size 0) t)) type-error) gcl/ansi-tests/array.lsp000066400000000000000000000123201242227143400155520ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 25 08:46:58 2003 ;;;; Contains: Tests of the ARRAY type specifier (in-package :cl-test) ;;; Tests of array by itself (deftest array.1.1 (notnot-mv (typep #() 'array)) t) (deftest array.1.2 (notnot-mv (typep #0aX 'array)) t) (deftest array.1.3 (notnot-mv (typep #2a(()) 'array)) t) (deftest array.1.4 (notnot-mv (typep #(1 2 3) 'array)) t) (deftest array.1.5 (notnot-mv (typep "abcd" 'array)) t) (deftest array.1.6 (notnot-mv (typep #*010101 'array)) t) (deftest array.1.7 (typep nil 'array) nil) (deftest array.1.8 (typep 'x 'array) nil) (deftest array.1.9 (typep '(a b c) 'array) nil) (deftest array.1.10 (typep 10.0 'array) nil) (deftest array.1.11 (typep #'(lambda (x) (cons x nil)) 'array) nil) (deftest array.1.12 (typep 1 'array) nil) (deftest array.1.13 (typep (1+ most-positive-fixnum) 'array) nil) ;;; Tests of (array *) (deftest array.2.1 (notnot-mv (typep #() '(array *))) t) (deftest array.2.2 (notnot-mv (typep #0aX '(array *))) t) (deftest array.2.3 (notnot-mv (typep #2a(()) '(array *))) t) (deftest array.2.4 (notnot-mv (typep #(1 2 3) '(array *))) t) (deftest array.2.5 (notnot-mv (typep "abcd" '(array *))) t) (deftest array.2.6 (notnot-mv (typep #*010101 '(array *))) t) ;;; Tests of (array * ()) (deftest array.3.1 (notnot-mv (typep #() '(array * nil))) nil) (deftest array.3.2 (notnot-mv (typep #0aX '(array * nil))) t) (deftest array.3.3 (typep #2a(()) '(array * nil)) nil) (deftest array.3.4 (typep #(1 2 3) '(array * nil)) nil) (deftest array.3.5 (typep "abcd" '(array * nil)) nil) (deftest array.3.6 (typep #*010101 '(array * nil)) nil) ;;; Tests of (array * 1) ;;; The '1' indicates rank, so this is equivalent to 'vector' (deftest array.4.1 (notnot-mv (typep #() '(array * 1))) t) (deftest array.4.2 (typep #0aX '(array * 1)) nil) (deftest array.4.3 (typep #2a(()) '(array * 1)) nil) (deftest array.4.4 (notnot-mv (typep #(1 2 3) '(array * 1))) t) (deftest array.4.5 (notnot-mv (typep "abcd" '(array * 1))) t) (deftest array.4.6 (notnot-mv (typep #*010101 '(array * 1))) t) ;;; Tests of (array * 0) (deftest array.5.1 (typep #() '(array * 0)) nil) (deftest array.5.2 (notnot-mv (typep #0aX '(array * 0))) t) (deftest array.5.3 (typep #2a(()) '(array * 0)) nil) (deftest array.5.4 (typep #(1 2 3) '(array * 0)) nil) (deftest array.5.5 (typep "abcd" '(array * 0)) nil) (deftest array.5.6 (typep #*010101 '(array * 0)) nil) ;;; Tests of (array * *) (deftest array.6.1 (notnot-mv (typep #() '(array * *))) t) (deftest array.6.2 (notnot-mv (typep #0aX '(array * *))) t) (deftest array.6.3 (notnot-mv (typep #2a(()) '(array * *))) t) (deftest array.6.4 (notnot-mv (typep #(1 2 3) '(array * *))) t) (deftest array.6.5 (notnot-mv (typep "abcd" '(array * *))) t) (deftest array.6.6 (notnot-mv (typep #*010101 '(array * *))) t) ;;; Tests of (array * 2) (deftest array.7.1 (typep #() '(array * 2)) nil) (deftest array.7.2 (typep #0aX '(array * 2)) nil) (deftest array.7.3 (notnot-mv (typep #2a(()) '(array * 2))) t) (deftest array.7.4 (typep #(1 2 3) '(array * 2)) nil) (deftest array.7.5 (typep "abcd" '(array * 2)) nil) (deftest array.7.6 (typep #*010101 '(array * 2)) nil) ;;; Testing '(array * (--)) (deftest array.8.1 (typep #() '(array * (1))) nil) (deftest array.8.2 (notnot-mv (typep #() '(array * (0)))) t) (deftest array.8.3 (notnot-mv (typep #() '(array * (*)))) t) (deftest array.8.4 (typep #(a b c) '(array * (2))) nil) (deftest array.8.5 (notnot-mv (typep #(a b c) '(array * (3)))) t) (deftest array.8.6 (notnot-mv (typep #(a b c) '(array * (*)))) t) (deftest array.8.7 (typep #(a b c) '(array * (4))) nil) (deftest array.8.8 (typep #2a((a b c)) '(array * (*))) nil) (deftest array.8.9 (typep #2a((a b c)) '(array * (3))) nil) (deftest array.8.10 (typep #2a((a b c)) '(array * (1))) nil) (deftest array.8.11 (typep "abc" '(array * (2))) nil) (deftest array.8.12 (notnot-mv (typep "abc" '(array * (3)))) t) (deftest array.8.13 (notnot-mv (typep "abc" '(array * (*)))) t) (deftest array.8.14 (typep "abc" '(array * (4))) nil) ;;; Two dimensional array type tests (deftest array.9.1 (typep #() '(array * (* *))) nil) (deftest array.9.2 (typep "abc" '(array * (* *))) nil) (deftest array.9.3 (typep #(a b c) '(array * (3 *))) nil) (deftest array.9.4 (typep #(a b c) '(array * (* 3))) nil) (deftest array.9.5 (typep "abc" '(array * (3 *))) nil) (deftest array.9.6 (typep "abc" '(array * (* 3))) nil) (deftest array.9.7 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (* *)))) t) (deftest array.9.8 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (3 *)))) t) (deftest array.9.9 (typep #2a((a b)(c d)(e f)) '(array * (2 *))) nil) (deftest array.9.10 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (* 2)))) t) (deftest array.9.11 (typep #2a((a b)(c d)(e f)) '(array * (* 3))) nil) (deftest array.9.12 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (3 2)))) t) (deftest array.9.13 (typep #2a((a b)(c d)(e f)) '(array * (2 3))) nil) gcl/ansi-tests/arrayp.lsp000066400000000000000000000016301242227143400157340ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 22:08:21 2003 ;;;; Contains: Tests of ARRAYP (in-package :cl-test) ;;; Also tested by make-array.lsp (deftest arrayp.1 (notnot-mv (arrayp #(a b c))) t) (deftest arrayp.2 (notnot-mv (arrayp "abcd")) t) (deftest arrayp.3 (notnot-mv (arrayp #*001110101)) t) (deftest arrayp.4 (notnot-mv (arrayp #0aNIL)) t) (deftest arrayp.5 (notnot-mv (arrayp #2a((1 2 3)(4 5 6)))) t) (deftest arrayp.6 (loop for e in *universe* for a = (arrayp e) for b = (typep e 'array) when (or (and a (not b)) (and b (not a))) collect e) nil) (deftest arrayp.order.1 (let ((i 0) a) (values (arrayp (progn (setf a (incf i)) nil)) i a)) nil 1 1) ;;; Error tests (deftest arrayp.error.1 (classify-error (arrayp)) program-error) (deftest arrayp.error.2 (classify-error (arrayp #(a b c) nil)) program-error) gcl/ansi-tests/assert.lsp000066400000000000000000000031561242227143400157440ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 28 06:48:19 2003 ;;;; Contains: Tests of ASSERT (in-package :cl-test) (deftest assert.1 (assert t) nil) (deftest assert.2 (assert t ()) nil) ;;; I am assuming that when no places are given to ASSERT, ;;; it doesn't invoke any interactive handler. (deftest assert.3 (let ((x nil)) (handler-bind ((error #'(lambda (c) (setq x 17) (let ((r (find-restart 'continue c))) (when r (invoke-restart r)))))) (assert x) x)) 17) (deftest assert.3a (let ((x nil)) (handler-bind ((error #'(lambda (c) (setq x 17) (continue c)))) (assert x) x)) 17) ;;; I don't yet know how to test the interactive version of ASSERT ;;; that is normally invoked when places are given. ;;; Tests of the syntax (at least) (deftest assert.4 (let (x) (assert t (x))) nil) (deftest assert.5 (let ((x (cons 'a 'b))) (assert t ((car x) (cdr x)))) nil) (deftest assert.6 (let ((x (vector 'a 'b 'c))) (assert t ((aref x 0) (aref x 1) (aref x 2)) "Vector x has value: ~A." x)) nil) (deftest assert.7 (let ((x nil)) (handler-bind ((simple-error #'(lambda (c) (setq x 17) (continue c)))) (assert x () 'simple-error) x)) 17) (deftest assert.8 (let ((x 0)) (handler-bind ((type-error #'(lambda (c) (incf x) (continue c)))) (assert (> x 5) () 'type-error) x)) 6) (deftest assert.9 (let ((x 0)) (handler-bind ((type-error #'(lambda (c) (declare (ignore c)) (incf x) (continue)))) (assert (> x 5) () 'type-error) x)) 6) gcl/ansi-tests/atom-errors.lsp000066400000000000000000000012311242227143400167050ustar00rootroot00000000000000(setf x (loop for tp in '(CONDITION SERIOUS-CONDITION ERROR TYPE-ERROR SIMPLE-TYPE-ERROR SIMPLE-CONDITION PARSE-ERROR CELL-ERROR UNBOUND-SLOT WARNING STYLE-WARNING STORAGE-CONDITION SIMPLE-WARNING UNBOUND-VARIABLE CONTROL-ERROR PROGRAM-ERROR UNDEFINED-FUNCTION PACKAGE-ERROR ARITHMETIC-ERROR DIVISION-BY-ZERO FLOATING-POINT-INVALID-OPERATION FLOATING-POINT-INEXACT FLOATING-POINT-OVERFLOW FLOATING-POINT-UNDERFLOW FILE-ERROR BROADCAST-STREAM CONCATENATED-STREAM ECHO-STREAM FILE-STREAM STRING-STREAM SYNONYM-STREAM TWO-WAY-STREAM STREAM-ERROR END-OF-FILE PRINT-NOT-READABLE READER-ERROR) collect (list tp (multiple-value-list (subtypep* tp 'atom))))) gcl/ansi-tests/bit-and.lsp000066400000000000000000000142601242227143400157570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 18:18:47 2003 ;;;; Contains: Tests of BIT-AND (in-package :cl-test) (deftest bit-and.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-and s1 s2) s1 s2)) #0a0 #0a0 #0a0) (deftest bit-and.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-and s1 s2) s1 s2)) #0a0 #0a1 #0a0) (deftest bit-and.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-and s1 s2) s1 s2)) #0a0 #0a0 #0a1) (deftest bit-and.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-and s1 s2) s1 s2)) #0a1 #0a1 #0a1) (deftest bit-and.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-and s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a0 #0a0 t) (deftest bit-and.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-and s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a1 #0a1 t) (deftest bit-and.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-and s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 #0a0 t) ;;; Tests on bit vectors (deftest bit-and.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-and a1 a2)) a1 a2)) #*0001 #*0011 #*0101) (deftest bit-and.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-and a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0001 #*0001 #*0101 t) (deftest bit-and.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-and a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0001 #*0011 #*0101 #*0001 t) (deftest bit-and.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-and a1 a2 nil)) a1 a2)) #*0001 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-and.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-and a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) (deftest bit-and.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-and a1 a2 t))) (values a1 a2 result)) #2a((0 0)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) (deftest bit-and.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-and a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) (deftest bit-and.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-and a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1)) #2a((0 0)(0 1))) ;;; Adjustable arrays (deftest bit-and.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-and a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) ;;; Displaced arrays (deftest bit-and.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-and a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) (deftest bit-and.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-and a1 a2 t))) (values a0 a1 a2 result)) #*00010011 #2a((0 0)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) (deftest bit-and.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-and a1 a2 a3))) (values a0 a1 a2 result)) #*010100110001 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) (deftest bit-and.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-and (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) ;;; Error tests (deftest bit-and.error.1 (classify-error (bit-and)) program-error) (deftest bit-and.error.2 (classify-error (bit-and #*000)) program-error) (deftest bit-and.error.3 (classify-error (bit-and #*000 #*0100 nil nil)) program-error) gcl/ansi-tests/bit-andc1.lsp000066400000000000000000000144111242227143400162010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 18:56:39 2003 ;;;; Contains: Tests of BIT-ANDC1 (in-package :cl-test) (deftest bit-andc1.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-andc1 s1 s2) s1 s2)) #0a0 #0a0 #0a0) (deftest bit-andc1.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-andc1 s1 s2) s1 s2)) #0a0 #0a1 #0a0) (deftest bit-andc1.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-andc1 s1 s2) s1 s2)) #0a1 #0a0 #0a1) (deftest bit-andc1.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-andc1 s1 s2) s1 s2)) #0a0 #0a1 #0a1) (deftest bit-andc1.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-andc1 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a0 #0a0 t) (deftest bit-andc1.6 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-andc1 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a1 #0a1 #0a1 t) (deftest bit-andc1.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-andc1 s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 #0a0 t) ;;; Tests on bit vectors (deftest bit-andc1.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-andc1 a1 a2)) a1 a2)) #*0100 #*0011 #*0101) (deftest bit-andc1.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-andc1 a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0100 #*0100 #*0101 t) (deftest bit-andc1.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*0000)) (result (check-values (bit-andc1 a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0100 #*0011 #*0101 #*0100 t) (deftest bit-andc1.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-andc1 a1 a2 nil)) a1 a2)) #*0100 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-andc1.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-andc1 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) (deftest bit-andc1.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-andc1 a1 a2 t))) (values a1 a2 result)) #2a((0 0)(1 0)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) (deftest bit-andc1.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-andc1 a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) (deftest bit-andc1.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-andc1 a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(1 0)) #2a((0 0)(1 0))) ;;; Adjustable arrays (deftest bit-andc1.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-andc1 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) ;;; Displaced arrays (deftest bit-andc1.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-andc1 a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) (deftest bit-andc1.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-andc1 a1 a2 t))) (values a0 a1 a2 result)) #*00100011 #2a((0 0)(1 0)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) (deftest bit-andc1.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-andc1 a1 a2 a3))) (values a0 a1 a2 result)) #*010100110010 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) (deftest bit-andc1.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-andc1 (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) ;;; Error tests (deftest bit-andc1.error.1 (classify-error (bit-andc1)) program-error) (deftest bit-andc1.error.2 (classify-error (bit-andc1 #*000)) program-error) (deftest bit-andc1.error.3 (classify-error (bit-andc1 #*000 #*0100 nil nil)) program-error) gcl/ansi-tests/bit-andc2.lsp000066400000000000000000000144121242227143400162030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:01:38 2003 ;;;; Contains: Tests of BIT-ANDC2 (in-package :cl-test) (deftest bit-andc2.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-andc2 s1 s2) s1 s2)) #0a0 #0a0 #0a0) (deftest bit-andc2.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-andc2 s1 s2) s1 s2)) #0a1 #0a1 #0a0) (deftest bit-andc2.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-andc2 s1 s2) s1 s2)) #0a0 #0a0 #0a1) (deftest bit-andc2.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-andc2 s1 s2) s1 s2)) #0a0 #0a1 #0a1) (deftest bit-andc2.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-andc2 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a0 #0a0 t) (deftest bit-andc2.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-andc2 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a0 #0a1 #0a1 t) (deftest bit-andc2.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-andc2 s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a1 #0a0 t) ;;; Tests on bit vectors (deftest bit-andc2.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-andc2 a1 a2)) a1 a2)) #*0010 #*0011 #*0101) (deftest bit-andc2.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-andc2 a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0010 #*0010 #*0101 t) (deftest bit-andc2.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-andc2 a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0010 #*0011 #*0101 #*0010 t) (deftest bit-andc2.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-andc2 a1 a2 nil)) a1 a2)) #*0010 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-andc2.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-andc2 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) (deftest bit-andc2.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-andc2 a1 a2 t))) (values a1 a2 result)) #2a((0 1)(0 0)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) (deftest bit-andc2.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-andc2 a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) (deftest bit-andc2.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-andc2 a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(0 0)) #2a((0 1)(0 0))) ;;; Adjustable arrays (deftest bit-andc2.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-andc2 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) ;;; Displaced arrays (deftest bit-andc2.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-andc2 a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) (deftest bit-andc2.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-andc2 a1 a2 t))) (values a0 a1 a2 result)) #*01000011 #2a((0 1)(0 0)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) (deftest bit-andc2.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-andc2 a1 a2 a3))) (values a0 a1 a2 result)) #*010100110100 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) (deftest bit-andc2.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-andc2 (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) ;;; Error tests (deftest bit-andc2.error.1 (classify-error (bit-andc2)) program-error) (deftest bit-andc2.error.2 (classify-error (bit-andc2 #*000)) program-error) (deftest bit-andc2.error.3 (classify-error (bit-andc2 #*000 #*0100 nil nil)) program-error) gcl/ansi-tests/bit-eqv.lsp000066400000000000000000000142621242227143400160120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:07:23 2003 ;;;; Contains: Tests of BIT-EQV (in-package :cl-test) (deftest bit-eqv.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-eqv s1 s2) s1 s2)) #0a1 #0a0 #0a0) (deftest bit-eqv.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-eqv s1 s2) s1 s2)) #0a0 #0a1 #0a0) (deftest bit-eqv.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-eqv s1 s2) s1 s2)) #0a0 #0a0 #0a1) (deftest bit-eqv.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-eqv s1 s2) s1 s2)) #0a1 #0a1 #0a1) (deftest bit-eqv.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-eqv s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a1 #0a1 t) (deftest bit-eqv.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-eqv s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a1 #0a1 t) (deftest bit-eqv.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-eqv s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 #0a0 t) ;;; Tests on bit vectors (deftest bit-eqv.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-eqv a1 a2)) a1 a2)) #*1001 #*0011 #*0101) (deftest bit-eqv.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-eqv a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1001 #*1001 #*0101 t) (deftest bit-eqv.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*0000)) (result (check-values (bit-eqv a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1001 #*0011 #*0101 #*1001 t) (deftest bit-eqv.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-eqv a1 a2 nil)) a1 a2)) #*1001 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-eqv.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-eqv a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) (deftest bit-eqv.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-eqv a1 a2 t))) (values a1 a2 result)) #2a((1 0)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) (deftest bit-eqv.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-eqv a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) (deftest bit-eqv.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-eqv a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1)) #2a((1 0)(0 1))) ;;; Adjustable arrays (deftest bit-eqv.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-eqv a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) ;;; Displaced arrays (deftest bit-eqv.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-eqv a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) (deftest bit-eqv.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-eqv a1 a2 t))) (values a0 a1 a2 result)) #*10010011 #2a((1 0)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) (deftest bit-eqv.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-eqv a1 a2 a3))) (values a0 a1 a2 result)) #*010100111001 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) (deftest bit-eqv.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-eqv (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) ;;; Error tests (deftest bit-eqv.error.1 (classify-error (bit-eqv)) program-error) (deftest bit-eqv.error.2 (classify-error (bit-eqv #*000)) program-error) (deftest bit-eqv.error.3 (classify-error (bit-eqv #*000 #*0100 nil nil)) program-error) gcl/ansi-tests/bit-ior.lsp000066400000000000000000000142611242227143400160070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:13:34 2003 ;;;; Contains: Tests of BIT-IOR (in-package :cl-test) (deftest bit-ior.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-ior s1 s2) s1 s2)) #0a0 #0a0 #0a0) (deftest bit-ior.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-ior s1 s2) s1 s2)) #0a1 #0a1 #0a0) (deftest bit-ior.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-ior s1 s2) s1 s2)) #0a1 #0a0 #0a1) (deftest bit-ior.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-ior s1 s2) s1 s2)) #0a1 #0a1 #0a1) (deftest bit-ior.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-ior s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a0 #0a0 t) (deftest bit-ior.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-ior s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a1 #0a1 t) (deftest bit-ior.7 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-ior s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a1 #0a1 #0a1 t) ;;; Tests on bit vectors (deftest bit-ior.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-ior a1 a2)) a1 a2)) #*0111 #*0011 #*0101) (deftest bit-ior.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-ior a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0111 #*0111 #*0101 t) (deftest bit-ior.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-ior a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0111 #*0011 #*0101 #*0111 t) (deftest bit-ior.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-ior a1 a2 nil)) a1 a2)) #*0111 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-ior.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-ior a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) (deftest bit-ior.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-ior a1 a2 t))) (values a1 a2 result)) #2a((0 1)(1 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) (deftest bit-ior.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-ior a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) (deftest bit-ior.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-ior a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1)) #2a((0 1)(1 1))) ;;; Adjustable arrays (deftest bit-ior.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-ior a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) ;;; Displaced arrays (deftest bit-ior.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-ior a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) (deftest bit-ior.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-ior a1 a2 t))) (values a0 a1 a2 result)) #*01110011 #2a((0 1)(1 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) (deftest bit-ior.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-ior a1 a2 a3))) (values a0 a1 a2 result)) #*010100110111 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) (deftest bit-ior.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-ior (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) ;;; Error tests (deftest bit-ior.error.1 (classify-error (bit-ior)) program-error) (deftest bit-ior.error.2 (classify-error (bit-ior #*000)) program-error) (deftest bit-ior.error.3 (classify-error (bit-ior #*000 #*0100 nil nil)) program-error) gcl/ansi-tests/bit-nand.lsp000066400000000000000000000143421242227143400161360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:16:15 2003 ;;;; Contains: Tests for BIT-NAND (in-package :cl-test) (deftest bit-nand.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-nand s1 s2) s1 s2)) #0a1 #0a0 #0a0) (deftest bit-nand.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-nand s1 s2) s1 s2)) #0a1 #0a1 #0a0) (deftest bit-nand.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-nand s1 s2) s1 s2)) #0a1 #0a0 #0a1) (deftest bit-nand.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-nand s1 s2) s1 s2)) #0a0 #0a1 #0a1) (deftest bit-nand.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-nand s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a1 #0a1 t) (deftest bit-nand.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-nand s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a0 #0a0 t) (deftest bit-nand.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-nand s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a1 #0a0 #0a1 t) ;;; Tests on bit vectors (deftest bit-nand.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-nand a1 a2)) a1 a2)) #*1110 #*0011 #*0101) (deftest bit-nand.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-nand a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1110 #*1110 #*0101 t) (deftest bit-nand.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-nand a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1110 #*0011 #*0101 #*1110 t) (deftest bit-nand.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-nand a1 a2 nil)) a1 a2)) #*1110 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-nand.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-nand a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) (deftest bit-nand.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-nand a1 a2 t))) (values a1 a2 result)) #2a((1 1)(1 0)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) (deftest bit-nand.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-nand a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) (deftest bit-nand.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-nand a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(1 0)) #2a((1 1)(1 0))) ;;; Adjustable arrays (deftest bit-nand.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-nand a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) ;;; Displaced arrays (deftest bit-nand.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-nand a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) (deftest bit-nand.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-nand a1 a2 t))) (values a0 a1 a2 result)) #*11100011 #2a((1 1)(1 0)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) (deftest bit-nand.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-nand a1 a2 a3))) (values a0 a1 a2 result)) #*010100111110 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) (deftest bit-nand.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-nand (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) ;;; Error tests (deftest bit-nand.error.1 (classify-error (bit-nand)) program-error) (deftest bit-nand.error.2 (classify-error (bit-nand #*000)) program-error) (deftest bit-nand.error.3 (classify-error (bit-nand #*000 #*0100 nil nil)) program-error) gcl/ansi-tests/bit-nor.lsp000066400000000000000000000142621242227143400160150ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:20:40 2003 ;;;; Contains: Tests for BIT-NOR (in-package :cl-test) (deftest bit-nor.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-nor s1 s2) s1 s2)) #0a1 #0a0 #0a0) (deftest bit-nor.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-nor s1 s2) s1 s2)) #0a0 #0a1 #0a0) (deftest bit-nor.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-nor s1 s2) s1 s2)) #0a0 #0a0 #0a1) (deftest bit-nor.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-nor s1 s2) s1 s2)) #0a0 #0a1 #0a1) (deftest bit-nor.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-nor s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a1 #0a1 t) (deftest bit-nor.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-nor s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a0 #0a0 t) (deftest bit-nor.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-nor s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 #0a0 t) ;;; Tests on bit vectors (deftest bit-nor.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-nor a1 a2)) a1 a2)) #*1000 #*0011 #*0101) (deftest bit-nor.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-nor a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1000 #*1000 #*0101 t) (deftest bit-nor.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-nor a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1000 #*0011 #*0101 #*1000 t) (deftest bit-nor.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-nor a1 a2 nil)) a1 a2)) #*1000 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-nor.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-nor a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) (deftest bit-nor.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-nor a1 a2 t))) (values a1 a2 result)) #2a((1 0)(0 0)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) (deftest bit-nor.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-nor a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) (deftest bit-nor.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-nor a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 0)) #2a((1 0)(0 0))) ;;; Adjustable arrays (deftest bit-nor.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-nor a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) ;;; Displaced arrays (deftest bit-nor.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-nor a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) (deftest bit-nor.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-nor a1 a2 t))) (values a0 a1 a2 result)) #*10000011 #2a((1 0)(0 0)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) (deftest bit-nor.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-nor a1 a2 a3))) (values a0 a1 a2 result)) #*010100111000 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) (deftest bit-nor.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-nor (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) ;;; Error tests (deftest bit-nor.error.1 (classify-error (bit-nor)) program-error) (deftest bit-nor.error.2 (classify-error (bit-nor #*000)) program-error) (deftest bit-nor.error.3 (classify-error (bit-nor #*000 #*0100 nil nil)) program-error) gcl/ansi-tests/bit-not.lsp000066400000000000000000000063351242227143400160210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:40:13 2003 ;;;; Contains: Tests of BIT-NOT (in-package :cl-test) (deftest bit-not.1 (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) (values (bit-not a1) a1)) #0a1 #0a0) (deftest bit-not.2 (let ((a1 (make-array nil :element-type 'bit :initial-element 1))) (values (bit-not a1) a1)) #0a0 #0a1) (deftest bit-not.3 (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) (values (bit-not a1 t) a1)) #0a1 #0a1) (deftest bit-not.4 (let ((a1 (make-array nil :element-type 'bit :initial-element 1))) (values (bit-not a1 t) a1)) #0a0 #0a0) (deftest bit-not.5 (let* ((a1 (make-array nil :element-type 'bit :initial-element 1)) (a2 (make-array nil :element-type 'bit :initial-element 1)) (result (bit-not a1 a2))) (values a1 a2 (eqt a2 result))) #0a1 #0a0 t) (deftest bit-not.6 (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) (values (bit-not a1 nil) a1)) #0a1 #0a0) ;;; Tests on bit vectors (deftest bit-not.7 (let ((a1 (copy-seq #*0011010110))) (values (bit-not a1) a1)) #*1100101001 #*0011010110) (deftest bit-not.8 (let ((a1 (copy-seq #*0011010110))) (values (bit-not a1 t) a1)) #*1100101001 #*1100101001) (deftest bit-not.9 (let ((a1 (copy-seq #*0011010110)) (a2 (copy-seq #*0000000000))) (values (bit-not a1 a2) a1 a2)) #*1100101001 #*0011010110 #*1100101001) ;;; Arrays (deftest bit-not.10 (let ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(1 0))))) (values (bit-not a1) a1)) #2a((1 0)(0 1)) #2a((0 1)(1 0))) (deftest bit-not.11 (let ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(1 0))))) (values (bit-not a1 nil) a1)) #2a((1 0)(0 1)) #2a((0 1)(1 0))) (deftest bit-not.12 (let ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(1 0))))) (values (bit-not a1 t) a1)) #2a((1 0)(0 1)) #2a((1 0)(0 1))) (deftest bit-not.13 (let ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(1 0)))) (a2 (make-array '(2 2) :element-type 'bit :initial-element 0))) (values (bit-not a1 a2) a1 a2)) #2a((1 0)(0 1)) #2a((0 1)(1 0)) #2a((1 0)(0 1))) ;;; Adjustable array (deftest bit-not.14 (let ((a1 (make-array '(2 2) :element-type 'bit :adjustable t :initial-contents '((0 1)(1 0))))) (values (bit-not a1) a1)) #2a((1 0)(0 1)) #2a((0 1)(1 0))) ;;; Displaced arrays (deftest bit-not.15 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 0 0 1 1 0 0 0 0 0 0 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 2)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 6))) (values (bit-not a1 a2) a0 a1 a2)) #2a((1 0)(0 1)) #*000110100100 #2a((0 1)(1 0)) #2a((1 0)(0 1))) (deftest bit-not.order.1 (let ((a (copy-seq #*001101)) (i 0) x) (values (bit-not (progn (setf x (incf i)) a)) i x)) #*110010 1 1) ;;; Error tests (deftest bit-not.error.1 (classify-error (bit-not)) program-error) (deftest bit-not.error.2 (classify-error (bit-not #*000 nil nil)) program-error) gcl/ansi-tests/bit-orc1.lsp000066400000000000000000000143411242227143400160610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:25:28 2003 ;;;; Contains: Tests of BIT-ORC1 (in-package :cl-test) (deftest bit-orc1.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-orc1 s1 s2) s1 s2)) #0a1 #0a0 #0a0) (deftest bit-orc1.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-orc1 s1 s2) s1 s2)) #0a0 #0a1 #0a0) (deftest bit-orc1.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-orc1 s1 s2) s1 s2)) #0a1 #0a0 #0a1) (deftest bit-orc1.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-orc1 s1 s2) s1 s2)) #0a1 #0a1 #0a1) (deftest bit-orc1.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-orc1 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a1 #0a1 t) (deftest bit-orc1.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-orc1 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a1 #0a1 t) (deftest bit-orc1.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-orc1 s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 #0a0 t) ;;; Tests on bit vectors (deftest bit-orc1.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-orc1 a1 a2)) a1 a2)) #*1101 #*0011 #*0101) (deftest bit-orc1.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-orc1 a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1101 #*1101 #*0101 t) (deftest bit-orc1.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-orc1 a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1101 #*0011 #*0101 #*1101 t) (deftest bit-orc1.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-orc1 a1 a2 nil)) a1 a2)) #*1101 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-orc1.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-orc1 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) (deftest bit-orc1.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-orc1 a1 a2 t))) (values a1 a2 result)) #2a((1 0)(1 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) (deftest bit-orc1.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-orc1 a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) (deftest bit-orc1.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-orc1 a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1)) #2a((1 0)(1 1))) ;;; Adjustable arrays (deftest bit-orc1.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-orc1 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) ;;; Displaced arrays (deftest bit-orc1.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-orc1 a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) (deftest bit-orc1.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-orc1 a1 a2 t))) (values a0 a1 a2 result)) #*10110011 #2a((1 0)(1 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) (deftest bit-orc1.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-orc1 a1 a2 a3))) (values a0 a1 a2 result)) #*010100111011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) (deftest bit-orc1.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-orc1 (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) ;;; Error tests (deftest bit-orc1.error.1 (classify-error (bit-orc1)) program-error) (deftest bit-orc1.error.2 (classify-error (bit-orc1 #*000)) program-error) (deftest bit-orc1.error.3 (classify-error (bit-orc1 #*000 #*0100 nil nil)) program-error) gcl/ansi-tests/bit-orc2.lsp000066400000000000000000000143421242227143400160630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:31:35 2003 ;;;; Contains: Tests of BIT-ORC2 (in-package :cl-test) (deftest bit-orc2.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-orc2 s1 s2) s1 s2)) #0a1 #0a0 #0a0) (deftest bit-orc2.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-orc2 s1 s2) s1 s2)) #0a1 #0a1 #0a0) (deftest bit-orc2.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-orc2 s1 s2) s1 s2)) #0a0 #0a0 #0a1) (deftest bit-orc2.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-orc2 s1 s2) s1 s2)) #0a1 #0a1 #0a1) (deftest bit-orc2.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-orc2 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a1 #0a1 t) (deftest bit-orc2.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-orc2 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a1 #0a1 t) (deftest bit-orc2.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-orc2 s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a1 #0a0 #0a1 t) ;;; Tests on bit vectors (deftest bit-orc2.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-orc2 a1 a2)) a1 a2)) #*1011 #*0011 #*0101) (deftest bit-orc2.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-orc2 a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1011 #*1011 #*0101 t) (deftest bit-orc2.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-orc2 a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1011 #*0011 #*0101 #*1011 t) (deftest bit-orc2.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-orc2 a1 a2 nil)) a1 a2)) #*1011 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-orc2.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-orc2 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) (deftest bit-orc2.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-orc2 a1 a2 t))) (values a1 a2 result)) #2a((1 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) (deftest bit-orc2.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-orc2 a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) (deftest bit-orc2.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-orc2 a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1)) #2a((1 1)(0 1))) ;;; Adjustable arrays (deftest bit-orc2.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-orc2 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) ;;; Displaced arrays (deftest bit-orc2.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-orc2 a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) (deftest bit-orc2.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-orc2 a1 a2 t))) (values a0 a1 a2 result)) #*11010011 #2a((1 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) (deftest bit-orc2.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-orc2 a1 a2 a3))) (values a0 a1 a2 result)) #*010100111101 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) (deftest bit-orc2.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-orc2 (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) ;;; Error tests (deftest bit-orc2.error.1 (classify-error (bit-orc2)) program-error) (deftest bit-orc2.error.2 (classify-error (bit-orc2 #*000)) program-error) (deftest bit-orc2.error.3 (classify-error (bit-orc2 #*000 #*0100 nil nil)) program-error) gcl/ansi-tests/bit-vector-p.lsp000066400000000000000000000025471242227143400167610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 20:16:50 2003 ;;;; Contains: Tests of BIT-VECTOR-P (in-package :cl-test) (deftest bit-vector-p.2 (notnot-mv (bit-vector-p #*)) t) (deftest bit-vector-p.3 (notnot-mv (bit-vector-p #*00101)) t) (deftest bit-vector-p.4 (bit-vector-p #(0 1 1 1 0 0)) nil) (deftest bit-vector-p.5 (bit-vector-p "011100") nil) (deftest bit-vector-p.6 (bit-vector-p 0) nil) (deftest bit-vector-p.7 (bit-vector-p 1) nil) (deftest bit-vector-p.8 (bit-vector-p nil) nil) (deftest bit-vector-p.9 (bit-vector-p 'x) nil) (deftest bit-vector-p.10 (bit-vector-p '(0 1 1 0)) nil) (deftest bit-vector-p.11 (bit-vector-p (make-array '(2 2) :element-type 'bit :initial-element 0)) nil) (deftest bit-vector-p.12 (loop for e in *universe* for p1 = (typep e 'bit-vector) for p2 = (bit-vector-p e) always (if p1 p2 (not p2))) t) (deftest bit-vector-p.order.1 (let ((i 0) x) (values (notnot (bit-vector-p (progn (setf x (incf i)) #*0010))) i x)) t 1 1) (deftest bit-vector-p.order.2 (let ((i 0) x) (values (bit-vector-p (progn (setf x (incf i)) 'a)) i x)) nil 1 1) (deftest bit-vector-p.error.1 (classify-error (bit-vector-p)) program-error) (deftest bit-vector-p.error.2 (classify-error (bit-vector-p #* #*)) program-error) gcl/ansi-tests/bit-vector.lsp000066400000000000000000000042441242227143400165200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 13:03:22 2003 ;;;; Contains: Tests of type BIT-VECTOR (in-package :cl-test) (deftest bit-vector.1 (notnot-mv (find-class 'bit-vector)) t) (deftest bit-vector.2 (notnot-mv (typep #* 'bit-vector)) t) (deftest bit-vector.3 (notnot-mv (typep #*00101 'bit-vector)) t) (deftest bit-vector.4 (typep #(0 1 1 1 0 0) 'bit-vector) nil) (deftest bit-vector.5 (typep "011100" 'bit-vector) nil) (deftest bit-vector.6 (typep 0 'bit-vector) nil) (deftest bit-vector.7 (typep 1 'bit-vector) nil) (deftest bit-vector.8 (typep nil 'bit-vector) nil) (deftest bit-vector.9 (typep 'x 'bit-vector) nil) (deftest bit-vector.10 (typep '(0 1 1 0) 'bit-vector) nil) (deftest bit-vector.11 (typep (make-array '(2 2) :element-type 'bit :initial-element 0) 'bit-vector) nil) (deftest bit-vector.12 (notnot-mv (typep #* '(bit-vector *))) t) (deftest bit-vector.13 (notnot-mv (typep #*01101 '(bit-vector *))) t) (deftest bit-vector.14 (notnot-mv (typep #* '(bit-vector 0))) t) (deftest bit-vector.15 (typep #*01101 '(bit-vector 0)) nil) (deftest bit-vector.16 (typep #* '(bit-vector 5)) nil) (deftest bit-vector.17 (notnot-mv (typep #*01101 '(bit-vector 5))) t) ;;; Tests of typep on the class named bit-vector (deftest bit-vector.class.2 (notnot-mv (typep #* (find-class 'bit-vector))) t) (deftest bit-vector.class.3 (notnot-mv (typep #*00101 (find-class 'bit-vector))) t) (deftest bit-vector.class.4 (typep #(0 1 1 1 0 0) (find-class 'bit-vector)) nil) (deftest bit-vector.class.5 (typep "011100" (find-class 'bit-vector)) nil) (deftest bit-vector.class.6 (typep 0 (find-class 'bit-vector)) nil) (deftest bit-vector.class.7 (typep 1 (find-class 'bit-vector)) nil) (deftest bit-vector.class.8 (typep nil (find-class 'bit-vector)) nil) (deftest bit-vector.class.9 (typep 'x (find-class 'bit-vector)) nil) (deftest bit-vector.class.10 (typep '(0 1 1 0) (find-class 'bit-vector)) nil) (deftest bit-vector.class.11 (typep (make-array '(2 2) :element-type 'bit :initial-element 0) (find-class 'bit-vector)) nil) gcl/ansi-tests/bit-xor.lsp000066400000000000000000000142611242227143400160260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:35:46 2003 ;;;; Contains: Tests of BIT-XOR (in-package :cl-test) (deftest bit-xor.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-xor s1 s2) s1 s2)) #0a0 #0a0 #0a0) (deftest bit-xor.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-xor s1 s2) s1 s2)) #0a1 #0a1 #0a0) (deftest bit-xor.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-xor s1 s2) s1 s2)) #0a1 #0a0 #0a1) (deftest bit-xor.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-xor s1 s2) s1 s2)) #0a0 #0a1 #0a1) (deftest bit-xor.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-xor s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a0 #0a0 t) (deftest bit-xor.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-xor s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a0 #0a0 t) (deftest bit-xor.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-xor s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a1 #0a0 #0a1 t) ;;; Tests on bit vectors (deftest bit-xor.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-xor a1 a2)) a1 a2)) #*0110 #*0011 #*0101) (deftest bit-xor.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-xor a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0110 #*0110 #*0101 t) (deftest bit-xor.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-xor a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0110 #*0011 #*0101 #*0110 t) (deftest bit-xor.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-xor a1 a2 nil)) a1 a2)) #*0110 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-xor.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-xor a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) (deftest bit-xor.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-xor a1 a2 t))) (values a1 a2 result)) #2a((0 1)(1 0)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) (deftest bit-xor.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-xor a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) (deftest bit-xor.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-xor a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 0)) #2a((0 1)(1 0))) ;;; Adjustable arrays (deftest bit-xor.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-xor a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) ;;; Displaced arrays (deftest bit-xor.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-xor a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) (deftest bit-xor.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-xor a1 a2 t))) (values a0 a1 a2 result)) #*01100011 #2a((0 1)(1 0)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) (deftest bit-xor.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-xor a1 a2 a3))) (values a0 a1 a2 result)) #*010100110110 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) (deftest bit-xor.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-xor (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) ;;; Error tests (deftest bit-xor.error.1 (classify-error (bit-xor)) program-error) (deftest bit-xor.error.2 (classify-error (bit-xor #*000)) program-error) (deftest bit-xor.error.3 (classify-error (bit-xor #*000 #*0100 nil nil)) program-error) gcl/ansi-tests/bit.lsp000066400000000000000000000055561242227143400152270ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 13:22:59 2003 ;;;; Contains: Tests for accessor BIT (in-package :cl-test) (deftest bit.1 (bit #*0010 2) 1) (deftest bit.2 (let ((a #*00000000)) (loop for i from 0 below (length a) collect (let ((b (copy-seq a))) (setf (bit b i) 1) b))) (#*10000000 #*01000000 #*00100000 #*00010000 #*00001000 #*00000100 #*00000010 #*00000001)) (deftest bit.3 (let ((a #*11111111)) (loop for i from 0 below (length a) collect (let ((b (copy-seq a))) (setf (bit b i) 0) b))) (#*01111111 #*10111111 #*11011111 #*11101111 #*11110111 #*11111011 #*11111101 #*11111110)) (deftest bit.4 (let ((a (make-array nil :element-type 'bit :initial-element 0))) (values (aref a) (bit a) (setf (bit a) 1) (aref a) (bit a))) 0 0 1 1 1) (deftest bit.5 (let ((a (make-array '(1 1) :element-type 'bit :initial-element 0))) (values (aref a 0 0) (bit a 0 0) (setf (bit a 0 0) 1) (aref a 0 0) (bit a 0 0))) 0 0 1 1 1) (deftest bit.6 (let ((a (make-array '(10 10) :element-type 'bit :initial-element 0))) (values (aref a 5 5) (bit a 5 5) (setf (bit a 5 5) 1) (aref a 5 5) (bit a 5 5))) 0 0 1 1 1) ;;; Check that the fill pointer is ignored (deftest bit.7 (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 1 1 1 0 0) :element-type 'bit :fill-pointer 5))) (values (coerce a 'list) (loop for i from 0 below 10 collect (bit a i)) (loop for i from 0 below 10 collect (setf (bit a i) (- 1 (bit a i)))) (coerce a 'list) (loop for i from 0 below 10 collect (bit a i)) (fill-pointer a))) (0 1 1 0 0) (0 1 1 0 0 1 1 1 0 0) (1 0 0 1 1 0 0 0 1 1) (1 0 0 1 1) (1 0 0 1 1 0 0 0 1 1) 5) ;;; Check that adjustability is not relevant (deftest bit.8 (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 1 1 1 0 0) :element-type 'bit :adjustable t))) (values (coerce a 'list) (loop for i from 0 below 10 collect (bit a i)) (loop for i from 0 below 10 collect (setf (bit a i) (- 1 (bit a i)))) (coerce a 'list) (loop for i from 0 below 10 collect (bit a i)))) (0 1 1 0 0 1 1 1 0 0) (0 1 1 0 0 1 1 1 0 0) (1 0 0 1 1 0 0 0 1 1) (1 0 0 1 1 0 0 0 1 1) (1 0 0 1 1 0 0 0 1 1)) ;;; Order of evaluation tests (deftest bit.order.1 (let ((x 0) y z (b (copy-seq #*01010))) (values (bit (progn (setf y (incf x)) b) (progn (setf z (incf x)) 1)) x y z)) 1 2 1 2) (deftest bit.order.2 (let ((x 0) y z w (b (copy-seq #*01010))) (values (setf (bit (progn (setf y (incf x)) b) (progn (setf z (incf x)) 1)) (progn (setf w (incf x)) 0)) b x y z w)) 0 #*00010 3 1 2 3) (deftest bit.error.1 (classify-error (bit)) program-error) gcl/ansi-tests/block.lsp000066400000000000000000000021531242227143400155310ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 12:30:46 2002 ;;;; Contains: Tests of BLOCK (in-package :cl-test) (deftest block.1 (block foo (return-from foo 1)) 1) (deftest block.2 (block nil (block foo (return 'good)) 'bad) good) (deftest block.3 (block done (flet ((%f (x) (return-from done x))) (%f 'good)) 'bad) good) (deftest block.4 (block foo (block foo (return-from foo 'bad)) 'good) good) (deftest block.5 (block done (flet ((%f (x) (return-from done x))) (mapcar #'%f '(good bad bad))) 'bad) good) (deftest block.6 (block b1 (return-from b1 (values)) 1)) (deftest block.7 (block b1 (return-from b1 (values 1 2 3 4)) 1) 1 2 3 4) (deftest block.8 (block foo) nil) (deftest block.9 (block foo (values 'a 'b) (values 'c 'd)) c d) (deftest block.10 (block done (flet ((%f (x) (return-from done x))) (block done (mapcar #'%f '(good bad bad)))) 'bad) good) #| (deftest return.error.1 (classify-error (block nil (return 'a 'b))) program-error) |# gcl/ansi-tests/boundp.lsp000066400000000000000000000016751242227143400157360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 14 05:58:01 2003 ;;;; Contains: Tests for BOUNDP (in-package :cl-test) (deftest boundp.error.1 (classify-error (boundp)) program-error) (deftest boundp.error.2 (classify-error (boundp 'a 'a)) program-error) (deftest boundp.error.3 (classify-error (boundp 1)) type-error) (deftest boundp.error.4 (classify-error (boundp '(setf car))) type-error) (deftest boundp.error.5 (classify-error (boundp "abc")) type-error) (deftest boundp.error.6 (classify-error (locally (boundp "abc") t)) type-error) ;;; See other tests in cl-symbols.lsp (deftest boundp.1 (notnot-mv (boundp 't)) t) (deftest boundp.2 (notnot-mv (boundp nil)) t) (deftest boundp.3 (notnot-mv (boundp :foo)) t) (deftest boundp.4 (boundp '#:foo) nil) (deftest boundp.order.1 (let ((i 0) x) (values (boundp (progn (setf x (incf i)) '#:foo)) i x)) nil 1 1) gcl/ansi-tests/call-arguments-limit.lsp000066400000000000000000000012341242227143400204700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 22:39:25 2002 ;;;; Contains: Tests for CALL-ARGUMENTS-LIMIT (in-package :cl-test) (deftest call-arguments-limit.1 (notnot-mv (constantp 'call-arguments-limit)) t) (deftest call-arguments-limit.2 (notnot-mv (typep call-arguments-limit 'integer)) t) (deftest call-arguments-limit.3 (< call-arguments-limit 50) nil) (deftest call-arguments-limit.4 (let* ((m (min 65536 (1- call-arguments-limit))) (args (make-list m :initial-element 'a))) (equal (apply #'list args) args)) t) (deftest call-arguments-limit.5 (< call-arguments-limit lambda-parameters-limit) nil) gcl/ansi-tests/case.lsp000066400000000000000000000052231242227143400153530ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 19:56:44 2002 ;;;; Contains: Tests of CASE (in-package :cl-test) (deftest case.1 (case 'a) nil) (deftest case.2 (case 10 (10 'a)) a) (deftest case.3 (case (copy-seq "abc") ("abc" 'a)) nil) (deftest case.4 (case 'z ((a b c) 1) ((d e) 2) ((f z g) 3) (t 4)) 3) (deftest case.5 (case (1+ most-positive-fixnum) (#.(1+ most-positive-fixnum) 'a)) a) (deftest case.6 (case nil (nil 'a) (t 'b)) b) (deftest case.7 (case nil ((nil) 'a) (t 'b)) a) (deftest case.8 (case 'a (b 0) (a (values 1 2 3)) (t nil)) 1 2 3) (deftest case.9 (case 'c (b 0) (a (values 1 2 3)) (t (values 'x 'y 'z))) x y z) (deftest case.10 (case 'z (b 1) (a 2) (z (values)) (t nil))) (deftest case.11 (case 'z (b 1) (a 2) (t (values)))) (deftest case.12 (case t (a 10)) nil) (deftest case.13 (case t ((t) 10) (t 20)) 10) (deftest case.14 (let ((x (list 'a 'b))) (eval `(case (quote ,x) ((,x) 1) (t 2)))) 1) (deftest case.15 (case 'otherwise ((t) 10)) nil) (deftest case.16 (case t ((otherwise) 10)) nil) (deftest case.17 (case 'a (b 0) (c 1) (otherwise 2)) 2) (deftest case.18 (case 'a (b 0) (c 1) ((otherwise) 2)) nil) (deftest case.19 (case 'a (b 0) (c 1) ((t) 2)) nil) (deftest case.20 (case #\a ((#\b #\c) 10) ((#\d #\e #\A) 20) (() 30) ((#\z #\a #\y) 40)) 40) (deftest case.21 (case 1 (1 (values)))) (deftest case.22 (case 2 (t (values)))) (deftest case.23 (case 1 (1 (values 'a 'b 'c))) a b c) (deftest case.24 (case 2 (t (values 'a 'b 'c))) a b c) ;;; Show that the key expression is evaluated only once. (deftest case.25 (let ((x 0)) (values (case (progn (incf x) 'c) (a 1) (b 2) (c 3) (t 4)) x)) 3 1) ;;; Repeated keys are allowed (all but the first are ignored) (deftest case.26 (case 'b ((a b c) 10) (b 20)) 10) (deftest case.27 (case 'b (b 20) ((a b c) 10)) 20) (deftest case.28 (case 'b (b 20) (b 10) (t 0)) 20) ;;; There are implicit progns (deftest case.29 (let ((x nil)) (values (case 2 (1 (setq x 'a) 'w) (2 (setq x 'b) 'y) (t (setq x 'c) 'z)) x)) y b) (deftest case.30 (let ((x nil)) (values (case 10 (1 (setq x 'a) 'w) (2 (setq x 'b) 'y) (t (setq x 'c) 'z)) x)) z c) (deftest case.31 (case (values 'b 'c) (c 0) ((a b) 10) (t 20)) 10) (deftest case.32 (case 'a (a) (t 'b)) nil) (deftest case.33 (case 'a (b 'b) (t)) nil) (deftest case.34 (case 'a (b 'b) (otherwise)) nil) ;;; (deftest case.error.1 ;;; (classify-error (case)) ;;; program-error) gcl/ansi-tests/catch.lsp000066400000000000000000000023711242227143400155230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 13:04:02 2002 ;;;; Contains: Tests of CATCH and THROW (in-package :cl-test) (deftest catch.1 (catch 'foo) nil) (deftest catch.2 (catch 'foo 'a) a) (deftest catch.3 (catch 'foo (values))) (deftest catch.4 (catch 'foo (values 1 2 3)) 1 2 3) (deftest catch.5 (catch 'foo 'a (throw 'foo 'b) 'c) b) (deftest catch.6 (let ((tag1 (1+ most-positive-fixnum)) (tag2 (1+ most-positive-fixnum))) (if (eqt tag1 tag2) 'good (catch tag1 (catch tag2 (throw tag1 'good)) 'bad))) good) (deftest catch.7 (catch 'foo 'a (throw 'foo (values)) 'c)) (deftest catch.8 (catch 'foo 'a (throw 'foo (values 1 2 3)) 'c) 1 2 3) (deftest catch.9 (let ((i 0)) (catch (progn (incf i) 'foo) (assert (eql i 1)) (throw (progn (incf i 2) 'foo) i))) 3) (deftest catch.10 (flet ((%f (x) (throw 'foo x))) (catch 'foo (%f 'good) 'bad)) good) (defun catch.11-fn (x) (throw 'foo x)) (deftest catch.11 (catch 'foo (catch.11-fn 'good) 'bad) good) (deftest catch.12 (labels ((%f (x) (throw 'foo x))) (catch 'foo (%f 'good) 'bad)) good) (deftest throw-error (classify-error (throw (gensym) nil)) control-error) gcl/ansi-tests/ccase.lsp000066400000000000000000000062431242227143400155210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 21:06:45 2002 ;;;; Contains: Tests of CCASE (in-package :cl-test) (deftest ccase.1 (let ((x 'b)) (ccase x (a 1) (b 2) (c 3))) 2) (deftest ccase.2 (classify-error (let ((x 1)) (ccase x))) type-error) (deftest ccase.3 (classify-error (let ((x 1)) (ccase x (a 1) (b 2) (c 3)))) type-error) ;;; It is legal to use T or OTHERWISE as key designators ;;; in CCASE forms. They have no special meaning here. (deftest ccase.4 (classify-error (let ((x 1)) (ccase x (t nil)))) type-error) (deftest ccase.5 (classify-error (let ((x 1)) (ccase x (otherwise nil)))) type-error) (deftest ccase.6 (let ((x 'b)) (ccase x ((a z) 1) ((y b w) 2) ((b c) 3))) 2) (deftest ccase.7 (let ((x 'z)) (ccase x ((a b c) 1) ((d e) 2) ((f z g) 3))) 3) (deftest ccase.8 (let ((x (1+ most-positive-fixnum))) (ccase x (#.(1+ most-positive-fixnum) 'a))) a) (deftest ccase.9 (classify-error (let (x) (ccase x (nil 'a)))) type-error) (deftest ccase.10 (let (x) (ccase x ((nil) 'a))) a) (deftest ccase.11 (let ((x 'a)) (ccase x (b 0) (a (values 1 2 3)) (c nil))) 1 2 3) (deftest ccase.12 (classify-error (let ((x t)) (ccase x (a 10)))) type-error) (deftest ccase.13 (let ((x t)) (ccase x ((t) 10) (t 20))) 10) (deftest ccase.14 (let ((x (list 'a 'b))) (eval `(let ((y (quote ,x))) (ccase y ((,x) 1) (a 2))))) 1) (deftest ccase.15 (classify-error (let ((x 'otherwise)) (ccase x ((t) 10)))) type-error) (deftest ccase.16 (classify-error (let ((x t)) (ccase x ((otherwise) 10)))) type-error) (deftest ccase.17 (classify-error (let ((x 'a)) (ccase x (b 0) (c 1) (otherwise 2)))) type-error) (deftest ccase.19 (classify-error (let ((x 'a)) (ccase x (b 0) (c 1) ((t) 2)))) type-error) (deftest ccase.20 (let ((x #\a)) (ccase x ((#\b #\c) 10) ((#\d #\e #\A) 20) (() 30) ((#\z #\a #\y) 40))) 40) (deftest ccase.21 (let ((x 1)) (ccase x (1 (values)) (2 'a)))) (deftest ccase.23 (let ((x 1)) (ccase x (1 (values 'a 'b 'c)))) a b c) ;;; Show that the key expression is evaluated only once. (deftest ccase.25 (let ((a (vector 'a 'b 'c 'd 'e)) (i 1)) (values (ccase (aref a (incf i)) (a 1) (b 2) (c 3) (d 4)) i)) 3 2) ;;; Repeated keys are allowed (all but the first are ignored) (deftest ccase.26 (let ((x 'b)) (ccase x ((a b c) 10) (b 20))) 10) (deftest ccase.27 (let ((x 'b)) (ccase x (b 20) ((a b c) 10))) 20) (deftest ccase.28 (let ((x 'b)) (ccase x (b 20) (b 10) (d 0))) 20) ;;; There are implicit progns (deftest ccase.29 (let ((x nil) (y 2)) (values (ccase y (1 (setq x 'a) 'w) (2 (setq x 'b) 'y) (3 (setq x 'c) 'z)) x)) y b) (deftest ccase.30 (let ((x 'a)) (ccase x (a))) nil) (deftest ccase.31 (handler-bind ((type-error #'(lambda (c) (store-value 7 c)))) (let ((x 0)) (ccase x (1 :bad) (7 :good) (2 nil)))) :good) ;;; (deftest ccase.error.1 ;;; (classify-error (ccase)) ;;; program-error) gcl/ansi-tests/cell-error-name.lsp000066400000000000000000000022671242227143400174310ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 27 22:36:48 2003 ;;;; Contains: Tests of CELL-ERROR-NAME (in-package :cl-test) (deftest cell-error-name.1 (handler-case (eval 'my-unbound-variable) (cell-error (c) (cell-error-name c))) my-unbound-variable) (deftest cell-error-name.2 (handler-case (eval '(my-undefined-function)) ;; (warning (c) (muffle-warning c)) (cell-error (c) (cell-error-name c))) my-undefined-function) (deftest cell-error-name.3 (cell-error-name (make-condition 'unbound-variable :name 'x)) x) (deftest cell-error-name.4 (cell-error-name (make-condition 'undefined-function :name 'f)) f) (deftest cell-error-name.5 (cell-error-name (make-condition 'unbound-slot :name 's)) s) (deftest cell-error-name.6 (let ((i 0)) (values (cell-error-name (progn (incf i) (make-condition 'unbound-slot :name 's))) i)) s 1) ;;; Need test raising condition unbound-slot (deftest cell-error-name.error.1 (classify-error (cell-error-name)) program-error) (deftest cell-error-name.error.2 (classify-error (cell-error-name (make-condition 'unbound-variable :name 'foo) nil)) program-error) gcl/ansi-tests/cerror.lsp000066400000000000000000000024041242227143400157320ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 19:45:27 2003 ;;;; Contains: Tests of CERROR (in-package :cl-test) (deftest cerror.1 (let ((fmt "Cerror")) (handler-case (cerror "Keep going." fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest cerror.2 (let* ((fmt "Cerror") (cnd (make-condition 'simple-error :format-control fmt))) (handler-case (cerror "Continue on." cnd) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest cerror.3 (let ((fmt "Cerror")) (handler-case (cerror "Continue" 'simple-error :format-control fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest cerror.4 (let ((fmt "Cerror: ~A")) (handler-case (cerror "On on" fmt 10) (simple-error (c) (frob-simple-error c fmt 10)))) t) (deftest cerror.5 (let ((fmt (formatter "Cerror"))) (handler-case (cerror "Keep going." fmt) (simple-error (c) (frob-simple-error c fmt)))) t) ;;; Continuing from a cerror (deftest cerror.6 (handler-bind ((simple-error #'(lambda (c) (continue c)))) (progn (cerror "Wooo" 'simple-error) 10)) 10) (deftest cerror.error.1 (classify-error (cerror)) program-error) (deftest cerror.error.2 (classify-error (cerror "foo")) program-error) gcl/ansi-tests/char-aux.lsp000066400000000000000000000177361242227143400161640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 5 20:15:55 2002 ;;;; Contains: Auxiliary functions for character tests (in-package :cl-test) (defun is-ordered-by (seq fn) (let ((n (length seq))) (loop for i from 0 below (1- n) for e = (elt seq i) always (loop for j from (1+ i) below n always (funcall fn e (elt seq j)))))) (defun is-antisymmetrically-ordered-by (seq fn) (and (is-ordered-by seq fn) (is-ordered-by (reverse seq) (complement fn)))) (defun is-case-insensitive (fn) (loop for c across +code-chars+ for c1 = (char-upcase c) for c2 = (if (eql c c1) (char-downcase c) c1) always (loop for d across +code-chars+ for d1 = (char-upcase d) for d2 = (if (eql d d1) (char-downcase d) d1) always (equiv (funcall fn c d) (funcall fn c2 d) (funcall fn c d2) (funcall fn c2 d2))))) (defun equiv (&rest args) (declare (dynamic-extent args)) (cond ((null args) t) ((car args) (loop for e in (cdr args) always e)) (t (loop for e in (cdr args) never e)))) ;;; From character.lsp (defun char-type-error-check (fn) (loop for x in *universe* always (or (characterp x) (eqt (catch-type-error (funcall fn x)) 'type-error)))) (defun standard-char.5.body () (loop for i from 0 below (min 65536 char-code-limit) always (let ((c (code-char i))) (not (and (typep c 'standard-char) (not (standard-char-p c))))))) (defun extended-char.3.body () (loop for i from 0 below (min 65536 char-code-limit) always (let ((c (code-char i))) (not (and (typep c 'extended-char) (typep c 'base-char)))))) (defun character.1.body () (loop for i from 0 below (min 65536 char-code-limit) always (let ((c (code-char i))) (or (null c) (let ((s (string c))) (and (eqlt (character c) c) (eqlt (character s) c) (eqlt (character (make-symbol s)) c))))))) (defun character.2.body () (loop for x in *universe* when (not (or (characterp x) (and (stringp x) (eqlt (length x) 1)) (and (symbolp x) (eqlt (length (symbol-name x)) 1)) (let ((c (catch-type-error (character x)))) (or (eqlt c 'type-error) (let ((s (catch-type-error (string x)))) (and (stringp s) (eqlt (char s 0) c))))))) do (return x))) (defun characterp.2.body () (loop for i from 0 below (min 65536 char-code-limit) always (let ((c (code-char i))) (or (null c) (characterp c))))) (defun characterp.3.body () (loop for x in *universe* always (let ((p (characterp x)) (q (typep x 'character))) (if p (notnot q) (not q))))) (defun alphanumericp.4.body () (loop for x in *universe* always (or (not (characterp x)) (if (or (digit-char-p x) (alpha-char-p x)) (alphanumericp x) ;; The hyperspec has an example that claims alphanumeric == ;; digit-char-p or alpha-char-p, but the text seems to suggest ;; that there can be numeric characters for which digit-char-p ;; returns NIL. Therefore, I've weakened the next line ;; (not (alphanumericp x)) t )))) (defun alphanumericp.5.body () (loop for i from 0 below (min 65536 char-code-limit) for x = (code-char i) always (or (not (characterp x)) (if (or (digit-char-p x) (alpha-char-p x)) (alphanumericp x) ;; The hyperspec has an example that claims alphanumeric == ;; digit-char-p or alpha-char-p, but the text seems to suggest ;; that there can be numeric characters for which digit-char-p ;; returns NIL. Therefore, I've weakened the next line ;; (not (alphanumericp x)) t )))) (defun digit-char.1.body () (loop for r from 2 to 36 always (loop for i from 0 to 36 always (let ((c (digit-char i r))) (if (>= i r) (null c) (eqlt c (char +extended-digit-chars+ i))))))) (defun digit-char-p.1.body () (loop for x in *universe* always (not (and (characterp x) (not (alphanumericp x)) (digit-char-p x))))) (defun digit-char-p.2.body () (loop for i from 0 below (min 65536 char-code-limit) for x = (code-char i) always (or (not x) (not (and (not (alphanumericp x)) (digit-char-p x)))))) (defun digit-char-p.3.body () (loop for r from 2 to 35 always (loop for i from r to 35 for c = (char +extended-digit-chars+ i) never (or (digit-char-p c r) (digit-char-p (char-downcase c) r))))) (defun digit-char-p.4.body () (loop for r from 2 to 35 always (loop for i from 0 below r for c = (char +extended-digit-chars+ i) always (and (eqlt (digit-char-p c r) i) (eqlt (digit-char-p (char-downcase c) r) i))))) (defun standard-char-p.2.body () (loop for x in *universe* always (or (not (characterp x)) (find x +standard-chars+) (not (standard-char-p x))))) (defun standard-char-p.2a.body () (loop for i from 0 below (min 65536 char-code-limit) for x = (code-char i) always (or (not (characterp x)) (find x +standard-chars+) (not (standard-char-p x))))) (defun char-upcase.1.body () (loop for x in *universe* always (or (not (characterp x)) (let ((u (char-upcase x))) (and (or (lower-case-p x) (eqlt u x)) (eqlt u (char-upcase u))))))) (defun char-upcase.2.body () (loop for i from 0 below (min 65536 char-code-limit) for x = (code-char i) always (or (not x) (let ((u (char-upcase x))) (and (or (lower-case-p x) (eqlt u x)) (eqlt u (char-upcase u))))))) (defun char-downcase.1.body () (loop for x in *universe* always (or (not (characterp x)) (let ((u (char-downcase x))) (and (or (upper-case-p x) (eqlt u x)) (eqlt u (char-downcase u))))))) (defun char-downcase.2.body () (loop for i from 0 below (min 65536 char-code-limit) for x = (code-char i) always (or (not x) (let ((u (char-downcase x))) (and (or (upper-case-p x) (eqlt u x)) (eqlt u (char-downcase u))))))) (defun both-case-p.1.body () (loop for x in *universe* always (or (not (characterp x)) (if (both-case-p x) (and (graphic-char-p x) (or (upper-case-p x) (lower-case-p x))) (not (or (upper-case-p x) (lower-case-p x))))))) (defun both-case-p.2.body () (loop for i from 0 below (min 65536 char-code-limit) for x = (code-char i) always (or (not (characterp x)) (if (both-case-p x) (and (graphic-char-p x) (or (upper-case-p x) (lower-case-p x))) (not (or (upper-case-p x) (lower-case-p x))))))) (defun char-code.2.body () (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i) always (or (not c) (eqlt (char-code c) i)))) (defun char-int.2.fn () (declare (optimize (safety 3) (speed 1) (space 1))) (let ((c->i (make-hash-table :test #'equal)) (i->c (make-hash-table :test #'eql))) (flet ((%insert (c) (or (not (characterp c)) (let* ((i (char-int c)) (j (gethash c c->i)) (d (gethash i i->c))) (and (or (null j) (eqlt j i)) (or (null d) (char= c d)) (progn (setf (gethash c c->i) i) (setf (gethash i i->c) c) t)))))) (and (loop for i from 0 below char-code-limit always (%insert (code-char i))) (every #'%insert +standard-chars+) (every #'%insert *universe*) t)))) (defun char-name.1.fn () (declare (optimize (safety 3) (speed 1) (space 1))) (flet ((%check (c) (or (not (characterp c)) (let ((name (char-name c))) (or (null name) (and (stringp name) (eqlt c (name-char name)))))))) (and (loop for i from 0 below char-code-limit always (%check (code-char i))) (every #'%check +standard-chars+) (every #'%check *universe*) t))) (defun name-char.1.body () (declare (optimize (safety 3))) (loop for x in *universe* for s = (catch-type-error (string x)) always (or (eqlt s 'type-error) (let ((c (name-char x))) (or (not c) (characterp c) (let ((name (char-name c))) (declare (type (or null string) name)) (and name (string-equal name s)))))))) gcl/ansi-tests/char-compare.lsp000066400000000000000000000366071242227143400170130ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 5 19:36:00 2002 ;;;; Contains: Tests of character comparison functions (in-package :cl-test) ;;; The character comparisons should throw a PROGRAM-ERROR when ;;; safe-called with no arguments (deftest char-compare-no-args (loop for f in '(char= char/= char< char> char<= char>= char-lessp char-greaterp char-equal char-not-lessp char-not-greaterp char-not-equal) collect (eval `(classify-error (funcall ',f)))) (program-error program-error program-error program-error program-error program-error program-error program-error program-error program-error program-error program-error )) (deftest char=.1 (is-ordered-by +code-chars+ #'(lambda (c1 c2) (not (char= c1 c2)))) t) (deftest char=.2 (loop for c across +code-chars+ always (char= c c)) t) (deftest char=.3 (every #'char= +code-chars+) t) (deftest char=.4 (is-ordered-by +rev-code-chars+ #'(lambda (c1 c2) (not (char= c1 c2)))) t) (deftest char=.order.1 (let ((i 0)) (values (not (char= (progn (incf i) #\a))) i)) nil 1) (deftest char=.order.2 (let ((i 0) a b) (values (char= (progn (setf a (incf i)) #\a) (progn (setf b (incf i)) #\b)) i a b)) nil 2 1 2) (deftest char=.order.3 (let ((i 0) a b c) (values (char= (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) ;;; (deftest char/=.1 (is-ordered-by +code-chars+ #'char/=) t) (deftest char/=.2 (loop for c across +code-chars+ never (char/= c c)) t) (deftest char/=.3 (every #'char/= +code-chars+) t) (deftest char/=.4 (is-ordered-by +rev-code-chars+ #'char/=) t) (deftest char/=.order.1 (let ((i 0)) (values (not (char/= (progn (incf i) #\a))) i)) nil 1) (deftest char/=.order.2 (let ((i 0) a b) (values (not (char/= (progn (setf a (incf i)) #\a) (progn (setf b (incf i)) #\b))) i a b)) nil 2 1 2) (deftest char/=.order.3 (let ((i 0) a b c) (values (char/= (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) ;;; (deftest char<=.1 (loop for c across +code-chars+ always (char<= c c)) t) (deftest char<=.2 (every #'char<= +code-chars+) t) (deftest char<=.3 (is-antisymmetrically-ordered-by +code-chars+ #'char<=) t) (deftest char<=.4 (is-antisymmetrically-ordered-by +lower-case-chars+ #'char<=) t) (deftest char<=.5 (is-antisymmetrically-ordered-by +upper-case-chars+ #'char<=) t) (deftest char<=.6 (is-antisymmetrically-ordered-by +digit-chars+ #'char<=) t) (deftest char<=.7 (notnot-mv (or (char<= #\9 #\A) (char<= #\Z #\0))) t) (deftest char<=.8 (notnot-mv (or (char<= #\9 #\a) (char<= #\z #\0))) t) (deftest char<=.order.1 (let ((i 0)) (values (not (char<= (progn (incf i) #\a))) i)) nil 1) (deftest char<=.order.2 (let ((i 0) a b) (values (not (char<= (progn (setf a (incf i)) #\a) (progn (setf b (incf i)) #\b))) i a b)) nil 2 1 2) (deftest char<=.order.3 (let ((i 0) a b c) (values (char<= (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) ;;; (deftest char<.1 (loop for c across +code-chars+ never (char< c c)) t) (deftest char<.2 (every #'char< +code-chars+) t) (deftest char<.3 (is-antisymmetrically-ordered-by +code-chars+ #'char<) t) (deftest char<.4 (is-antisymmetrically-ordered-by +lower-case-chars+ #'char<) t) (deftest char<.5 (is-antisymmetrically-ordered-by +upper-case-chars+ #'char<) t) (deftest char<.6 (is-antisymmetrically-ordered-by +digit-chars+ #'char<) t) (deftest char<.7 (notnot-mv (or (char< #\9 #\A) (char< #\Z #\0))) t) (deftest char<.8 (notnot-mv (or (char< #\9 #\a) (char< #\z #\0))) t) (deftest char<.order.1 (let ((i 0)) (values (not (char< (progn (incf i) #\a))) i)) nil 1) (deftest char<.order.2 (let ((i 0) a b) (values (not (char< (progn (setf a (incf i)) #\a) (progn (setf b (incf i)) #\b))) i a b)) nil 2 1 2) (deftest char<.order.3 (let ((i 0) a b c) (values (char< (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) (deftest char<.order.4 (let ((i 0) a b c) (values (char< (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) ;;; (deftest char>=.1 (loop for c across +code-chars+ always (char>= c c)) t) (deftest char>=.2 (every #'char>= +code-chars+) t) (deftest char>=.3 (is-antisymmetrically-ordered-by +rev-code-chars+ #'char>=) t) (deftest char>=.4 (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) #'char>=) t) (deftest char>=.5 (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char>=) t) (deftest char>=.6 (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char>=) t) (deftest char>=.7 (notnot-mv (or (char>= #\A #\9) (char>= #\0 #\Z))) t) (deftest char>=.8 (notnot-mv (or (char>= #\a #\9) (char>= #\0 #\z))) t) (deftest char>=.order.1 (let ((i 0)) (values (not (char>= (progn (incf i) #\a))) i)) nil 1) (deftest char>=.order.2 (let ((i 0) a b) (values (not (char>= (progn (setf a (incf i)) #\b) (progn (setf b (incf i)) #\a))) i a b)) nil 2 1 2) (deftest char>=.order.3 (let ((i 0) a b c) (values (char>= (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) (deftest char>=.order.4 (let ((i 0) a b c) (values (char>= (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) ;;; (deftest char>.1 (loop for c across +code-chars+ never (char> c c)) t) (deftest char>.2 (every #'char> +code-chars+) t) (deftest char>.3 (is-antisymmetrically-ordered-by +rev-code-chars+ #'char>) t) (deftest char>.4 (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) #'char>) t) (deftest char>.5 (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char>) t) (deftest char>.6 (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char>) t) (deftest char>.7 (notnot-mv (or (char> #\A #\9) (char> #\0 #\Z))) t) (deftest char>.8 (notnot-mv (or (char> #\a #\9) (char> #\0 #\z))) t) (deftest char>.order.1 (let ((i 0)) (values (not (char> (progn (incf i) #\a))) i)) nil 1) (deftest char>.order.2 (let ((i 0) a b) (values (not (char> (progn (setf a (incf i)) #\b) (progn (setf b (incf i)) #\a))) i a b)) nil 2 1 2) (deftest char>.order.3 (let ((i 0) a b c) (values (char> (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) (deftest char>.order.4 (let ((i 0) a b c) (values (char> (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) ;;; Case-insensitive comparisons (deftest char-equal.1 (is-ordered-by +code-chars+ #'(lambda (c1 c2) (or (char= (char-downcase c1) (char-downcase c2)) (not (char-equal c1 c2))))) t) (deftest char-equal.2 (loop for c across +code-chars+ always (char-equal c c)) t) (deftest char-equal.3 (loop for c across +code-chars+ always (char-equal c)) t) (deftest char-equal.4 (is-ordered-by +rev-code-chars+ #'(lambda (c1 c2) (or (char= (char-downcase c1) (char-downcase c2)) (not (char-equal c1 c2))))) t) (deftest char-equal.order.1 (let ((i 0)) (values (not (char-equal (progn (incf i) #\a))) i)) nil 1) (deftest char-equal.order.2 (let ((i 0) a b) (values (char-equal (progn (setf a (incf i)) #\b) (progn (setf b (incf i)) #\a)) i a b)) nil 2 1 2) (deftest char-equal.order.3 (let ((i 0) a b c) (values (char-equal (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) (deftest char-equal.order.4 (let ((i 0) a b c) (values (char-equal (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) ;;; (deftest char-not-equal.1 (is-ordered-by +code-chars+ #'(lambda (c1 c2) (or (char= (char-downcase c1) (char-downcase c2)) (char-not-equal c1 c2)))) t) (deftest char-not-equal.2 (loop for c across +code-chars+ never (char-not-equal c c)) t) (deftest char-not-equal.3 (every #'char-not-equal +code-chars+) t) (deftest char-not-equal.4 (is-ordered-by +rev-code-chars+ #'(lambda (c1 c2) (or (char= (char-downcase c1) (char-downcase c2)) (char-not-equal c1 c2)))) t) (deftest char-not-equal.order.1 (let ((i 0)) (values (not (char-not-equal (progn (incf i) #\a))) i)) nil 1) (deftest char-not-equal.order.2 (let ((i 0) a b) (values (not (char-not-equal (progn (setf a (incf i)) #\b) (progn (setf b (incf i)) #\a))) i a b)) nil 2 1 2) (deftest char-not-equal.order.3 (let ((i 0) a b c) (values (char-not-equal (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) (deftest char-not-equal.order.4 (let ((i 0) a b c) (values (char-not-equal (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) ;;; (deftest char-not-greaterp.1 (loop for c across +code-chars+ always (char-not-greaterp c c)) t) (deftest char-not-greaterp.2 (every #'char-not-greaterp +code-chars+) t) (deftest char-not-greaterp.3 (is-case-insensitive #'char-not-greaterp) t) (deftest char-not-greaterp.4 (is-antisymmetrically-ordered-by +lower-case-chars+ #'char-not-greaterp) t) (deftest char-not-greaterp.5 (is-antisymmetrically-ordered-by +upper-case-chars+ #'char-not-greaterp) t) (deftest char-not-greaterp.6 (is-antisymmetrically-ordered-by +digit-chars+ #'char-not-greaterp) t) (deftest char-not-greaterp.7 (notnot-mv (or (char-not-greaterp #\9 #\A) (char-not-greaterp #\Z #\0))) t) (deftest char-not-greaterp.8 (notnot-mv (or (char-not-greaterp #\9 #\a) (char-not-greaterp #\z #\0))) t) (deftest char-not-greaterp.order.1 (let ((i 0)) (values (not (char-not-greaterp (progn (incf i) #\a))) i)) nil 1) (deftest char-not-greaterp.order.2 (let ((i 0) a b) (values (not (char-not-greaterp (progn (setf a (incf i)) #\a) (progn (setf b (incf i)) #\b))) i a b)) nil 2 1 2) (deftest char-not-greaterp.order.3 (let ((i 0) a b c) (values (char-not-greaterp (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) (deftest char-not-greaterp.order.4 (let ((i 0) a b c) (values (char-not-greaterp (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) ;;; (deftest char-lessp.1 (loop for c across +code-chars+ never (char-lessp c c)) t) (deftest char-lessp.2 (every #'char-lessp +code-chars+) t) (deftest char-lessp.3 (is-case-insensitive #'char-lessp) t) (deftest char-lessp.4 (is-antisymmetrically-ordered-by +lower-case-chars+ #'char-lessp) t) (deftest char-lessp.5 (is-antisymmetrically-ordered-by +upper-case-chars+ #'char-lessp) t) (deftest char-lessp.6 (is-antisymmetrically-ordered-by +digit-chars+ #'char-lessp) t) (deftest char-lessp.7 (notnot-mv (or (char-lessp #\9 #\A) (char-lessp #\Z #\0))) t) (deftest char-lessp.8 (notnot-mv (or (char-lessp #\9 #\a) (char-lessp #\z #\0))) t) (deftest char-lessp.order.1 (let ((i 0)) (values (not (char-lessp (progn (incf i) #\a))) i)) nil 1) (deftest char-lessp.order.2 (let ((i 0) a b) (values (not (char-lessp (progn (setf a (incf i)) #\a) (progn (setf b (incf i)) #\b))) i a b)) nil 2 1 2) (deftest char-lessp.order.3 (let ((i 0) a b c) (values (char-lessp (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) (deftest char-lessp.order.4 (let ((i 0) a b c) (values (char-lessp (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) ;;; (deftest char-not-lessp.1 (loop for c across +code-chars+ always (char-not-lessp c c)) t) (deftest char-not-lessp.2 (every #'char-not-lessp +code-chars+) t) (deftest char-not-lessp.3 (is-case-insensitive #'char-not-lessp) t) (deftest char-not-lessp.4 (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) #'char-not-lessp) t) (deftest char-not-lessp.5 (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char-not-lessp) t) (deftest char-not-lessp.6 (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char-not-lessp) t) (deftest char-not-lessp.7 (notnot-mv (or (char-not-lessp #\A #\9) (char-not-lessp #\0 #\Z))) t) (deftest char-not-lessp.8 (notnot-mv (or (char-not-lessp #\a #\9) (char-not-lessp #\0 #\z))) t) (deftest char-not-lessp.order.1 (let ((i 0)) (values (not (char-not-lessp (progn (incf i) #\a))) i)) nil 1) (deftest char-not-lessp.order.2 (let ((i 0) a b) (values (not (char-not-lessp (progn (setf a (incf i)) #\b) (progn (setf b (incf i)) #\a))) i a b)) nil 2 1 2) (deftest char-not-lessp.order.3 (let ((i 0) a b c) (values (char-not-lessp (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) (deftest char-not-lessp.order.4 (let ((i 0) a b c) (values (char-not-lessp (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) ;;; (deftest char-greaterp.1 (loop for c across +code-chars+ never (char-greaterp c c)) t) (deftest char-greaterp.2 (every #'char-greaterp +code-chars+) t) (deftest char-greaterp.3 (is-case-insensitive #'char-greaterp) t) (deftest char-greaterp.4 (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) #'char-greaterp) t) (deftest char-greaterp.5 (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char-greaterp) t) (deftest char-greaterp.6 (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char-greaterp) t) (deftest char-greaterp.7 (notnot-mv (or (char-greaterp #\A #\9) (char-greaterp #\0 #\Z))) t) (deftest char-greaterp.8 (notnot-mv (or (char-greaterp #\a #\9) (char-greaterp #\0 #\z))) t) (deftest char-greaterp.order.1 (let ((i 0)) (values (not (char-greaterp (progn (incf i) #\a))) i)) nil 1) (deftest char-greaterp.order.2 (let ((i 0) a b) (values (not (char-greaterp (progn (setf a (incf i)) #\b) (progn (setf b (incf i)) #\a))) i a b)) nil 2 1 2) (deftest char-greaterp.order.3 (let ((i 0) a b c) (values (char-greaterp (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) (deftest char-greaterp.order.4 (let ((i 0) a b c) (values (char-greaterp (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) gcl/ansi-tests/char-schar.lsp000066400000000000000000000072321242227143400164550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 29 21:04:44 2002 ;;;; Contains: Tests of CHAR and SCHAR accessors (in-package :cl-test) (deftest char.1 (let ((s "abcd")) (values (char s 0) (char s 1) (char s 2) (char s 3))) #\a #\b #\c #\d) (deftest char.2 (let ((s0 (copy-seq "abcd")) (s1 (copy-seq "abcd")) (s2 (copy-seq "abcd")) (s3 (copy-seq "abcd"))) (setf (char s0 0) #\X) (setf (char s1 1) #\X) (setf (char s2 2) #\X) (setf (char s3 3) #\X) (values s0 s1 s2 s3)) "Xbcd" "aXcd" "abXd" "abcX") (deftest char.3 (let ((s (make-array 6 :element-type 'character :initial-contents '(#\a #\b #\c #\d #\e #\f)))) (setf (char s 3) #\X) s) "abcXef") (deftest char.4 (let ((s (make-array 6 :element-type 'character :initial-contents '(#\a #\b #\c #\d #\e #\f) :fill-pointer 4))) (setf (char s 3) #\X) s) "abcX") (deftest char.5 (let ((s (make-string 5 :initial-element #\a))) (setf (char s 3) #\X) s) "aaaXa") (deftest char.6 (let ((s (make-string 5 :initial-element #\a :element-type 'base-char))) (setf (char s 3) #\X) s) "aaaXa") (deftest char.7 (let ((s (make-string 5 :initial-element #\a :element-type 'character))) (setf (char s 3) #\X) s) "aaaXa") (deftest char.8 (let ((s (make-array 6 :element-type 'character :initial-contents '(#\a #\b #\c #\d #\e #\f) :fill-pointer 4))) (setf (char s 5) #\X) (setf (fill-pointer s) 6) s) "abcdeX") (deftest char.9 (let ((s (make-string 5 :initial-element #\a :element-type 'base-char))) (setf (char s 3) #\X) s) "aaaXa") (deftest char.10 (let ((s (make-string 5 :initial-element #\a :element-type 'standard-char))) (setf (char s 3) #\X) s) "aaaXa") (deftest char.order.1 (let ((i 0) a b) (values (char (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) 1)) i a b)) #\b 2 1 2) (deftest char.order.2 (let ((i 0) a b c (s (make-string 5 :initial-element #\z))) (values (setf (char (progn (setf a (incf i)) s) (progn (setf b (incf i)) 1)) (progn (setf c (incf i)) #\a)) s i a b c)) #\a "zazzz" 3 1 2 3) ;;; Tests of schar (deftest schar.1 (let ((s "abcd")) (values (schar s 0) (schar s 1) (schar s 2) (schar s 3))) #\a #\b #\c #\d) (deftest schar.2 (let ((s0 (copy-seq "abcd")) (s1 (copy-seq "abcd")) (s2 (copy-seq "abcd")) (s3 (copy-seq "abcd"))) (setf (schar s0 0) #\X) (setf (schar s1 1) #\X) (setf (schar s2 2) #\X) (setf (schar s3 3) #\X) (values s0 s1 s2 s3)) "Xbcd" "aXcd" "abXd" "abcX") (deftest schar.3 (let ((s (make-string 6 :initial-element #\x))) (setf (schar s 2) #\X) s) "xxXxxx") (deftest schar.4 (let ((s (make-string 6 :initial-element #\x :element-type 'character))) (setf (schar s 2) #\X) s) "xxXxxx") (deftest schar.5 (let ((s (make-string 6 :initial-element #\x :element-type 'standard-char))) (setf (schar s 2) #\X) s) "xxXxxx") (deftest schar.6 (let ((s (make-string 6 :initial-element #\x :element-type 'base-char))) (setf (schar s 2) #\X) s) "xxXxxx") (deftest schar.7 (let ((s (make-string 6 :initial-element #\x :element-type 'standard-char))) (setf (schar s 2) #\X) s) "xxXxxx") (deftest schar.order.1 (let ((i 0) a b) (values (schar (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) 1)) i a b)) #\b 2 1 2) (deftest schar.order.2 (let ((i 0) a b c (s (copy-seq "zzzzz"))) (values (setf (schar (progn (setf a (incf i)) s) (progn (setf b (incf i)) 1)) (progn (setf c (incf i)) #\a)) s i a b c)) #\a "zazzz" 3 1 2 3) gcl/ansi-tests/character.lsp000066400000000000000000000275441242227143400164060ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 5 12:52:18 2002 ;;;; Contains: Tests associated with the class CHARACTER (in-package :cl-test) (deftest character-class.1 (subtypep* 'character t) t t) (deftest base-char.1 (subtypep* 'base-char 'character) t t) (deftest base-char.2 (subtypep* 'base-char t) t t) (deftest base-char.3 (every #'(lambda (c) (typep c 'base-char)) +standard-chars+) t) (deftest standard-char.1 (subtypep* 'standard-char 'base-char) t t) (deftest standard-char.2 (subtypep* 'standard-char 'character) t t) (deftest standard-char.3 (subtypep* 'standard-char t) t t) (deftest standard-char.4 (every #'(lambda (c) (typep c 'standard-char)) +standard-chars+) t) (deftest standard-char.5 (standard-char.5.body) t) (deftest extended-char.1 (subtypep* 'extended-char 'character) t t) (deftest extended-char.2 (subtypep* 'extended-char t) t t) (deftest extended-char.3 (extended-char.3.body) t) ;;; (deftest character.1 (character.1.body) t) (deftest character.2 (character.2.body) nil) (deftest character.order.1 (let ((i 0)) (values (character (progn (incf i) #\a)) i)) #\a 1) (deftest character.error.1 (classify-error (character)) program-error) (deftest character.error.2 (classify-error (character #\a #\a)) program-error) ;;; (deftest characterp.1 (every #'characterp +standard-chars+) t) (deftest characterp.2 (characterp.2.body) t) (deftest characterp.3 (characterp.3.body) t) (deftest characterp.order.1 (let ((i 0)) (values (characterp (incf i)) i)) nil 1) (deftest characterp.error.1 (classify-error (characterp)) program-error) (deftest characterp.error.2 (classify-error (characterp #\a #\b)) program-error) (deftest alpha-char-p.1 (loop for c across +standard-chars+ always (or (find c +alpha-chars+) (not (alpha-char-p c)))) t) ;;; (deftest alpha-char-p.2 (every #'alpha-char-p +alpha-chars+) t) (deftest alpha-char-p.3 (char-type-error-check #'alpha-char-p) t) (deftest alpha-char-p.order.1 (let ((i 0)) (values (alpha-char-p (progn (incf i) #\8)) i)) nil 1) (deftest alpha-char-p.error.1 (classify-error (alpha-char-p)) program-error) (deftest alpha-char-p.error.2 (classify-error (alpha-char-p #\a #\b)) program-error) ;;; (deftest alphanumericp.1 (loop for c across +standard-chars+ always (or (find c +alphanumeric-chars+) (not (alphanumericp c)))) t) (deftest alphanumericp.2 (every #'alphanumericp +alphanumeric-chars+) t) (deftest alphanumericp.3 (char-type-error-check #'alphanumericp) t) (deftest alphanumericp.4 (alphanumericp.4.body) t) (deftest alphanumericp.5 (alphanumericp.5.body) t) (deftest alphanumericp.order.1 (let ((i 0)) (values (alphanumericp (progn (incf i) #\?)) i)) nil 1) (deftest alphanumericp.error.1 (classify-error (alphanumericp)) program-error) (deftest alphanumericp.error.2 (classify-error (alphanumericp #\a #\b)) program-error) ;;; (deftest digit-char.1 (digit-char.1.body) t) (deftest digit-char.2 (map 'list #'digit-char (loop for i from 0 to 39 collect i)) (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) (deftest digit-char.order.1 (let ((i 0)) (values (digit-char (incf i)) i)) #\1 1) (deftest digit-char.order.2 (let ((i 0) x) (values (digit-char (incf i) (progn (setf x (incf i)) 10)) i x)) #\1 2 2) (deftest digit-char.error.1 (classify-error (digit-char)) program-error) (deftest digit-char.error.2 (classify-error (digit-char 0 10 'foo)) program-error) ;;; (deftest digit-char-p.1 (digit-char-p.1.body) t) (deftest digit-char-p.2 (digit-char-p.2.body) t) (deftest digit-char-p.3 (digit-char-p.3.body) t) (deftest digit-char-p.4 (digit-char-p.4.body) t) (deftest digit-char-p.5 (loop for i from 10 to 35 for c = (char +extended-digit-chars+ i) never (or (digit-char-p c) (digit-char-p (char-downcase c)))) t) (deftest digit-char-p.6 (loop for i from 0 below 10 for c = (char +extended-digit-chars+ i) always (eqlt (digit-char-p c) i)) t) (deftest digit-char-p.order.1 (let ((i 0)) (values (digit-char-p (progn (incf i) #\0)) i)) 0 1) (deftest digit-char-p.order.2 (let ((i 0) x y) (values (digit-char-p (progn (setf x (incf i)) #\0) (progn (setf y (incf i)) 10)) i x y)) 0 2 1 2) (deftest digit-char-p.error.1 (classify-error (digit-char-p)) program-error) (deftest digit-char-p.error.2 (classify-error (digit-char-p #\1 10 'foo)) program-error) ;;; (deftest graphic-char-p.1 (loop for c across +standard-chars+ always (if (eqlt c #\Newline) (not (graphic-char-p c)) (graphic-char-p c))) t) (deftest graphic-char-p.2 (loop for name in '("Rubout" "Page" "Backspace" "Tab" "Linefeed" "Return") for c = (name-char name) when (and c (graphic-char-p c)) collect c) nil) (deftest graphic-char-p.3 (char-type-error-check #'graphic-char-p) t) (deftest graphic-char-p.order.1 (let ((i 0)) (values (not (graphic-char-p (progn (incf i) #\a))) i)) nil 1) (deftest graphic-char-p.error.1 (classify-error (graphic-char-p)) program-error) (deftest graphic-char-p.error.2 (classify-error (graphic-char-p #\a #\a)) program-error) ;;; (deftest standard-char-p.1 (every #'standard-char-p +standard-chars+) t) (deftest standard-char-p.2 (standard-char-p.2.body) t) (deftest standard-char-p.2a (standard-char-p.2a.body) t) (deftest standard-char-p.3 (char-type-error-check #'standard-char-p) t) (deftest standard-char-p.order.1 (let ((i 0)) (values (not (standard-char-p (progn (incf i) #\a))) i)) nil 1) (deftest standard-char-p.error.1 (classify-error (standard-char-p)) program-error) (deftest standard-char-p.error.2 (classify-error (standard-char-p #\a #\a)) program-error) ;;; (deftest char-upcase.1 (char-upcase.1.body) t) (deftest char-upcase.2 (char-upcase.2.body) t) (deftest char-upcase.3 (map 'string #'char-upcase +alpha-chars+) "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ") (deftest char-upcase.4 (char-type-error-check #'char-upcase) t) (deftest char-upcase.order.1 (let ((i 0)) (values (char-upcase (progn (incf i) #\a)) i)) #\A 1) (deftest char-upcase.error.1 (classify-error (char-upcase)) program-error) (deftest char-upcase.error.2 (classify-error (char-upcase #\a #\a)) program-error) ;;; (deftest char-downcase.1 (char-downcase.1.body) t) (deftest char-downcase.2 (char-downcase.2.body) t) (deftest char-downcase.3 (map 'string #'char-downcase +alpha-chars+) "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz") (deftest char-downcase.4 (char-type-error-check #'char-downcase) t) (deftest char-downcase.order.1 (let ((i 0)) (values (char-downcase (progn (incf i) #\A)) i)) #\a 1) (deftest char-downcase.error.1 (classify-error (char-downcase)) program-error) (deftest char-downcase.error.2 (classify-error (char-downcase #\A #\A)) program-error) ;;; (deftest upper-case-p.1 (find-if-not #'upper-case-p +standard-chars+ :start 26 :end 52) nil) (deftest upper-case-p.2 (find-if #'upper-case-p +standard-chars+ :end 26) nil) (deftest upper-case-p.3 (find #'upper-case-p +standard-chars+ :start 52) nil) (deftest upper-case-p.4 (char-type-error-check #'upper-case-p) t) (deftest upper-case-p.order.1 (let ((i 0)) (values (upper-case-p (progn (incf i) #\a)) i)) nil 1) (deftest upper-case-p.error.1 (classify-error (upper-case-p)) program-error) (deftest upper-case-p.error.2 (classify-error (upper-case-p #\a #\A)) program-error) ;;; (deftest lower-case-p.1 (find-if-not #'lower-case-p +standard-chars+ :end 26) nil) (deftest lower-case-p.2 (find-if #'lower-case-p +standard-chars+ :start 26) nil) (deftest lower-case-p.3 (char-type-error-check #'lower-case-p) t) (deftest lower-case-p.order.1 (let ((i 0)) (values (lower-case-p (progn (incf i) #\A)) i)) nil 1) (deftest lower-case-p.error.1 (classify-error (lower-case-p)) program-error) (deftest lower-case-p.error.2 (classify-error (lower-case-p #\a #\a)) program-error) ;;; (deftest both-case-p.1 (both-case-p.1.body) t) (deftest both-case-p.2 (both-case-p.2.body) t) (deftest both-case-p.3 (char-type-error-check #'both-case-p) t) (deftest both-case-p.order.1 (let ((i 0)) (values (both-case-p (progn (incf i) #\5)) i)) nil 1) (deftest both-case-p.error.1 (classify-error (both-case-p)) program-error) (deftest both-case-p.error.2 (classify-error (both-case-p #\a #\a)) program-error) ;;; (deftest char-code.1 (char-type-error-check #'char-code) t) (deftest char-code.2 (char-code.2.body) t) (deftest char-code.order.1 (let ((i 0)) (values (not (numberp (char-code (progn (incf i) #\a)))) i)) nil 1) (deftest char-code.error.1 (classify-error (char-code)) program-error) (deftest char-code.error.2 (classify-error (char-code #\a #\a)) program-error) ;;; (deftest code-char.1 (loop for x across +standard-chars+ always (eqlt (code-char (char-code x)) x)) t) (deftest code-char.order.1 (let ((i 0)) (values (code-char (progn (incf i) (char-code #\a))) i)) #\a 1) (deftest code-char.error.1 (classify-error (code-char)) program-error) (deftest code-char.error.2 (classify-error (code-char 1 1)) program-error) ;;; (deftest char-int.1 (loop for x across +standard-chars+ always (eqlt (char-int x) (char-code x))) t) (deftest char-int.2 (char-int.2.fn) t) (deftest char-int.order.1 (let ((i 0)) (values (code-char (char-int (progn (incf i) #\a))) i)) #\a 1) (deftest char-int.error.1 (classify-error (char-int)) program-error) (deftest char-int.error.2 (classify-error (char-int #\a #\a)) program-error) ;;; (deftest char-name.1 (char-name.1.fn) t) (deftest char-name.2 (notnot-mv (string= (char-name #\Space) "Space")) t) (deftest char-name.3 (notnot-mv (string= (char-name #\Newline) "Newline")) t) ;;; Check that the names of various semi-standard characters are ;;; appropriate. This is complicated by the possibility that two different ;;; names may refer to the same character (as is allowed by the standard, ;;; for example in the case of Newline and Linefeed). (deftest char-name.4 (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed") for c = (name-char s) unless (or (not c) ;; If the char-name is not even string-equal, ;; assume we're sharing the character with some other ;; name, and assume it's ok (not (string-equal (char-name c) s)) (string= (char-name c) s)) ;; Collect list of cases that failed collect (list s c (char-name c))) nil) (deftest char-name.5 (char-type-error-check #'char-name) t) (deftest char-name.order.1 (let ((i 0)) (values (char-name (progn (incf i) #\Space)) i)) "Space" 1) (deftest char-name.error.1 (classify-error (char-name)) program-error) (deftest char-name.error.2 (classify-error (char-name #\a #\a)) program-error) ;;; (deftest name-char.1 (name-char.1.body) t) (deftest name-char.2 (loop for s in '("RubOut" "PAGe" "BacKspace" "RetUrn" "Tab" "LineFeed" "SpaCE" "NewLine") always (let ((c1 (name-char (string-upcase s))) (c2 (name-char (string-downcase s))) (c3 (name-char (string-capitalize s))) (c4 (name-char s))) (and (eqlt c1 c2) (eqlt c2 c3) (eqlt c3 c4)))) t) (deftest name-char.order.1 (let ((i 0)) (values (name-char (progn (incf i) "Space")) i)) #\Space 1) (deftest name-char.error.1 (classify-error (name-char)) program-error) (deftest name-char.error.2 (classify-error (name-char "space" "space")) program-error) gcl/ansi-tests/check-type.lsp000066400000000000000000000021611242227143400164720ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 20:12:04 2003 ;;;; Contains: Tests of CHECK-TYPE (in-package :cl-test) (deftest check-type.1 (let ((x 'a)) (values (check-type x symbol) x)) nil a) (deftest check-type.2 (classify-error (let ((x 'a)) (check-type x integer))) type-error) (deftest check-type.3 (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) (store-value 15 c)))) (values (check-type x number) x))) nil 15) (deftest check-type.4 (let ((x 'a)) (values (check-type x symbol "a symbol") x)) nil a) (deftest check-type.5 (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) (store-value "abc" c)))) (values (check-type x string "a string") x))) nil "abc") (deftest check-type.6 (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) (declare (ignore c)) (store-value 15 nil)))) (values (check-type x number) x))) nil 15) (deftest check-type.7 (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) (declare (ignore c)) (store-value 15)))) (values (check-type x number) x))) nil 15) gcl/ansi-tests/cl-symbol-names.lsp000066400000000000000000001023701242227143400174430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 6 21:49:33 2002 ;;;; Contains: Names of standard CL symbols (in-package :cl-test) ;;; ;;; These are the names of the 978 symbols that can and must be external to ;;; the COMMON-LISP package. ;;; (defparameter *cl-symbol-names* (mapcar #'string '( #:&allow-other-keys #:&aux #:&body #:&environment #:&key #:&optional #:&rest #:&whole #:* #:** #:*** #:*break-on-signals* #:*compile-file-pathname* #:*compile-file-truename* #:*compile-print* #:*compile-verbose* #:*debug-io* #:*debugger-hook* #:*default-pathname-defaults* #:*error-output* #:*features* #:*gensym-counter* #:*load-pathname* #:*load-print* #:*load-truename* #:*load-verbose* #:*macroexpand-hook* #:*modules* #:*package* #:*print-array* #:*print-base* #:*print-case* #:*print-circle* #:*print-escape* #:*print-gensym* #:*print-length* #:*print-level* #:*print-lines* #:*print-miser-width* #:*print-pprint-dispatch* #:*print-pretty* #:*print-radix* #:*print-readably* #:*print-right-margin* #:*query-io* #:*random-state* #:*read-base* #:*read-default-float-format* #:*read-eval* #:*read-suppress* #:*readtable* #:*standard-input* #:*standard-output* #:*terminal-io* #:*trace-output* #:+ #:++ #:+++ #:- #:/ #:// #:/// #:/= #:1+ #:1- #:< #:<= #:= #:> #:>= #:abort #:abs #:acons #:acos #:acosh #:add-method #:adjoin #:adjust-array #:adjustable-array-p #:allocate-instance #:alpha-char-p #:alphanumericp #:and #:append #:apply #:apropos #:apropos-list #:aref #:arithmetic-error #:arithmetic-error-operands #:arithmetic-error-operation #:array #:array-dimension #:array-dimension-limit #:array-dimensions #:array-displacement #:array-element-type #:array-has-fill-pointer-p #:array-in-bounds-p #:array-rank #:array-rank-limit #:array-row-major-index #:array-total-size #:array-total-size-limit #:arrayp #:ash #:asin #:asinh #:assert #:assoc #:assoc-if #:assoc-if-not #:atan #:atanh #:atom #:base-char #:base-string #:bignum #:bit #:bit-and #:bit-andc1 #:bit-andc2 #:bit-eqv #:bit-ior #:bit-nand #:bit-nor #:bit-not #:bit-orc1 #:bit-orc2 #:bit-vector #:bit-vector-p #:bit-xor #:block #:boole #:boole-1 #:boole-2 #:boole-and #:boole-andc1 #:boole-andc2 #:boole-c1 #:boole-c2 #:boole-clr #:boole-eqv #:boole-ior #:boole-nand #:boole-nor #:boole-orc1 #:boole-orc2 #:boole-set #:boole-xor #:boolean #:both-case-p #:boundp #:break #:broadcast-stream #:broadcast-stream-streams #:built-in-class #:butlast #:byte #:byte-position #:byte-size #:caaaar #:caaadr #:caaar #:caadar #:caaddr #:caadr #:caar #:cadaar #:cadadr #:cadar #:caddar #:cadddr #:caddr #:cadr #:call-arguments-limit #:call-method #:call-next-method #:car #:case #:catch #:ccase #:cdaaar #:cdaadr #:cdaar #:cdadar #:cdaddr #:cdadr #:cdar #:cddaar #:cddadr #:cddar #:cdddar #:cddddr #:cdddr #:cddr #:cdr #:ceiling #:cell-error #:cell-error-name #:cerror #:change-class #:char #:char-code #:char-code-limit #:char-downcase #:char-equal #:char-greaterp #:char-int #:char-lessp #:char-name #:char-not-equal #:char-not-greaterp #:char-not-lessp #:char-upcase #:char/= #:char< #:char<= #:char= #:char> #:char>= #:character #:characterp #:check-type #:cis #:class #:class-name #:class-of #:clear-input #:clear-output #:close #:clrhash #:code-char #:coerce #:compilation-speed #:compile #:compile-file #:compile-file-pathname #:compiled-function #:compiled-function-p #:compiler-macro #:compiler-macro-function #:complement #:complex #:complexp #:compute-applicable-methods #:compute-restarts #:concatenate #:concatenated-stream #:concatenated-stream-streams #:cond #:condition #:conjugate #:cons #:consp #:constantly #:constantp #:continue #:control-error #:copy-alist #:copy-list #:copy-pprint-dispatch #:copy-readtable #:copy-seq #:copy-structure #:copy-symbol #:copy-tree #:cos #:cosh #:count #:count-if #:count-if-not #:ctypecase #:debug #:decf #:declaim #:declaration #:declare #:decode-float #:decode-universal-time #:defclass #:defconstant #:defgeneric #:define-compiler-macro #:define-condition #:define-method-combination #:define-modify-macro #:define-setf-expander #:define-symbol-macro #:defmacro #:defmethod #:defpackage #:defparameter #:defsetf #:defstruct #:deftype #:defun #:defvar #:delete #:delete-duplicates #:delete-file #:delete-if #:delete-if-not #:delete-package #:denominator #:deposit-field #:describe #:describe-object #:destructuring-bind #:digit-char #:digit-char-p #:directory #:directory-namestring #:disassemble #:division-by-zero #:do #:do* #:do-all-symbols #:do-external-symbols #:do-symbols #:documentation #:dolist #:dotimes #:double-float #:double-float-epsilon #:double-float-negative-epsilon #:dpb #:dribble #:dynamic-extent #:ecase #:echo-stream #:echo-stream-input-stream #:echo-stream-output-stream #:ed #:eighth #:elt #:encode-universal-time #:end-of-file #:endp #:enough-namestring #:ensure-directories-exist #:ensure-generic-function #:eq #:eql #:equal #:equalp #:error #:etypecase #:eval #:eval-when #:evenp #:every #:exp #:export #:expt #:extended-char #:fboundp #:fceiling #:fdefinition #:ffloor #:fifth #:file-author #:file-error #:file-error-pathname #:file-length #:file-namestring #:file-position #:file-stream #:file-string-length #:file-write-date #:fill #:fill-pointer #:find #:find-all-symbols #:find-class #:find-if #:find-if-not #:find-method #:find-package #:find-restart #:find-symbol #:finish-output #:first #:fixnum #:flet #:float #:float-digits #:float-precision #:float-radix #:float-sign #:floating-point-inexact #:floating-point-invalid-operation #:floating-point-overflow #:floating-point-underflow #:floatp #:floor #:fmakunbound #:force-output #:format #:formatter #:fourth #:fresh-line #:fround #:ftruncate #:ftype #:funcall #:function #:function-keywords #:function-lambda-expression #:functionp #:gcd #:generic-function #:gensym #:gentemp #:get #:get-decoded-time #:get-dispatch-macro-character #:get-internal-real-time #:get-internal-run-time #:get-macro-character #:get-output-stream-string #:get-properties #:get-setf-expansion #:get-universal-time #:getf #:gethash #:go #:graphic-char-p #:handler-bind #:handler-case #:hash-table #:hash-table-count #:hash-table-p #:hash-table-rehash-size #:hash-table-rehash-threshold #:hash-table-size #:hash-table-test #:host-namestring #:identity #:if #:ignorable #:ignore #:ignore-errors #:imagpart #:import #:in-package #:incf #:initialize-instance #:inline #:input-stream-p #:inspect #:integer #:integer-decode-float #:integer-length #:integerp #:interactive-stream-p #:intern #:internal-time-units-per-second #:intersection #:invalid-method-error #:invoke-debugger #:invoke-restart #:invoke-restart-interactively #:isqrt #:keyword #:keywordp #:labels #:lambda #:lambda-list-keywords #:lambda-parameters-limit #:last #:lcm #:ldb #:ldb-test #:ldiff #:least-negative-double-float #:least-negative-long-float #:least-negative-normalized-double-float #:least-negative-normalized-long-float #:least-negative-normalized-short-float #:least-negative-normalized-single-float #:least-negative-short-float #:least-negative-single-float #:least-positive-double-float #:least-positive-long-float #:least-positive-normalized-double-float #:least-positive-normalized-long-float #:least-positive-normalized-short-float #:least-positive-normalized-single-float #:least-positive-short-float #:least-positive-single-float #:length #:let #:let* #:lisp-implementation-type #:lisp-implementation-version #:list #:list* #:list-all-packages #:list-length #:listen #:listp #:load #:load-logical-pathname-translations #:load-time-value #:locally #:log #:logand #:logandc1 #:logandc2 #:logbitp #:logcount #:logeqv #:logical-pathname #:logical-pathname-translations #:logior #:lognand #:lognor #:lognot #:logorc1 #:logorc2 #:logtest #:logxor #:long-float #:long-float-epsilon #:long-float-negative-epsilon #:long-site-name #:loop #:loop-finish #:lower-case-p #:machine-instance #:machine-type #:machine-version #:macro-function #:macroexpand #:macroexpand-1 #:macrolet #:make-array #:make-broadcast-stream #:make-concatenated-stream #:make-condition #:make-dispatch-macro-character #:make-echo-stream #:make-hash-table #:make-instance #:make-instances-obsolete #:make-list #:make-load-form #:make-load-form-saving-slots #:make-method #:make-package #:make-pathname #:make-random-state #:make-sequence #:make-string #:make-string-input-stream #:make-string-output-stream #:make-symbol #:make-synonym-stream #:make-two-way-stream #:makunbound #:map #:map-into #:mapc #:mapcan #:mapcar #:mapcon #:maphash #:mapl #:maplist #:mask-field #:max #:member #:member-if #:member-if-not #:merge #:merge-pathnames #:method #:method-combination #:method-combination-error #:method-qualifiers #:min #:minusp #:mismatch #:mod #:most-negative-double-float #:most-negative-fixnum #:most-negative-long-float #:most-negative-short-float #:most-negative-single-float #:most-positive-double-float #:most-positive-fixnum #:most-positive-long-float #:most-positive-short-float #:most-positive-single-float #:muffle-warning #:multiple-value-bind #:multiple-value-call #:multiple-value-list #:multiple-value-prog1 #:multiple-value-setq #:multiple-values-limit #:name-char #:namestring #:nbutlast #:nconc #:next-method-p #:nil #:nintersection #:ninth #:no-applicable-method #:no-next-method #:not #:notany #:notevery #:notinline #:nreconc #:nreverse #:nset-difference #:nset-exclusive-or #:nstring-capitalize #:nstring-downcase #:nstring-upcase #:nsublis #:nsubst #:nsubst-if #:nsubst-if-not #:nsubstitute #:nsubstitute-if #:nsubstitute-if-not #:nth #:nth-value #:nthcdr #:null #:number #:numberp #:numerator #:nunion #:oddp #:open #:open-stream-p #:optimize #:or #:otherwise #:output-stream-p #:package #:package-error #:package-error-package #:package-name #:package-nicknames #:package-shadowing-symbols #:package-use-list #:package-used-by-list #:packagep #:pairlis #:parse-error #:parse-integer #:parse-namestring #:pathname #:pathname-device #:pathname-directory #:pathname-host #:pathname-match-p #:pathname-name #:pathname-type #:pathname-version #:pathnamep #:peek-char #:phase #:pi #:plusp #:pop #:position #:position-if #:position-if-not #:pprint #:pprint-dispatch #:pprint-exit-if-list-exhausted #:pprint-fill #:pprint-indent #:pprint-linear #:pprint-logical-block #:pprint-newline #:pprint-pop #:pprint-tab #:pprint-tabular #:prin1 #:prin1-to-string #:princ #:princ-to-string #:print #:print-not-readable #:print-not-readable-object #:print-object #:print-unreadable-object #:probe-file #:proclaim #:prog #:prog* #:prog1 #:prog2 #:progn #:program-error #:progv #:provide #:psetf #:psetq #:push #:pushnew #:quote #:random #:random-state #:random-state-p #:rassoc #:rassoc-if #:rassoc-if-not #:ratio #:rational #:rationalize #:rationalp #:read #:read-byte #:read-char #:read-char-no-hang #:read-delimited-list #:read-from-string #:read-line #:read-preserving-whitespace #:read-sequence #:reader-error #:readtable #:readtable-case #:readtablep #:real #:realp #:realpart #:reduce #:reinitialize-instance #:rem #:remf #:remhash #:remove #:remove-duplicates #:remove-if #:remove-if-not #:remove-method #:remprop #:rename-file #:rename-package #:replace #:require #:rest #:restart #:restart-bind #:restart-case #:restart-name #:return #:return-from #:revappend #:reverse #:room #:rotatef #:round #:row-major-aref #:rplaca #:rplacd #:safety #:satisfies #:sbit #:scale-float #:schar #:search #:second #:sequence #:serious-condition #:set #:set-difference #:set-dispatch-macro-character #:set-exclusive-or #:set-macro-character #:set-pprint-dispatch #:set-syntax-from-char #:setf #:setq #:seventh #:shadow #:shadowing-import #:shared-initialize #:shiftf #:short-float #:short-float-epsilon #:short-float-negative-epsilon #:short-site-name #:signal #:signed-byte #:signum #:simple-array #:simple-base-string #:simple-bit-vector #:simple-bit-vector-p #:simple-condition #:simple-condition-format-arguments #:simple-condition-format-control #:simple-error #:simple-string #:simple-string-p #:simple-type-error #:simple-vector #:simple-vector-p #:simple-warning #:sin #:single-float #:single-float-epsilon #:single-float-negative-epsilon #:sinh #:sixth #:sleep #:slot-boundp #:slot-exists-p #:slot-makunbound #:slot-missing #:slot-unbound #:slot-value #:software-type #:software-version #:some #:sort #:space #:special #:special-operator-p #:speed #:sqrt #:stable-sort #:standard #:standard-char #:standard-char-p #:standard-class #:standard-generic-function #:standard-method #:standard-object #:step #:storage-condition #:store-value #:stream #:stream-element-type #:stream-error #:stream-error-stream #:stream-external-format #:streamp #:string #:string-capitalize #:string-downcase #:string-equal #:string-greaterp #:string-left-trim #:string-lessp #:string-not-equal #:string-not-greaterp #:string-not-lessp #:string-right-trim #:string-stream #:string-trim #:string-upcase #:string/= #:string< #:string<= #:string= #:string> #:string>= #:stringp #:structure #:structure-class #:structure-object #:style-warning #:sublis #:subseq #:subsetp #:subst #:subst-if #:subst-if-not #:substitute #:substitute-if #:substitute-if-not #:subtypep #:svref #:sxhash #:symbol #:symbol-function #:symbol-macrolet #:symbol-name #:symbol-package #:symbol-plist #:symbol-value #:symbolp #:synonym-stream #:synonym-stream-symbol #:t #:tagbody #:tailp #:tan #:tanh #:tenth #:terpri #:the #:third #:throw #:time #:trace #:translate-logical-pathname #:translate-pathname #:tree-equal #:truename #:truncate #:two-way-stream #:two-way-stream-input-stream #:two-way-stream-output-stream #:type #:type-error #:type-error-datum #:type-error-expected-type #:type-of #:typecase #:typep #:unbound-slot #:unbound-slot-instance #:unbound-variable #:undefined-function #:unexport #:unintern #:union #:unless #:unread-char #:unsigned-byte #:untrace #:unuse-package #:unwind-protect #:update-instance-for-different-class #:update-instance-for-redefined-class #:upgraded-array-element-type #:upgraded-complex-part-type #:upper-case-p #:use-package #:use-value #:user-homedir-pathname #:values #:values-list #:variable #:vector #:vector-pop #:vector-push #:vector-push-extend #:vectorp #:warn #:warning #:when #:wild-pathname-p #:with-accessors #:with-compilation-unit #:with-condition-restarts #:with-hash-table-iterator #:with-input-from-string #:with-open-file #:with-open-stream #:with-output-to-string #:with-package-iterator #:with-simple-restart #:with-slots #:with-standard-io-syntax #:write #:write-byte #:write-char #:write-line #:write-sequence #:write-string #:write-to-string #:y-or-n-p #:yes-or-no-p #:zerop))) (defparameter *cl-symbols* (let ((pkg (find-package :common-lisp))) (mapcar #'(lambda (str) (intern str pkg)) *cl-symbol-names*))) ;;; Symbols classified by their kind in the spec (defparameter *cl-function-symbols* '( * + - / /= 1+ 1- < <= = > >= abort abs acons acos acosh adjoin adjust-array adjustable-array-p alpha-char-p alphanumericp append apply apropos apropos-list arithmetic-error-operands arithmetic-error-operation array-dimension array-dimensions array-displacement array-element-type array-has-fill-pointer-p array-in-bounds-p array-rank array-row-major-index array-total-size arrayp ash asin asinh assoc-if-not assoc assoc-if atan atanh atom bit-and bit-andc1 bit-andc2 bit-eqv bit-ior bit-nand bit-nor bit-not bit-orc1 bit-orc2 bit-vector-p bit-xor boole both-case-p boundp break broadcast-stream-streams butlast byte byte-position byte-size ceiling cell-error-name cerror char-code char-downcase char-equal char-greaterp char-int char-lessp char-name char-not-equal char-not-greaterp char-not-lessp char-upcase char/= char< char<= char= char> char>= character characterp cis class-of clear-input clear-output close clrhash code-char coerce compile compile-file compile-file-pathname compiled-function-p complement complex complexp compute-restarts concatenate concatenated-stream-streams conjugate cons consp constantly constantp continue copy-alist copy-list copy-pprint-dispatch copy-readtable copy-seq copy-structure copy-symbol copy-tree cos cosh count count-if count-if-not decode-float decode-universal-time delete delete-duplicates delete-file delete-if delete-if-not delete-package denominator deposit-field describe digit-char digit-char-p directory directory-namestring disassemble dpb dribble echo-stream-input-stream echo-stream-output-stream ;;; The function ED is commented out because an implementation ;;; needn't provide this function. ;; ed encode-universal-time endp enough-namestring ensure-directories-exist ensure-generic-function eq eql equal equalp error eval evenp every exp export expt fboundp fceiling ffloor file-author file-error-pathname file-length file-namestring file-position file-write-date find find-all-symbols find-if find-if-not find-package find-restart find-symbol finish-output float float-digits float-precision float-radix float-sign floatp floor fmakunbound force-output format fresh-line fround funcall function-lambda-expression functionp gcd gensym gentemp get-decoded-time get-dispatch-macro-character get-internal-real-time get-internal-run-time get-macro-character get-output-stream-string get-properties get-setf-expansion get-universal-time graphic-char-p hash-table-count hash-table-p hash-table-rehash-size hash-table-rehash-threshold hash-table-size hash-table-test host-namestring identity imagpart import input-stream-p inspect integer-decode-float integer-length integerp interactive-stream-p intern intersection invalid-method-error invoke-debugger invoke-restart invoke-restart-interactively isqrt keywordp last lcm ldb-test ldiff length lisp-implementation-type lisp-implementation-version list list* list-all-packages list-length listen listp load load-logical-pathname-translations log logand logandc1 logandc2 logbitp logcount logeqv logical-pathname logior lognand lognor lognot logorc1 logorc2 logtest logxor long-site-name lower-case-p machine-instance machine-type machine-version macroexpand macroexpand-1 make-array make-broadcast-stream make-concatenated-stream make-condition make-dispatch-macro-character make-echo-stream make-hash-table make-list make-load-form-saving-slots make-package make-pathname make-random-state make-sequence make-string make-string-input-stream make-string-output-stream make-symbol make-synonym-stream make-two-way-stream makunbound map map-into mapc mapcan mapcar mapcon maphash mapl maplist max member member-if member-if-not merge merge-pathnames method-combination-error min minusp mismatch mod muffle-warning name-char namestring nbutlast nconc nintersection not notany notevery nreconc nreverse nset-difference nset-exclusive-or nstring-capitalize nstring-downcase nstring-upcase nsublis nsubst nsubst-if nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not nthcdr null numberp numerator nunion oddp open open-stream-p output-stream-p package-error-package package-name package-nicknames package-shadowing-symbols package-use-list package-used-by-list packagep pairlis parse-integer parse-namestring pathname pathname-device pathname-directory pathname-host pathname-match-p pathname-name pathname-type pathname-version pathnamep peek-char phase plusp position position-if position-if-not pprint pprint-dispatch pprint-fill pprint-indent pprint-linear pprint-newline pprint-tab pprint-tabular prin1 prin1-to-string princ princ-to-string print print-not-readable-object probe-file proclaim provide random-state-p rassoc rassoc-if rassoc-if-not rational rationalize rationalp read read-byte read-char read-char-no-hang read-delimited-list read-from-string read-line read-preserving-whitespace read-sequence readtablep realp realpart reduce rem remhash remove remove-duplicates remove-if remove-if-not remprop rename-file rename-package replace require restart-name revappend reverse room round rplaca rplacd scale-float search set set-difference set-dispatch-macro-character set-exclusive-or set-macro-character set-pprint-dispatch set-syntax-from-char shadow shadowing-import short-site-name signal signum simple-bit-vector-p simple-condition-format-arguments simple-condition-format-control simple-string-p simple-vector-p sin sinh slot-exists-p sleep slot-boundp slot-makunbound slot-value software-type software-version some sort special-operator-p sqrt stable-sort standard-char-p store-value stream-element-type stream-error-stream stream-external-format streamp string string-capitalize string-downcase string-equal string-greaterp string-left-trim string-lessp string-not-equal string-not-greaterp string-not-lessp string-right-trim string-trim string-upcase string/= string< string<= string= string> string>= stringp sublis subsetp subst subst-if subst-if-not substitute substitute-if substitute-if-not subtypep sxhash symbol-name symbol-package symbolp synonym-stream-symbol tailp tan tanh terpri translate-logical-pathname translate-pathname tree-equal truename truncate ftruncate two-way-stream-input-stream two-way-stream-output-stream type-error-datum type-error-expected-type type-of typep unbound-slot-instance unexport unintern union unread-char unuse-package upgraded-array-element-type upgraded-complex-part-type upper-case-p use-package use-value user-homedir-pathname values-list vector vector-pop vector-push vector-push-extend vectorp warn wild-pathname-p write write-byte write-char write-line write-sequence write-string write-to-string y-or-n-p yes-or-no-p zerop )) (defparameter *cl-variable-symbols* '( * ** *** *break-on-signals* *compile-file-pathname* *compile-file-truename* *compile-print* *compile-verbose* *debug-io* *debugger-hook* *default-pathname-defaults* *error-output* *features* *gensym-counter* *load-pathname* *load-print* *load-truename* *load-verbose* *macroexpand-hook* *modules* *package* *print-array* *print-base* *print-case* *print-circle* *print-escape* *print-gensym* *print-length* *print-level* *print-lines* *print-miser-width* *print-pprint-dispatch* *print-pretty* *print-radix* *print-readably* *print-right-margin* *query-io* *random-state* *read-base* *read-default-float-format* *read-eval* *read-suppress* *readtable* *standard-input* *standard-output* *terminal-io* *trace-output* + ++ +++ / // /// - )) (defparameter *cl-constant-symbols* '( array-dimension-limit array-rank-limit array-total-size-limit boole-1 boole-2 boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand boole-nor boole-orc1 boole-orc2 boole-set boole-xor call-arguments-limit char-code-limit double-float-epsilon double-float-negative-epsilon internal-time-units-per-second lambda-list-keywords lambda-parameters-limit least-negative-double-float least-negative-long-float least-negative-normalized-double-float least-negative-normalized-long-float least-negative-normalized-short-float least-negative-normalized-single-float least-negative-short-float least-negative-single-float least-positive-double-float least-positive-long-float least-positive-normalized-double-float least-positive-normalized-long-float least-positive-normalized-short-float least-positive-normalized-single-float least-positive-short-float least-positive-single-float long-float-epsilon long-float-negative-epsilon most-negative-double-float most-negative-fixnum most-negative-long-float most-negative-short-float most-negative-single-float most-positive-double-float most-positive-fixnum most-positive-long-float most-positive-short-float most-positive-single-float multiple-values-limit nil pi short-float-epsilon short-float-negative-epsilon single-float-epsilon single-float-negative-epsilon t )) (defparameter *cl-macro-symbols* '( and assert case ccase ecase check-type cond declaim defclass defconstant defgeneric define-compiler-macro define-condition define-method-combination define-modify-macro define-setf-expander define-symbol-macro defmacro defmethod defpackage defparameter defvar defsetf defstruct deftype defun destructuring-bind do do* do-symbols do-external-symbols do-all-symbols dolist dotimes formatter handler-bind handler-case ignore-errors in-package incf decf lambda loop multiple-value-bind multiple-value-list multiple-value-setq nth-value or pop pprint-logical-block print-unreadable-object prog prog* prog1 prog2 psetq push pushnew remf restart-bind restart-case return rotatef setf psetf shiftf step time trace untrace typecase ctypecase etypecase when unless with-accessors with-compilation-unit with-condition-restarts with-hash-table-iterator with-input-from-string with-open-file with-open-stream with-output-to-string with-package-iterator with-simple-restart with-slots with-standard-io-syntax )) (defparameter *cl-accessor-symbols* '( aref bit caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr car cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr char compiler-macro-function eighth elt fdefinition fifth fill-pointer find-class first fourth get getf gethash ldb logical-pathname-translations macro-function mask-field ninth nth readtable-case rest row-major-aref sbit schar second seventh sixth subseq svref symbol-function symbol-plist symbol-value tenth third values )) (defparameter *cl-condition-type-symbols* '( arithmetic-error cell-error condition control-error division-by-zero end-of-file error file-error floating-point-inexact floating-point-invalid-operation floating-point-overflow floating-point-underflow package-error parse-error print-not-readable program-error reader-error serious-condition simple-condition simple-error simple-type-error simple-warning storage-condition stream-error style-warning type-error unbound-slot unbound-variable undefined-function warning )) (defparameter *cl-class-symbols* '(standard-object structure-object)) (defparameter *cl-declaration-symbols* '( declaration dynamic-extent ftype ignore ignorable inline notinline optimize special type)) (defparameter *cl-local-function-symbols* '(call-next-method next-method-p)) (defparameter *cl-local-macro-symbols* '( call-method make-method loop-finish pprint-exit-if-list-exhausted pprint-pop )) (defparameter *cl-special-operator-symbols* '( block catch eval-when flet function go if labels let let* load-time-value locally macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq symbol-macrolet tagbody the throw unwind-protect )) (defparameter *cl-standard-generic-function-symbols* '( add-method allocate-instance change-class class-name compute-applicable-methods describe-object documentation find-method function-keywords initialize-instance make-instance make-instances-obsolete make-load-form method-qualifiers no-applicable-method no-next-method print-object reinitialize-instance remove-method shared-initialize slot-missing slot-unbound update-instance-for-different-class update-instance-for-redefined-class )) (defparameter *cl-system-class-symbols* '( array bit-vector broadcast-stream built-in-class character class complex concatenated-stream cons echo-stream file-stream float function generic-function hash-table integer list logical-pathname method method-combination null number package pathname random-state ratio rational readtable real restart sequence standard-class standard-generic-function standard-method stream string string-stream structure-class symbol synonym-stream t two-way-stream vector )) (defparameter *cl-type-symbols* '( atom base-char base-string bignum bit boolean compiled-function extended-char fixnum keyword nil short-float single-float double-float long-float signed-byte simple-array simple-base-string simple-bit-vector simple-string simple-vector standard-char unsigned-byte )) (defparameter *cl-type-specifier-symbols* '( and eql member mod not or satisfies values )) (defparameter *cl-restart-symbols* '( abort continue muffle-warning store-value use-value )) ;;; Symbols that are names of types that are also classes ;;; See figure 4-8 in section 4.3.7 (defparameter *cl-types-that-are-classes-symbols* '( arithmetic-error array bit-vector broadcast-stream built-in-class cell-error character class complex concatenated-stream condition cons control-error division-by-zero echo-stream end-of-file error file-error file-stream float floating-point-inexact floating-point-invalid-operation floating-point-overflow floating-point-underflow function generic-function hash-table integer list logical-pathname method method-combination null number package package-error parse-error pathname print-not-readable program-error random-state ratio rational reader-error readtable real restart sequence serious-condition simple-condition simple-error simple-type-error simple-warning standard-class standard-generic-function standard-method standard-object storage-condition stream stream-error string string-stream structure-class structure-object style-warning symbol synonym-stream t two-way-stream type-error unbound-slot unbound-variable undefined-function vector warning )) (defparameter *cl-all-type-symbols* (reduce #'union (list *cl-type-symbols* *cl-types-that-are-classes-symbols* *cl-system-class-symbols* *cl-class-symbols* *cl-condition-type-symbols*))) (defparameter *cl-non-function-macro-special-operator-symbols* (set-difference *cl-symbols* (reduce #'union (list *cl-function-symbols* *cl-macro-symbols* *cl-accessor-symbols* *cl-local-function-symbols* *cl-local-macro-symbols* *cl-special-operator-symbols* *cl-standard-generic-function-symbols* '(declare))))) (defparameter *cl-function-or-accessor-symbols* (append *cl-function-symbols* *cl-accessor-symbols*)) (defparameter *cl-non-variable-constant-symbols* (set-difference *cl-symbols* (union *cl-variable-symbols* *cl-constant-symbols*))) gcl/ansi-tests/cl-symbols-aux.lsp000066400000000000000000000025141242227143400173170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 28 06:43:51 2002 ;;;; Contains: Aux. functions for cl-symbols.lsp (in-package :cl-test) (declaim (optimize (safety 3))) (defun is-external-symbol-of (sym package) (multiple-value-bind (sym2 status) (find-symbol (symbol-name sym) package) (and (eqt sym sym2) (eqt status :external)))) (defun test-if-not-in-cl-package (str) (multiple-value-bind (sym status) (find-symbol #+lower-case str #-lower-case (string-upcase str) 'common-lisp) (or ;; Symbol not present in the common lisp package (not status) ;; Check if it has any properties whose indicators are ;; external in any of the standard packages or are accessible ;; in CL-USER (and (eqt status :external) (let ((plist (symbol-plist sym))) (loop for e = plist then (cddr e) while e for indicator = (car e) when (and (symbolp indicator) (or (is-external-symbol-of indicator "COMMON-LISP") (is-external-symbol-of indicator "KEYWORD") (eqt indicator (find-symbol (symbol-name indicator) "COMMON-LISP-USER")))) collect indicator)))))) (defun safe-symbol-name (sym) (catch-type-error (symbol-name sym))) (defun safe-make-symbol (name) (catch-type-error (make-symbol name))) gcl/ansi-tests/cl-symbols.lsp000066400000000000000000002562211242227143400165320ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 15 13:19:57 1998 ;;;; Contains: Test presence of symbols in the CL package, ;;;; and symbol-related functions (in-package :cl-test) (declaim (optimize (safety 3))) ;;; Test for the presence of every darned symbol ;;; the standard says should be in the CL package. ;;; Also, test that they have no prohibited plist indicators (section 11.1.2.1.1) (deftest symbol-&allow-other-keys (test-if-not-in-cl-package "&allow-other-keys") nil) (deftest symbol-&aux (test-if-not-in-cl-package "&aux") nil) (deftest symbol-&body (test-if-not-in-cl-package "&body") nil) (deftest symbol-&environment (test-if-not-in-cl-package "&environment") nil) (deftest symbol-&key (test-if-not-in-cl-package "&key") nil) (deftest symbol-&optional (test-if-not-in-cl-package "&optional") nil) (deftest symbol-&rest (test-if-not-in-cl-package "&rest") nil) (deftest symbol-&whole (test-if-not-in-cl-package "&whole") nil) (deftest symbol-* (test-if-not-in-cl-package "*") nil) (deftest symbol-** (test-if-not-in-cl-package "**") nil) (deftest symbol-*** (test-if-not-in-cl-package "***") nil) (deftest symbol-*break-on-signals* (test-if-not-in-cl-package "*break-on-signals*") nil) (deftest symbol-*compile-file-pathname* (test-if-not-in-cl-package "*compile-file-pathname*") nil) (deftest symbol-*compile-file-truename* (test-if-not-in-cl-package "*compile-file-truename*") nil) (deftest symbol-*compile-print* (test-if-not-in-cl-package "*compile-print*") nil) (deftest symbol-*compile-verbose* (test-if-not-in-cl-package "*compile-verbose*") nil) (deftest symbol-*debug-io* (test-if-not-in-cl-package "*debug-io*") nil) (deftest symbol-*debugger-hook* (test-if-not-in-cl-package "*debugger-hook*") nil) (deftest symbol-*default-pathname-defaults* (test-if-not-in-cl-package "*default-pathname-defaults*") nil) (deftest symbol-*error-output* (test-if-not-in-cl-package "*error-output*") nil) (deftest symbol-*features* (test-if-not-in-cl-package "*features*") nil) (deftest symbol-*gensym-counter* (test-if-not-in-cl-package "*gensym-counter*") nil) (deftest symbol-*load-pathname* (test-if-not-in-cl-package "*load-pathname*") nil) (deftest symbol-*load-print* (test-if-not-in-cl-package "*load-print*") nil) (deftest symbol-*load-truename* (test-if-not-in-cl-package "*load-truename*") nil) (deftest symbol-*load-verbose* (test-if-not-in-cl-package "*load-verbose*") nil) (deftest symbol-*macroexpand-hook* (test-if-not-in-cl-package "*macroexpand-hook*") nil) (deftest symbol-*modules* (test-if-not-in-cl-package "*modules*") nil) (deftest symbol-*package* (test-if-not-in-cl-package "*package*") nil) (deftest symbol-*print-array* (test-if-not-in-cl-package "*print-array*") nil) (deftest symbol-*print-base* (test-if-not-in-cl-package "*print-base*") nil) (deftest symbol-*print-case* (test-if-not-in-cl-package "*print-case*") nil) (deftest symbol-*print-circle* (test-if-not-in-cl-package "*print-circle*") nil) (deftest symbol-*print-escape* (test-if-not-in-cl-package "*print-escape*") nil) (deftest symbol-*print-gensym* (test-if-not-in-cl-package "*print-gensym*") nil) (deftest symbol-*print-length* (test-if-not-in-cl-package "*print-length*") nil) (deftest symbol-*print-level* (test-if-not-in-cl-package "*print-level*") nil) (deftest symbol-*print-lines* (test-if-not-in-cl-package "*print-lines*") nil) (deftest symbol-*print-miser-width* (test-if-not-in-cl-package "*print-miser-width*") nil) (deftest symbol-*print-pprint-dispatch* (test-if-not-in-cl-package "*print-pprint-dispatch*") nil) (deftest symbol-*print-pretty* (test-if-not-in-cl-package "*print-pretty*") nil) (deftest symbol-*print-radix* (test-if-not-in-cl-package "*print-radix*") nil) (deftest symbol-*print-readably* (test-if-not-in-cl-package "*print-readably*") nil) (deftest symbol-*print-right-margin* (test-if-not-in-cl-package "*print-right-margin*") nil) (deftest symbol-*query-io* (test-if-not-in-cl-package "*query-io*") nil) (deftest symbol-*random-state* (test-if-not-in-cl-package "*random-state*") nil) (deftest symbol-*read-base* (test-if-not-in-cl-package "*read-base*") nil) (deftest symbol-*read-default-float-format* (test-if-not-in-cl-package "*read-default-float-format*") nil) (deftest symbol-*read-eval* (test-if-not-in-cl-package "*read-eval*") nil) (deftest symbol-*read-suppress* (test-if-not-in-cl-package "*read-suppress*") nil) (deftest symbol-*readtable* (test-if-not-in-cl-package "*readtable*") nil) (deftest symbol-*standard-input* (test-if-not-in-cl-package "*standard-input*") nil) (deftest symbol-*standard-output* (test-if-not-in-cl-package "*standard-output*") nil) (deftest symbol-*terminal-io* (test-if-not-in-cl-package "*terminal-io*") nil) (deftest symbol-*trace-output* (test-if-not-in-cl-package "*trace-output*") nil) (deftest symbol-+ (test-if-not-in-cl-package "+") nil) (deftest symbol-++ (test-if-not-in-cl-package "++") nil) (deftest symbol-+++ (test-if-not-in-cl-package "+++") nil) (deftest symbol-- (test-if-not-in-cl-package "-") nil) (deftest symbol-/ (test-if-not-in-cl-package "/") nil) (deftest symbol-// (test-if-not-in-cl-package "//") nil) (deftest symbol-/// (test-if-not-in-cl-package "///") nil) (deftest symbol-/= (test-if-not-in-cl-package "/=") nil) (deftest symbol-1+ (test-if-not-in-cl-package "1+") nil) (deftest symbol-1- (test-if-not-in-cl-package "1-") nil) (deftest symbol-< (test-if-not-in-cl-package "<") nil) (deftest symbol-<= (test-if-not-in-cl-package "<=") nil) (deftest symbol-= (test-if-not-in-cl-package "=") nil) (deftest symbol-> (test-if-not-in-cl-package ">") nil) (deftest symbol->= (test-if-not-in-cl-package ">=") nil) (deftest symbol-abort (test-if-not-in-cl-package "abort") nil) (deftest symbol-abs (test-if-not-in-cl-package "abs") nil) (deftest symbol-acons (test-if-not-in-cl-package "acons") nil) (deftest symbol-acos (test-if-not-in-cl-package "acos") nil) (deftest symbol-acosh (test-if-not-in-cl-package "acosh") nil) (deftest symbol-add-method (test-if-not-in-cl-package "add-method") nil) (deftest symbol-adjoin (test-if-not-in-cl-package "adjoin") nil) (deftest symbol-adjust-array (test-if-not-in-cl-package "adjust-array") nil) (deftest symbol-adjustable-array-p (test-if-not-in-cl-package "adjustable-array-p") nil) (deftest symbol-allocate-instance (test-if-not-in-cl-package "allocate-instance") nil) (deftest symbol-alpha-char-p (test-if-not-in-cl-package "alpha-char-p") nil) (deftest symbol-alphanumericp (test-if-not-in-cl-package "alphanumericp") nil) (deftest symbol-and (test-if-not-in-cl-package "and") nil) (deftest symbol-append (test-if-not-in-cl-package "append") nil) (deftest symbol-apply (test-if-not-in-cl-package "apply") nil) (deftest symbol-apropos (test-if-not-in-cl-package "apropos") nil) (deftest symbol-apropos-list (test-if-not-in-cl-package "apropos-list") nil) (deftest symbol-aref (test-if-not-in-cl-package "aref") nil) (deftest symbol-arithmetic-error (test-if-not-in-cl-package "arithmetic-error") nil) (deftest symbol-arithmetic-error-operands (test-if-not-in-cl-package "arithmetic-error-operands") nil) (deftest symbol-arithmetic-error-operation (test-if-not-in-cl-package "arithmetic-error-operation") nil) (deftest symbol-array (test-if-not-in-cl-package "array") nil) (deftest symbol-array-dimension (test-if-not-in-cl-package "array-dimension") nil) (deftest symbol-array-dimension-limit (test-if-not-in-cl-package "array-dimension-limit") nil) (deftest symbol-array-dimensions (test-if-not-in-cl-package "array-dimensions") nil) (deftest symbol-array-displacement (test-if-not-in-cl-package "array-displacement") nil) (deftest symbol-array-element-type (test-if-not-in-cl-package "array-element-type") nil) (deftest symbol-array-has-fill-pointer-p (test-if-not-in-cl-package "array-has-fill-pointer-p") nil) (deftest symbol-array-in-bounds-p (test-if-not-in-cl-package "array-in-bounds-p") nil) (deftest symbol-array-rank (test-if-not-in-cl-package "array-rank") nil) (deftest symbol-array-rank-limit (test-if-not-in-cl-package "array-rank-limit") nil) (deftest symbol-array-row-major-index (test-if-not-in-cl-package "array-row-major-index") nil) (deftest symbol-array-total-size (test-if-not-in-cl-package "array-total-size") nil) (deftest symbol-array-total-size-limit (test-if-not-in-cl-package "array-total-size-limit") nil) (deftest symbol-arrayp (test-if-not-in-cl-package "arrayp") nil) (deftest symbol-ash (test-if-not-in-cl-package "ash") nil) (deftest symbol-asin (test-if-not-in-cl-package "asin") nil) (deftest symbol-asinh (test-if-not-in-cl-package "asinh") nil) (deftest symbol-assert (test-if-not-in-cl-package "assert") nil) (deftest symbol-assoc (test-if-not-in-cl-package "assoc") nil) (deftest symbol-assoc-if (test-if-not-in-cl-package "assoc-if") nil) (deftest symbol-assoc-if-not (test-if-not-in-cl-package "assoc-if-not") nil) (deftest symbol-atan (test-if-not-in-cl-package "atan") nil) (deftest symbol-atanh (test-if-not-in-cl-package "atanh") nil) (deftest symbol-atom (test-if-not-in-cl-package "atom") nil) (deftest symbol-base-char (test-if-not-in-cl-package "base-char") nil) (deftest symbol-base-string (test-if-not-in-cl-package "base-string") nil) (deftest symbol-bignum (test-if-not-in-cl-package "bignum") nil) (deftest symbol-bit (test-if-not-in-cl-package "bit") nil) (deftest symbol-bit-and (test-if-not-in-cl-package "bit-and") nil) (deftest symbol-bit-andc1 (test-if-not-in-cl-package "bit-andc1") nil) (deftest symbol-bit-andc2 (test-if-not-in-cl-package "bit-andc2") nil) (deftest symbol-bit-eqv (test-if-not-in-cl-package "bit-eqv") nil) (deftest symbol-bit-ior (test-if-not-in-cl-package "bit-ior") nil) (deftest symbol-bit-nand (test-if-not-in-cl-package "bit-nand") nil) (deftest symbol-bit-nor (test-if-not-in-cl-package "bit-nor") nil) (deftest symbol-bit-not (test-if-not-in-cl-package "bit-not") nil) (deftest symbol-bit-orc1 (test-if-not-in-cl-package "bit-orc1") nil) (deftest symbol-bit-orc2 (test-if-not-in-cl-package "bit-orc2") nil) (deftest symbol-bit-vector (test-if-not-in-cl-package "bit-vector") nil) (deftest symbol-bit-vector-p (test-if-not-in-cl-package "bit-vector-p") nil) (deftest symbol-bit-xor (test-if-not-in-cl-package "bit-xor") nil) (deftest symbol-block (test-if-not-in-cl-package "block") nil) (deftest symbol-boole (test-if-not-in-cl-package "boole") nil) (deftest symbol-boole-1 (test-if-not-in-cl-package "boole-1") nil) (deftest symbol-boole-2 (test-if-not-in-cl-package "boole-2") nil) (deftest symbol-boole-and (test-if-not-in-cl-package "boole-and") nil) (deftest symbol-boole-andc1 (test-if-not-in-cl-package "boole-andc1") nil) (deftest symbol-boole-andc2 (test-if-not-in-cl-package "boole-andc2") nil) (deftest symbol-boole-c1 (test-if-not-in-cl-package "boole-c1") nil) (deftest symbol-boole-c2 (test-if-not-in-cl-package "boole-c2") nil) (deftest symbol-boole-clr (test-if-not-in-cl-package "boole-clr") nil) (deftest symbol-boole-eqv (test-if-not-in-cl-package "boole-eqv") nil) (deftest symbol-boole-ior (test-if-not-in-cl-package "boole-ior") nil) (deftest symbol-boole-nand (test-if-not-in-cl-package "boole-nand") nil) (deftest symbol-boole-nor (test-if-not-in-cl-package "boole-nor") nil) (deftest symbol-boole-orc1 (test-if-not-in-cl-package "boole-orc1") nil) (deftest symbol-boole-orc2 (test-if-not-in-cl-package "boole-orc2") nil) (deftest symbol-boole-set (test-if-not-in-cl-package "boole-set") nil) (deftest symbol-boole-xor (test-if-not-in-cl-package "boole-xor") nil) (deftest symbol-boolean (test-if-not-in-cl-package "boolean") nil) (deftest symbol-both-case-p (test-if-not-in-cl-package "both-case-p") nil) (deftest symbol-boundp (test-if-not-in-cl-package "boundp") nil) (deftest symbol-break (test-if-not-in-cl-package "break") nil) (deftest symbol-broadcast-stream (test-if-not-in-cl-package "broadcast-stream") nil) (deftest symbol-broadcast-stream-streams (test-if-not-in-cl-package "broadcast-stream-streams") nil) (deftest symbol-built-in-class (test-if-not-in-cl-package "built-in-class") nil) (deftest symbol-butlast (test-if-not-in-cl-package "butlast") nil) (deftest symbol-byte (test-if-not-in-cl-package "byte") nil) (deftest symbol-byte-position (test-if-not-in-cl-package "byte-position") nil) (deftest symbol-byte-size (test-if-not-in-cl-package "byte-size") nil) (deftest symbol-caaaar (test-if-not-in-cl-package "caaaar") nil) (deftest symbol-caaadr (test-if-not-in-cl-package "caaadr") nil) (deftest symbol-caaar (test-if-not-in-cl-package "caaar") nil) (deftest symbol-caadar (test-if-not-in-cl-package "caadar") nil) (deftest symbol-caaddr (test-if-not-in-cl-package "caaddr") nil) (deftest symbol-caadr (test-if-not-in-cl-package "caadr") nil) (deftest symbol-caar (test-if-not-in-cl-package "caar") nil) (deftest symbol-cadaar (test-if-not-in-cl-package "cadaar") nil) (deftest symbol-cadadr (test-if-not-in-cl-package "cadadr") nil) (deftest symbol-cadar (test-if-not-in-cl-package "cadar") nil) (deftest symbol-caddar (test-if-not-in-cl-package "caddar") nil) (deftest symbol-cadddr (test-if-not-in-cl-package "cadddr") nil) (deftest symbol-caddr (test-if-not-in-cl-package "caddr") nil) (deftest symbol-cadr (test-if-not-in-cl-package "cadr") nil) (deftest symbol-call-arguments-limit (test-if-not-in-cl-package "call-arguments-limit") nil) (deftest symbol-call-method (test-if-not-in-cl-package "call-method") nil) (deftest symbol-call-next-method (test-if-not-in-cl-package "call-next-method") nil) (deftest symbol-car (test-if-not-in-cl-package "car") nil) (deftest symbol-case (test-if-not-in-cl-package "case") nil) (deftest symbol-catch (test-if-not-in-cl-package "catch") nil) (deftest symbol-ccase (test-if-not-in-cl-package "ccase") nil) (deftest symbol-cdaaar (test-if-not-in-cl-package "cdaaar") nil) (deftest symbol-cdaadr (test-if-not-in-cl-package "cdaadr") nil) (deftest symbol-cdaar (test-if-not-in-cl-package "cdaar") nil) (deftest symbol-cdadar (test-if-not-in-cl-package "cdadar") nil) (deftest symbol-cdaddr (test-if-not-in-cl-package "cdaddr") nil) (deftest symbol-cdadr (test-if-not-in-cl-package "cdadr") nil) (deftest symbol-cdar (test-if-not-in-cl-package "cdar") nil) (deftest symbol-cddaar (test-if-not-in-cl-package "cddaar") nil) (deftest symbol-cddadr (test-if-not-in-cl-package "cddadr") nil) (deftest symbol-cddar (test-if-not-in-cl-package "cddar") nil) (deftest symbol-cdddar (test-if-not-in-cl-package "cdddar") nil) (deftest symbol-cddddr (test-if-not-in-cl-package "cddddr") nil) (deftest symbol-cdddr (test-if-not-in-cl-package "cdddr") nil) (deftest symbol-cddr (test-if-not-in-cl-package "cddr") nil) (deftest symbol-cdr (test-if-not-in-cl-package "cdr") nil) (deftest symbol-ceiling (test-if-not-in-cl-package "ceiling") nil) (deftest symbol-cell-error (test-if-not-in-cl-package "cell-error") nil) (deftest symbol-cell-error-name (test-if-not-in-cl-package "cell-error-name") nil) (deftest symbol-cerror (test-if-not-in-cl-package "cerror") nil) (deftest symbol-change-class (test-if-not-in-cl-package "change-class") nil) (deftest symbol-char (test-if-not-in-cl-package "char") nil) (deftest symbol-char-code (test-if-not-in-cl-package "char-code") nil) (deftest symbol-char-code-limit (test-if-not-in-cl-package "char-code-limit") nil) (deftest symbol-char-downcase (test-if-not-in-cl-package "char-downcase") nil) (deftest symbol-char-equal (test-if-not-in-cl-package "char-equal") nil) (deftest symbol-char-greaterp (test-if-not-in-cl-package "char-greaterp") nil) (deftest symbol-char-int (test-if-not-in-cl-package "char-int") nil) (deftest symbol-char-lessp (test-if-not-in-cl-package "char-lessp") nil) (deftest symbol-char-name (test-if-not-in-cl-package "char-name") nil) (deftest symbol-char-not-equal (test-if-not-in-cl-package "char-not-equal") nil) (deftest symbol-char-not-greaterp (test-if-not-in-cl-package "char-not-greaterp") nil) (deftest symbol-char-not-lessp (test-if-not-in-cl-package "char-not-lessp") nil) (deftest symbol-char-upcase (test-if-not-in-cl-package "char-upcase") nil) (deftest symbol-char/= (test-if-not-in-cl-package "char/=") nil) (deftest symbol-char< (test-if-not-in-cl-package "char<") nil) (deftest symbol-char<= (test-if-not-in-cl-package "char<=") nil) (deftest symbol-char= (test-if-not-in-cl-package "char=") nil) (deftest symbol-char> (test-if-not-in-cl-package "char>") nil) (deftest symbol-char>= (test-if-not-in-cl-package "char>=") nil) (deftest symbol-character (test-if-not-in-cl-package "character") nil) (deftest symbol-characterp (test-if-not-in-cl-package "characterp") nil) (deftest symbol-check-type (test-if-not-in-cl-package "check-type") nil) (deftest symbol-cis (test-if-not-in-cl-package "cis") nil) (deftest symbol-class (test-if-not-in-cl-package "class") nil) (deftest symbol-class-name (test-if-not-in-cl-package "class-name") nil) (deftest symbol-class-of (test-if-not-in-cl-package "class-of") nil) (deftest symbol-clear-input (test-if-not-in-cl-package "clear-input") nil) (deftest symbol-clear-output (test-if-not-in-cl-package "clear-output") nil) (deftest symbol-close (test-if-not-in-cl-package "close") nil) (deftest symbol-clrhash (test-if-not-in-cl-package "clrhash") nil) (deftest symbol-code-char (test-if-not-in-cl-package "code-char") nil) (deftest symbol-coerce (test-if-not-in-cl-package "coerce") nil) (deftest symbol-compilation-speed (test-if-not-in-cl-package "compilation-speed") nil) (deftest symbol-compile (test-if-not-in-cl-package "compile") nil) (deftest symbol-compile-file (test-if-not-in-cl-package "compile-file") nil) (deftest symbol-compile-file-pathname (test-if-not-in-cl-package "compile-file-pathname") nil) (deftest symbol-compiled-function (test-if-not-in-cl-package "compiled-function") nil) (deftest symbol-compiled-function-p (test-if-not-in-cl-package "compiled-function-p") nil) (deftest symbol-compiler-macro (test-if-not-in-cl-package "compiler-macro") nil) (deftest symbol-compiler-macro-function (test-if-not-in-cl-package "compiler-macro-function") nil) (deftest symbol-complement (test-if-not-in-cl-package "complement") nil) (deftest symbol-complex (test-if-not-in-cl-package "complex") nil) (deftest symbol-complexp (test-if-not-in-cl-package "complexp") nil) (deftest symbol-compute-applicable-methods (test-if-not-in-cl-package "compute-applicable-methods") nil) (deftest symbol-compute-restarts (test-if-not-in-cl-package "compute-restarts") nil) (deftest symbol-concatenate (test-if-not-in-cl-package "concatenate") nil) (deftest symbol-concatenated-stream (test-if-not-in-cl-package "concatenated-stream") nil) (deftest symbol-concatenated-stream-streams (test-if-not-in-cl-package "concatenated-stream-streams") nil) (deftest symbol-cond (test-if-not-in-cl-package "cond") nil) (deftest symbol-condition (test-if-not-in-cl-package "condition") nil) (deftest symbol-conjugate (test-if-not-in-cl-package "conjugate") nil) (deftest symbol-cons (test-if-not-in-cl-package "cons") nil) (deftest symbol-consp (test-if-not-in-cl-package "consp") nil) (deftest symbol-constantly (test-if-not-in-cl-package "constantly") nil) (deftest symbol-constantp (test-if-not-in-cl-package "constantp") nil) (deftest symbol-continue (test-if-not-in-cl-package "continue") nil) (deftest symbol-control-error (test-if-not-in-cl-package "control-error") nil) (deftest symbol-copy-alist (test-if-not-in-cl-package "copy-alist") nil) (deftest symbol-copy-list (test-if-not-in-cl-package "copy-list") nil) (deftest symbol-copy-pprint-dispatch (test-if-not-in-cl-package "copy-pprint-dispatch") nil) (deftest symbol-copy-readtable (test-if-not-in-cl-package "copy-readtable") nil) (deftest symbol-copy-seq (test-if-not-in-cl-package "copy-seq") nil) (deftest symbol-copy-structure (test-if-not-in-cl-package "copy-structure") nil) (deftest symbol-copy-symbol (test-if-not-in-cl-package "copy-symbol") nil) (deftest symbol-copy-tree (test-if-not-in-cl-package "copy-tree") nil) (deftest symbol-cos (test-if-not-in-cl-package "cos") nil) (deftest symbol-cosh (test-if-not-in-cl-package "cosh") nil) (deftest symbol-count (test-if-not-in-cl-package "count") nil) (deftest symbol-count-if (test-if-not-in-cl-package "count-if") nil) (deftest symbol-count-if-not (test-if-not-in-cl-package "count-if-not") nil) (deftest symbol-ctypecase (test-if-not-in-cl-package "ctypecase") nil) (deftest symbol-debug (test-if-not-in-cl-package "debug") nil) (deftest symbol-decf (test-if-not-in-cl-package "decf") nil) (deftest symbol-declaim (test-if-not-in-cl-package "declaim") nil) (deftest symbol-declaration (test-if-not-in-cl-package "declaration") nil) (deftest symbol-declare (test-if-not-in-cl-package "declare") nil) (deftest symbol-decode-float (test-if-not-in-cl-package "decode-float") nil) (deftest symbol-decode-universal-time (test-if-not-in-cl-package "decode-universal-time") nil) (deftest symbol-defclass (test-if-not-in-cl-package "defclass") nil) (deftest symbol-defconstant (test-if-not-in-cl-package "defconstant") nil) (deftest symbol-defgeneric (test-if-not-in-cl-package "defgeneric") nil) (deftest symbol-define-compiler-macro (test-if-not-in-cl-package "define-compiler-macro") nil) (deftest symbol-define-condition (test-if-not-in-cl-package "define-condition") nil) (deftest symbol-define-method-combination (test-if-not-in-cl-package "define-method-combination") nil) (deftest symbol-define-modify-macro (test-if-not-in-cl-package "define-modify-macro") nil) (deftest symbol-define-setf-expander (test-if-not-in-cl-package "define-setf-expander") nil) (deftest symbol-define-symbol-macro (test-if-not-in-cl-package "define-symbol-macro") nil) (deftest symbol-defmacro (test-if-not-in-cl-package "defmacro") nil) (deftest symbol-defmethod (test-if-not-in-cl-package "defmethod") nil) (deftest symbol-defpackage (test-if-not-in-cl-package "defpackage") nil) (deftest symbol-defparameter (test-if-not-in-cl-package "defparameter") nil) (deftest symbol-defsetf (test-if-not-in-cl-package "defsetf") nil) (deftest symbol-defstruct (test-if-not-in-cl-package "defstruct") nil) (deftest symbol-deftype (test-if-not-in-cl-package "deftype") nil) (deftest symbol-defun (test-if-not-in-cl-package "defun") nil) (deftest symbol-defvar (test-if-not-in-cl-package "defvar") nil) (deftest symbol-delete (test-if-not-in-cl-package "delete") nil) (deftest symbol-delete-duplicates (test-if-not-in-cl-package "delete-duplicates") nil) (deftest symbol-delete-file (test-if-not-in-cl-package "delete-file") nil) (deftest symbol-delete-if (test-if-not-in-cl-package "delete-if") nil) (deftest symbol-delete-if-not (test-if-not-in-cl-package "delete-if-not") nil) (deftest symbol-delete-package (test-if-not-in-cl-package "delete-package") nil) (deftest symbol-denominator (test-if-not-in-cl-package "denominator") nil) (deftest symbol-deposit-field (test-if-not-in-cl-package "deposit-field") nil) (deftest symbol-describe (test-if-not-in-cl-package "describe") nil) (deftest symbol-describe-object (test-if-not-in-cl-package "describe-object") nil) (deftest symbol-destructuring-bind (test-if-not-in-cl-package "destructuring-bind") nil) (deftest symbol-digit-char (test-if-not-in-cl-package "digit-char") nil) (deftest symbol-digit-char-p (test-if-not-in-cl-package "digit-char-p") nil) (deftest symbol-directory (test-if-not-in-cl-package "directory") nil) (deftest symbol-directory-namestring (test-if-not-in-cl-package "directory-namestring") nil) (deftest symbol-disassemble (test-if-not-in-cl-package "disassemble") nil) (deftest symbol-division-by-zero (test-if-not-in-cl-package "division-by-zero") nil) (deftest symbol-do (test-if-not-in-cl-package "do") nil) (deftest symbol-do* (test-if-not-in-cl-package "do*") nil) (deftest symbol-do-all-symbols (test-if-not-in-cl-package "do-all-symbols") nil) (deftest symbol-do-external-symbols (test-if-not-in-cl-package "do-external-symbols") nil) (deftest symbol-do-symbols (test-if-not-in-cl-package "do-symbols") nil) (deftest symbol-documentation (test-if-not-in-cl-package "documentation") nil) (deftest symbol-dolist (test-if-not-in-cl-package "dolist") nil) (deftest symbol-dotimes (test-if-not-in-cl-package "dotimes") nil) (deftest symbol-double-float (test-if-not-in-cl-package "double-float") nil) (deftest symbol-double-float-epsilon (test-if-not-in-cl-package "double-float-epsilon") nil) (deftest symbol-double-float-negative-epsilon (test-if-not-in-cl-package "double-float-negative-epsilon") nil) (deftest symbol-dpb (test-if-not-in-cl-package "dpb") nil) (deftest symbol-dribble (test-if-not-in-cl-package "dribble") nil) (deftest symbol-dynamic-extent (test-if-not-in-cl-package "dynamic-extent") nil) (deftest symbol-ecase (test-if-not-in-cl-package "ecase") nil) (deftest symbol-echo-stream (test-if-not-in-cl-package "echo-stream") nil) (deftest symbol-echo-stream-input-stream (test-if-not-in-cl-package "echo-stream-input-stream") nil) (deftest symbol-echo-stream-output-stream (test-if-not-in-cl-package "echo-stream-output-stream") nil) (deftest symbol-ed (test-if-not-in-cl-package "ed") nil) (deftest symbol-eighth (test-if-not-in-cl-package "eighth") nil) (deftest symbol-elt (test-if-not-in-cl-package "elt") nil) (deftest symbol-encode-universal-time (test-if-not-in-cl-package "encode-universal-time") nil) (deftest symbol-end-of-file (test-if-not-in-cl-package "end-of-file") nil) (deftest symbol-endp (test-if-not-in-cl-package "endp") nil) (deftest symbol-enough-namestring (test-if-not-in-cl-package "enough-namestring") nil) (deftest symbol-ensure-directories-exist (test-if-not-in-cl-package "ensure-directories-exist") nil) (deftest symbol-ensure-generic-function (test-if-not-in-cl-package "ensure-generic-function") nil) (deftest symbol-eq (test-if-not-in-cl-package "eq") nil) (deftest symbol-eql (test-if-not-in-cl-package "eql") nil) (deftest symbol-equal (test-if-not-in-cl-package "equal") nil) (deftest symbol-equalp (test-if-not-in-cl-package "equalp") nil) (deftest symbol-error (test-if-not-in-cl-package "error") nil) (deftest symbol-etypecase (test-if-not-in-cl-package "etypecase") nil) (deftest symbol-eval (test-if-not-in-cl-package "eval") nil) (deftest symbol-eval-when (test-if-not-in-cl-package "eval-when") nil) (deftest symbol-evenp (test-if-not-in-cl-package "evenp") nil) (deftest symbol-every (test-if-not-in-cl-package "every") nil) (deftest symbol-exp (test-if-not-in-cl-package "exp") nil) (deftest symbol-export (test-if-not-in-cl-package "export") nil) (deftest symbol-expt (test-if-not-in-cl-package "expt") nil) (deftest symbol-extended-char (test-if-not-in-cl-package "extended-char") nil) (deftest symbol-fboundp (test-if-not-in-cl-package "fboundp") nil) (deftest symbol-fceiling (test-if-not-in-cl-package "fceiling") nil) (deftest symbol-fdefinition (test-if-not-in-cl-package "fdefinition") nil) (deftest symbol-ffloor (test-if-not-in-cl-package "ffloor") nil) (deftest symbol-fifth (test-if-not-in-cl-package "fifth") nil) (deftest symbol-file-author (test-if-not-in-cl-package "file-author") nil) (deftest symbol-file-error (test-if-not-in-cl-package "file-error") nil) (deftest symbol-file-error-pathname (test-if-not-in-cl-package "file-error-pathname") nil) (deftest symbol-file-length (test-if-not-in-cl-package "file-length") nil) (deftest symbol-file-namestring (test-if-not-in-cl-package "file-namestring") nil) (deftest symbol-file-position (test-if-not-in-cl-package "file-position") nil) (deftest symbol-file-stream (test-if-not-in-cl-package "file-stream") nil) (deftest symbol-file-string-length (test-if-not-in-cl-package "file-string-length") nil) (deftest symbol-file-write-date (test-if-not-in-cl-package "file-write-date") nil) (deftest symbol-fill (test-if-not-in-cl-package "fill") nil) (deftest symbol-fill-pointer (test-if-not-in-cl-package "fill-pointer") nil) (deftest symbol-find (test-if-not-in-cl-package "find") nil) (deftest symbol-find-all-symbols (test-if-not-in-cl-package "find-all-symbols") nil) (deftest symbol-find-class (test-if-not-in-cl-package "find-class") nil) (deftest symbol-find-if (test-if-not-in-cl-package "find-if") nil) (deftest symbol-find-if-not (test-if-not-in-cl-package "find-if-not") nil) (deftest symbol-find-method (test-if-not-in-cl-package "find-method") nil) (deftest symbol-find-package (test-if-not-in-cl-package "find-package") nil) (deftest symbol-find-restart (test-if-not-in-cl-package "find-restart") nil) (deftest symbol-find-symbol (test-if-not-in-cl-package "find-symbol") nil) (deftest symbol-finish-output (test-if-not-in-cl-package "finish-output") nil) (deftest symbol-first (test-if-not-in-cl-package "first") nil) (deftest symbol-fixnum (test-if-not-in-cl-package "fixnum") nil) (deftest symbol-flet (test-if-not-in-cl-package "flet") nil) (deftest symbol-float (test-if-not-in-cl-package "float") nil) (deftest symbol-float-digits (test-if-not-in-cl-package "float-digits") nil) (deftest symbol-float-precision (test-if-not-in-cl-package "float-precision") nil) (deftest symbol-float-radix (test-if-not-in-cl-package "float-radix") nil) (deftest symbol-float-sign (test-if-not-in-cl-package "float-sign") nil) (deftest symbol-floating-point-inexact (test-if-not-in-cl-package "floating-point-inexact") nil) (deftest symbol-floating-point-invalid-operation (test-if-not-in-cl-package "floating-point-invalid-operation") nil) (deftest symbol-floating-point-overflow (test-if-not-in-cl-package "floating-point-overflow") nil) (deftest symbol-floating-point-underflow (test-if-not-in-cl-package "floating-point-underflow") nil) (deftest symbol-floatp (test-if-not-in-cl-package "floatp") nil) (deftest symbol-floor (test-if-not-in-cl-package "floor") nil) (deftest symbol-fmakunbound (test-if-not-in-cl-package "fmakunbound") nil) (deftest symbol-force-output (test-if-not-in-cl-package "force-output") nil) (deftest symbol-format (test-if-not-in-cl-package "format") nil) (deftest symbol-formatter (test-if-not-in-cl-package "formatter") nil) (deftest symbol-fourth (test-if-not-in-cl-package "fourth") nil) (deftest symbol-fresh-line (test-if-not-in-cl-package "fresh-line") nil) (deftest symbol-fround (test-if-not-in-cl-package "fround") nil) (deftest symbol-ftruncate (test-if-not-in-cl-package "ftruncate") nil) (deftest symbol-ftype (test-if-not-in-cl-package "ftype") nil) (deftest symbol-funcall (test-if-not-in-cl-package "funcall") nil) (deftest symbol-function (test-if-not-in-cl-package "function") nil) (deftest symbol-function-keywords (test-if-not-in-cl-package "function-keywords") nil) (deftest symbol-function-lambda-expression (test-if-not-in-cl-package "function-lambda-expression") nil) (deftest symbol-functionp (test-if-not-in-cl-package "functionp") nil) (deftest symbol-gcd (test-if-not-in-cl-package "gcd") nil) (deftest symbol-generic-function (test-if-not-in-cl-package "generic-function") nil) (deftest symbol-gensym (test-if-not-in-cl-package "gensym") nil) (deftest symbol-gentemp (test-if-not-in-cl-package "gentemp") nil) (deftest symbol-get (test-if-not-in-cl-package "get") nil) (deftest symbol-get-decoded-time (test-if-not-in-cl-package "get-decoded-time") nil) (deftest symbol-get-dispatch-macro-character (test-if-not-in-cl-package "get-dispatch-macro-character") nil) (deftest symbol-get-internal-real-time (test-if-not-in-cl-package "get-internal-real-time") nil) (deftest symbol-get-internal-run-time (test-if-not-in-cl-package "get-internal-run-time") nil) (deftest symbol-get-macro-character (test-if-not-in-cl-package "get-macro-character") nil) (deftest symbol-get-output-stream-string (test-if-not-in-cl-package "get-output-stream-string") nil) (deftest symbol-get-properties (test-if-not-in-cl-package "get-properties") nil) (deftest symbol-get-setf-expansion (test-if-not-in-cl-package "get-setf-expansion") nil) (deftest symbol-get-universal-time (test-if-not-in-cl-package "get-universal-time") nil) (deftest symbol-getf (test-if-not-in-cl-package "getf") nil) (deftest symbol-gethash (test-if-not-in-cl-package "gethash") nil) (deftest symbol-go (test-if-not-in-cl-package "go") nil) (deftest symbol-graphic-char-p (test-if-not-in-cl-package "graphic-char-p") nil) (deftest symbol-handler-bind (test-if-not-in-cl-package "handler-bind") nil) (deftest symbol-handler-case (test-if-not-in-cl-package "handler-case") nil) (deftest symbol-hash-table (test-if-not-in-cl-package "hash-table") nil) (deftest symbol-hash-table-count (test-if-not-in-cl-package "hash-table-count") nil) (deftest symbol-hash-table-p (test-if-not-in-cl-package "hash-table-p") nil) (deftest symbol-hash-table-rehash-size (test-if-not-in-cl-package "hash-table-rehash-size") nil) (deftest symbol-hash-table-rehash-threshold (test-if-not-in-cl-package "hash-table-rehash-threshold") nil) (deftest symbol-hash-table-size (test-if-not-in-cl-package "hash-table-size") nil) (deftest symbol-hash-table-test (test-if-not-in-cl-package "hash-table-test") nil) (deftest symbol-host-namestring (test-if-not-in-cl-package "host-namestring") nil) (deftest symbol-identity (test-if-not-in-cl-package "identity") nil) (deftest symbol-if (test-if-not-in-cl-package "if") nil) (deftest symbol-ignorable (test-if-not-in-cl-package "ignorable") nil) (deftest symbol-ignore (test-if-not-in-cl-package "ignore") nil) (deftest symbol-ignore-errors (test-if-not-in-cl-package "ignore-errors") nil) (deftest symbol-imagpart (test-if-not-in-cl-package "imagpart") nil) (deftest symbol-import (test-if-not-in-cl-package "import") nil) (deftest symbol-in-package (test-if-not-in-cl-package "in-package") nil) (deftest symbol-incf (test-if-not-in-cl-package "incf") nil) (deftest symbol-initialize-instance (test-if-not-in-cl-package "initialize-instance") nil) (deftest symbol-inline (test-if-not-in-cl-package "inline") nil) (deftest symbol-input-stream-p (test-if-not-in-cl-package "input-stream-p") nil) (deftest symbol-inspect (test-if-not-in-cl-package "inspect") nil) (deftest symbol-integer (test-if-not-in-cl-package "integer") nil) (deftest symbol-integer-decode-float (test-if-not-in-cl-package "integer-decode-float") nil) (deftest symbol-integer-length (test-if-not-in-cl-package "integer-length") nil) (deftest symbol-integerp (test-if-not-in-cl-package "integerp") nil) (deftest symbol-interactive-stream-p (test-if-not-in-cl-package "interactive-stream-p") nil) (deftest symbol-intern (test-if-not-in-cl-package "intern") nil) (deftest symbol-internal-time-units-per-second (test-if-not-in-cl-package "internal-time-units-per-second") nil) (deftest symbol-intersection (test-if-not-in-cl-package "intersection") nil) (deftest symbol-invalid-method-error (test-if-not-in-cl-package "invalid-method-error") nil) (deftest symbol-invoke-debugger (test-if-not-in-cl-package "invoke-debugger") nil) (deftest symbol-invoke-restart (test-if-not-in-cl-package "invoke-restart") nil) (deftest symbol-invoke-restart-interactively (test-if-not-in-cl-package "invoke-restart-interactively") nil) (deftest symbol-isqrt (test-if-not-in-cl-package "isqrt") nil) (deftest symbol-keyword (test-if-not-in-cl-package "keyword") nil) (deftest symbol-keywordp (test-if-not-in-cl-package "keywordp") nil) (deftest symbol-labels (test-if-not-in-cl-package "labels") nil) (deftest symbol-lambda (test-if-not-in-cl-package "lambda") nil) (deftest symbol-lambda-list-keywords (test-if-not-in-cl-package "lambda-list-keywords") nil) (deftest symbol-lambda-parameters-limit (test-if-not-in-cl-package "lambda-parameters-limit") nil) (deftest symbol-last (test-if-not-in-cl-package "last") nil) (deftest symbol-lcm (test-if-not-in-cl-package "lcm") nil) (deftest symbol-ldb (test-if-not-in-cl-package "ldb") nil) (deftest symbol-ldb-test (test-if-not-in-cl-package "ldb-test") nil) (deftest symbol-ldiff (test-if-not-in-cl-package "ldiff") nil) (deftest symbol-least-negative-double-float (test-if-not-in-cl-package "least-negative-double-float") nil) (deftest symbol-least-negative-long-float (test-if-not-in-cl-package "least-negative-long-float") nil) (deftest symbol-least-negative-normalized-double-float (test-if-not-in-cl-package "least-negative-normalized-double-float") nil) (deftest symbol-least-negative-normalized-long-float (test-if-not-in-cl-package "least-negative-normalized-long-float") nil) (deftest symbol-least-negative-normalized-short-float (test-if-not-in-cl-package "least-negative-normalized-short-float") nil) (deftest symbol-least-negative-normalized-single-float (test-if-not-in-cl-package "least-negative-normalized-single-float") nil) (deftest symbol-least-negative-short-float (test-if-not-in-cl-package "least-negative-short-float") nil) (deftest symbol-least-negative-single-float (test-if-not-in-cl-package "least-negative-single-float") nil) (deftest symbol-least-positive-double-float (test-if-not-in-cl-package "least-positive-double-float") nil) (deftest symbol-least-positive-long-float (test-if-not-in-cl-package "least-positive-long-float") nil) (deftest symbol-least-positive-normalized-double-float (test-if-not-in-cl-package "least-positive-normalized-double-float") nil) (deftest symbol-least-positive-normalized-long-float (test-if-not-in-cl-package "least-positive-normalized-long-float") nil) (deftest symbol-least-positive-normalized-short-float (test-if-not-in-cl-package "least-positive-normalized-short-float") nil) (deftest symbol-least-positive-normalized-single-float (test-if-not-in-cl-package "least-positive-normalized-single-float") nil) (deftest symbol-least-positive-short-float (test-if-not-in-cl-package "least-positive-short-float") nil) (deftest symbol-least-positive-single-float (test-if-not-in-cl-package "least-positive-single-float") nil) (deftest symbol-length (test-if-not-in-cl-package "length") nil) (deftest symbol-let (test-if-not-in-cl-package "let") nil) (deftest symbol-let* (test-if-not-in-cl-package "let*") nil) (deftest symbol-lisp-implementation-type (test-if-not-in-cl-package "lisp-implementation-type") nil) (deftest symbol-lisp-implementation-version (test-if-not-in-cl-package "lisp-implementation-version") nil) (deftest symbol-list (test-if-not-in-cl-package "list") nil) (deftest symbol-list* (test-if-not-in-cl-package "list*") nil) (deftest symbol-list-all-packages (test-if-not-in-cl-package "list-all-packages") nil) (deftest symbol-list-length (test-if-not-in-cl-package "list-length") nil) (deftest symbol-listen (test-if-not-in-cl-package "listen") nil) (deftest symbol-listp (test-if-not-in-cl-package "listp") nil) (deftest symbol-load (test-if-not-in-cl-package "load") nil) (deftest symbol-load-logical-pathname-translations (test-if-not-in-cl-package "load-logical-pathname-translations") nil) (deftest symbol-load-time-value (test-if-not-in-cl-package "load-time-value") nil) (deftest symbol-locally (test-if-not-in-cl-package "locally") nil) (deftest symbol-log (test-if-not-in-cl-package "log") nil) (deftest symbol-logand (test-if-not-in-cl-package "logand") nil) (deftest symbol-logandc1 (test-if-not-in-cl-package "logandc1") nil) (deftest symbol-logandc2 (test-if-not-in-cl-package "logandc2") nil) (deftest symbol-logbitp (test-if-not-in-cl-package "logbitp") nil) (deftest symbol-logcount (test-if-not-in-cl-package "logcount") nil) (deftest symbol-logeqv (test-if-not-in-cl-package "logeqv") nil) (deftest symbol-logical-pathname (test-if-not-in-cl-package "logical-pathname") nil) (deftest symbol-logical-pathname-translations (test-if-not-in-cl-package "logical-pathname-translations") nil) (deftest symbol-logior (test-if-not-in-cl-package "logior") nil) (deftest symbol-lognand (test-if-not-in-cl-package "lognand") nil) (deftest symbol-lognor (test-if-not-in-cl-package "lognor") nil) (deftest symbol-lognot (test-if-not-in-cl-package "lognot") nil) (deftest symbol-logorc1 (test-if-not-in-cl-package "logorc1") nil) (deftest symbol-logorc2 (test-if-not-in-cl-package "logorc2") nil) (deftest symbol-logtest (test-if-not-in-cl-package "logtest") nil) (deftest symbol-logxor (test-if-not-in-cl-package "logxor") nil) (deftest symbol-long-float (test-if-not-in-cl-package "long-float") nil) (deftest symbol-long-float-epsilon (test-if-not-in-cl-package "long-float-epsilon") nil) (deftest symbol-long-float-negative-epsilon (test-if-not-in-cl-package "long-float-negative-epsilon") nil) (deftest symbol-long-site-name (test-if-not-in-cl-package "long-site-name") nil) (deftest symbol-loop (test-if-not-in-cl-package "loop") nil) (deftest symbol-loop-finish (test-if-not-in-cl-package "loop-finish") nil) (deftest symbol-lower-case-p (test-if-not-in-cl-package "lower-case-p") nil) (deftest symbol-machine-instance (test-if-not-in-cl-package "machine-instance") nil) (deftest symbol-machine-type (test-if-not-in-cl-package "machine-type") nil) (deftest symbol-machine-version (test-if-not-in-cl-package "machine-version") nil) (deftest symbol-macro-function (test-if-not-in-cl-package "macro-function") nil) (deftest symbol-macroexpand (test-if-not-in-cl-package "macroexpand") nil) (deftest symbol-macroexpand-1 (test-if-not-in-cl-package "macroexpand-1") nil) (deftest symbol-macrolet (test-if-not-in-cl-package "macrolet") nil) (deftest symbol-make-array (test-if-not-in-cl-package "make-array") nil) (deftest symbol-make-broadcast-stream (test-if-not-in-cl-package "make-broadcast-stream") nil) (deftest symbol-make-concatenated-stream (test-if-not-in-cl-package "make-concatenated-stream") nil) (deftest symbol-make-condition (test-if-not-in-cl-package "make-condition") nil) (deftest symbol-make-dispatch-macro-character (test-if-not-in-cl-package "make-dispatch-macro-character") nil) (deftest symbol-make-echo-stream (test-if-not-in-cl-package "make-echo-stream") nil) (deftest symbol-make-hash-table (test-if-not-in-cl-package "make-hash-table") nil) (deftest symbol-make-instance (test-if-not-in-cl-package "make-instance") nil) (deftest symbol-make-instances-obsolete (test-if-not-in-cl-package "make-instances-obsolete") nil) (deftest symbol-make-list (test-if-not-in-cl-package "make-list") nil) (deftest symbol-make-load-form (test-if-not-in-cl-package "make-load-form") nil) (deftest symbol-make-load-form-saving-slots (test-if-not-in-cl-package "make-load-form-saving-slots") nil) (deftest symbol-make-method (test-if-not-in-cl-package "make-method") nil) (deftest symbol-make-package (test-if-not-in-cl-package "make-package") nil) (deftest symbol-make-pathname (test-if-not-in-cl-package "make-pathname") nil) (deftest symbol-make-random-state (test-if-not-in-cl-package "make-random-state") nil) (deftest symbol-make-sequence (test-if-not-in-cl-package "make-sequence") nil) (deftest symbol-make-string (test-if-not-in-cl-package "make-string") nil) (deftest symbol-make-string-input-stream (test-if-not-in-cl-package "make-string-input-stream") nil) (deftest symbol-make-string-output-stream (test-if-not-in-cl-package "make-string-output-stream") nil) (deftest symbol-make-symbol (test-if-not-in-cl-package "make-symbol") nil) (deftest symbol-make-synonym-stream (test-if-not-in-cl-package "make-synonym-stream") nil) (deftest symbol-make-two-way-stream (test-if-not-in-cl-package "make-two-way-stream") nil) (deftest symbol-makunbound (test-if-not-in-cl-package "makunbound") nil) (deftest symbol-map (test-if-not-in-cl-package "map") nil) (deftest symbol-map-into (test-if-not-in-cl-package "map-into") nil) (deftest symbol-mapc (test-if-not-in-cl-package "mapc") nil) (deftest symbol-mapcan (test-if-not-in-cl-package "mapcan") nil) (deftest symbol-mapcar (test-if-not-in-cl-package "mapcar") nil) (deftest symbol-mapcon (test-if-not-in-cl-package "mapcon") nil) (deftest symbol-maphash (test-if-not-in-cl-package "maphash") nil) (deftest symbol-mapl (test-if-not-in-cl-package "mapl") nil) (deftest symbol-maplist (test-if-not-in-cl-package "maplist") nil) (deftest symbol-mask-field (test-if-not-in-cl-package "mask-field") nil) (deftest symbol-max (test-if-not-in-cl-package "max") nil) (deftest symbol-member (test-if-not-in-cl-package "member") nil) (deftest symbol-member-if (test-if-not-in-cl-package "member-if") nil) (deftest symbol-member-if-not (test-if-not-in-cl-package "member-if-not") nil) (deftest symbol-merge (test-if-not-in-cl-package "merge") nil) (deftest symbol-merge-pathnames (test-if-not-in-cl-package "merge-pathnames") nil) (deftest symbol-method (test-if-not-in-cl-package "method") nil) (deftest symbol-method-combination (test-if-not-in-cl-package "method-combination") nil) (deftest symbol-method-combination-error (test-if-not-in-cl-package "method-combination-error") nil) (deftest symbol-method-qualifiers (test-if-not-in-cl-package "method-qualifiers") nil) (deftest symbol-min (test-if-not-in-cl-package "min") nil) (deftest symbol-minusp (test-if-not-in-cl-package "minusp") nil) (deftest symbol-mismatch (test-if-not-in-cl-package "mismatch") nil) (deftest symbol-mod (test-if-not-in-cl-package "mod") nil) (deftest symbol-most-negative-double-float (test-if-not-in-cl-package "most-negative-double-float") nil) (deftest symbol-most-negative-fixnum (test-if-not-in-cl-package "most-negative-fixnum") nil) (deftest symbol-most-negative-long-float (test-if-not-in-cl-package "most-negative-long-float") nil) (deftest symbol-most-negative-short-float (test-if-not-in-cl-package "most-negative-short-float") nil) (deftest symbol-most-negative-single-float (test-if-not-in-cl-package "most-negative-single-float") nil) (deftest symbol-most-positive-double-float (test-if-not-in-cl-package "most-positive-double-float") nil) (deftest symbol-most-positive-fixnum (test-if-not-in-cl-package "most-positive-fixnum") nil) (deftest symbol-most-positive-long-float (test-if-not-in-cl-package "most-positive-long-float") nil) (deftest symbol-most-positive-short-float (test-if-not-in-cl-package "most-positive-short-float") nil) (deftest symbol-most-positive-single-float (test-if-not-in-cl-package "most-positive-single-float") nil) (deftest symbol-muffle-warning (test-if-not-in-cl-package "muffle-warning") nil) (deftest symbol-multiple-value-bind (test-if-not-in-cl-package "multiple-value-bind") nil) (deftest symbol-multiple-value-call (test-if-not-in-cl-package "multiple-value-call") nil) (deftest symbol-multiple-value-list (test-if-not-in-cl-package "multiple-value-list") nil) (deftest symbol-multiple-value-prog1 (test-if-not-in-cl-package "multiple-value-prog1") nil) (deftest symbol-multiple-value-setq (test-if-not-in-cl-package "multiple-value-setq") nil) (deftest symbol-multiple-values-limit (test-if-not-in-cl-package "multiple-values-limit") nil) (deftest symbol-name-char (test-if-not-in-cl-package "name-char") nil) (deftest symbol-namestring (test-if-not-in-cl-package "namestring") nil) (deftest symbol-nbutlast (test-if-not-in-cl-package "nbutlast") nil) (deftest symbol-nconc (test-if-not-in-cl-package "nconc") nil) (deftest symbol-next-method-p (test-if-not-in-cl-package "next-method-p") nil) (deftest symbol-nil (test-if-not-in-cl-package "nil") nil) (deftest symbol-nintersection (test-if-not-in-cl-package "nintersection") nil) (deftest symbol-ninth (test-if-not-in-cl-package "ninth") nil) (deftest symbol-no-applicable-method (test-if-not-in-cl-package "no-applicable-method") nil) (deftest symbol-no-next-method (test-if-not-in-cl-package "no-next-method") nil) (deftest symbol-not (test-if-not-in-cl-package "not") nil) (deftest symbol-notany (test-if-not-in-cl-package "notany") nil) (deftest symbol-notevery (test-if-not-in-cl-package "notevery") nil) (deftest symbol-notinline (test-if-not-in-cl-package "notinline") nil) (deftest symbol-nreconc (test-if-not-in-cl-package "nreconc") nil) (deftest symbol-nreverse (test-if-not-in-cl-package "nreverse") nil) (deftest symbol-nset-difference (test-if-not-in-cl-package "nset-difference") nil) (deftest symbol-nset-exclusive-or (test-if-not-in-cl-package "nset-exclusive-or") nil) (deftest symbol-nstring-capitalize (test-if-not-in-cl-package "nstring-capitalize") nil) (deftest symbol-nstring-downcase (test-if-not-in-cl-package "nstring-downcase") nil) (deftest symbol-nstring-upcase (test-if-not-in-cl-package "nstring-upcase") nil) (deftest symbol-nsublis (test-if-not-in-cl-package "nsublis") nil) (deftest symbol-nsubst (test-if-not-in-cl-package "nsubst") nil) (deftest symbol-nsubst-if (test-if-not-in-cl-package "nsubst-if") nil) (deftest symbol-nsubst-if-not (test-if-not-in-cl-package "nsubst-if-not") nil) (deftest symbol-nsubstitute (test-if-not-in-cl-package "nsubstitute") nil) (deftest symbol-nsubstitute-if (test-if-not-in-cl-package "nsubstitute-if") nil) (deftest symbol-nsubstitute-if-not (test-if-not-in-cl-package "nsubstitute-if-not") nil) (deftest symbol-nth (test-if-not-in-cl-package "nth") nil) (deftest symbol-nth-value (test-if-not-in-cl-package "nth-value") nil) (deftest symbol-nthcdr (test-if-not-in-cl-package "nthcdr") nil) (deftest symbol-null (test-if-not-in-cl-package "null") nil) (deftest symbol-number (test-if-not-in-cl-package "number") nil) (deftest symbol-numberp (test-if-not-in-cl-package "numberp") nil) (deftest symbol-numerator (test-if-not-in-cl-package "numerator") nil) (deftest symbol-nunion (test-if-not-in-cl-package "nunion") nil) (deftest symbol-oddp (test-if-not-in-cl-package "oddp") nil) (deftest symbol-open (test-if-not-in-cl-package "open") nil) (deftest symbol-open-stream-p (test-if-not-in-cl-package "open-stream-p") nil) (deftest symbol-optimize (test-if-not-in-cl-package "optimize") nil) (deftest symbol-or (test-if-not-in-cl-package "or") nil) (deftest symbol-otherwise (test-if-not-in-cl-package "otherwise") nil) (deftest symbol-output-stream-p (test-if-not-in-cl-package "output-stream-p") nil) (deftest symbol-package (test-if-not-in-cl-package "package") nil) (deftest symbol-package-error (test-if-not-in-cl-package "package-error") nil) (deftest symbol-package-error-package (test-if-not-in-cl-package "package-error-package") nil) (deftest symbol-package-name (test-if-not-in-cl-package "package-name") nil) (deftest symbol-package-nicknames (test-if-not-in-cl-package "package-nicknames") nil) (deftest symbol-package-shadowing-symbols (test-if-not-in-cl-package "package-shadowing-symbols") nil) (deftest symbol-package-use-list (test-if-not-in-cl-package "package-use-list") nil) (deftest symbol-package-used-by-list (test-if-not-in-cl-package "package-used-by-list") nil) (deftest symbol-packagep (test-if-not-in-cl-package "packagep") nil) (deftest symbol-pairlis (test-if-not-in-cl-package "pairlis") nil) (deftest symbol-parse-error (test-if-not-in-cl-package "parse-error") nil) (deftest symbol-parse-integer (test-if-not-in-cl-package "parse-integer") nil) (deftest symbol-parse-namestring (test-if-not-in-cl-package "parse-namestring") nil) (deftest symbol-pathname (test-if-not-in-cl-package "pathname") nil) (deftest symbol-pathname-device (test-if-not-in-cl-package "pathname-device") nil) (deftest symbol-pathname-directory (test-if-not-in-cl-package "pathname-directory") nil) (deftest symbol-pathname-host (test-if-not-in-cl-package "pathname-host") nil) (deftest symbol-pathname-match-p (test-if-not-in-cl-package "pathname-match-p") nil) (deftest symbol-pathname-name (test-if-not-in-cl-package "pathname-name") nil) (deftest symbol-pathname-type (test-if-not-in-cl-package "pathname-type") nil) (deftest symbol-pathname-version (test-if-not-in-cl-package "pathname-version") nil) (deftest symbol-pathnamep (test-if-not-in-cl-package "pathnamep") nil) (deftest symbol-peek-char (test-if-not-in-cl-package "peek-char") nil) (deftest symbol-phase (test-if-not-in-cl-package "phase") nil) (deftest symbol-pi (test-if-not-in-cl-package "pi") nil) (deftest symbol-plusp (test-if-not-in-cl-package "plusp") nil) (deftest symbol-pop (test-if-not-in-cl-package "pop") nil) (deftest symbol-position (test-if-not-in-cl-package "position") nil) (deftest symbol-position-if (test-if-not-in-cl-package "position-if") nil) (deftest symbol-position-if-not (test-if-not-in-cl-package "position-if-not") nil) (deftest symbol-pprint (test-if-not-in-cl-package "pprint") nil) (deftest symbol-pprint-dispatch (test-if-not-in-cl-package "pprint-dispatch") nil) (deftest symbol-pprint-exit-if-list-exhausted (test-if-not-in-cl-package "pprint-exit-if-list-exhausted") nil) (deftest symbol-pprint-fill (test-if-not-in-cl-package "pprint-fill") nil) (deftest symbol-pprint-indent (test-if-not-in-cl-package "pprint-indent") nil) (deftest symbol-pprint-linear (test-if-not-in-cl-package "pprint-linear") nil) (deftest symbol-pprint-logical-block (test-if-not-in-cl-package "pprint-logical-block") nil) (deftest symbol-pprint-newline (test-if-not-in-cl-package "pprint-newline") nil) (deftest symbol-pprint-pop (test-if-not-in-cl-package "pprint-pop") nil) (deftest symbol-pprint-tab (test-if-not-in-cl-package "pprint-tab") nil) (deftest symbol-pprint-tabular (test-if-not-in-cl-package "pprint-tabular") nil) (deftest symbol-prin1 (test-if-not-in-cl-package "prin1") nil) (deftest symbol-prin1-to-string (test-if-not-in-cl-package "prin1-to-string") nil) (deftest symbol-princ (test-if-not-in-cl-package "princ") nil) (deftest symbol-princ-to-string (test-if-not-in-cl-package "princ-to-string") nil) (deftest symbol-print (test-if-not-in-cl-package "print") nil) (deftest symbol-print-not-readable (test-if-not-in-cl-package "print-not-readable") nil) (deftest symbol-print-not-readable-object (test-if-not-in-cl-package "print-not-readable-object") nil) (deftest symbol-print-object (test-if-not-in-cl-package "print-object") nil) (deftest symbol-print-unreadable-object (test-if-not-in-cl-package "print-unreadable-object") nil) (deftest symbol-probe-file (test-if-not-in-cl-package "probe-file") nil) (deftest symbol-proclaim (test-if-not-in-cl-package "proclaim") nil) (deftest symbol-prog (test-if-not-in-cl-package "prog") nil) (deftest symbol-prog* (test-if-not-in-cl-package "prog*") nil) (deftest symbol-prog1 (test-if-not-in-cl-package "prog1") nil) (deftest symbol-prog2 (test-if-not-in-cl-package "prog2") nil) (deftest symbol-progn (test-if-not-in-cl-package "progn") nil) (deftest symbol-program-error (test-if-not-in-cl-package "program-error") nil) (deftest symbol-progv (test-if-not-in-cl-package "progv") nil) (deftest symbol-provide (test-if-not-in-cl-package "provide") nil) (deftest symbol-psetf (test-if-not-in-cl-package "psetf") nil) (deftest symbol-psetq (test-if-not-in-cl-package "psetq") nil) (deftest symbol-push (test-if-not-in-cl-package "push") nil) (deftest symbol-pushnew (test-if-not-in-cl-package "pushnew") nil) (deftest symbol-quote (test-if-not-in-cl-package "quote") nil) (deftest symbol-random (test-if-not-in-cl-package "random") nil) (deftest symbol-random-state (test-if-not-in-cl-package "random-state") nil) (deftest symbol-random-state-p (test-if-not-in-cl-package "random-state-p") nil) (deftest symbol-rassoc (test-if-not-in-cl-package "rassoc") nil) (deftest symbol-rassoc-if (test-if-not-in-cl-package "rassoc-if") nil) (deftest symbol-rassoc-if-not (test-if-not-in-cl-package "rassoc-if-not") nil) (deftest symbol-ratio (test-if-not-in-cl-package "ratio") nil) (deftest symbol-rational (test-if-not-in-cl-package "rational") nil) (deftest symbol-rationalize (test-if-not-in-cl-package "rationalize") nil) (deftest symbol-rationalp (test-if-not-in-cl-package "rationalp") nil) (deftest symbol-read (test-if-not-in-cl-package "read") nil) (deftest symbol-read-byte (test-if-not-in-cl-package "read-byte") nil) (deftest symbol-read-char (test-if-not-in-cl-package "read-char") nil) (deftest symbol-read-char-no-hang (test-if-not-in-cl-package "read-char-no-hang") nil) (deftest symbol-read-delimited-list (test-if-not-in-cl-package "read-delimited-list") nil) (deftest symbol-read-from-string (test-if-not-in-cl-package "read-from-string") nil) (deftest symbol-read-line (test-if-not-in-cl-package "read-line") nil) (deftest symbol-read-preserving-whitespace (test-if-not-in-cl-package "read-preserving-whitespace") nil) (deftest symbol-read-sequence (test-if-not-in-cl-package "read-sequence") nil) (deftest symbol-reader-error (test-if-not-in-cl-package "reader-error") nil) (deftest symbol-readtable (test-if-not-in-cl-package "readtable") nil) (deftest symbol-readtable-case (test-if-not-in-cl-package "readtable-case") nil) (deftest symbol-readtablep (test-if-not-in-cl-package "readtablep") nil) (deftest symbol-real (test-if-not-in-cl-package "real") nil) (deftest symbol-realp (test-if-not-in-cl-package "realp") nil) (deftest symbol-realpart (test-if-not-in-cl-package "realpart") nil) (deftest symbol-reduce (test-if-not-in-cl-package "reduce") nil) (deftest symbol-reinitialize-instance (test-if-not-in-cl-package "reinitialize-instance") nil) (deftest symbol-rem (test-if-not-in-cl-package "rem") nil) (deftest symbol-remf (test-if-not-in-cl-package "remf") nil) (deftest symbol-remhash (test-if-not-in-cl-package "remhash") nil) (deftest symbol-remove (test-if-not-in-cl-package "remove") nil) (deftest symbol-remove-duplicates (test-if-not-in-cl-package "remove-duplicates") nil) (deftest symbol-remove-if (test-if-not-in-cl-package "remove-if") nil) (deftest symbol-remove-if-not (test-if-not-in-cl-package "remove-if-not") nil) (deftest symbol-remove-method (test-if-not-in-cl-package "remove-method") nil) (deftest symbol-remprop (test-if-not-in-cl-package "remprop") nil) (deftest symbol-rename-file (test-if-not-in-cl-package "rename-file") nil) (deftest symbol-rename-package (test-if-not-in-cl-package "rename-package") nil) (deftest symbol-replace (test-if-not-in-cl-package "replace") nil) (deftest symbol-require (test-if-not-in-cl-package "require") nil) (deftest symbol-rest (test-if-not-in-cl-package "rest") nil) (deftest symbol-restart (test-if-not-in-cl-package "restart") nil) (deftest symbol-restart-bind (test-if-not-in-cl-package "restart-bind") nil) (deftest symbol-restart-case (test-if-not-in-cl-package "restart-case") nil) (deftest symbol-restart-name (test-if-not-in-cl-package "restart-name") nil) (deftest symbol-return (test-if-not-in-cl-package "return") nil) (deftest symbol-return-from (test-if-not-in-cl-package "return-from") nil) (deftest symbol-revappend (test-if-not-in-cl-package "revappend") nil) (deftest symbol-reverse (test-if-not-in-cl-package "reverse") nil) (deftest symbol-room (test-if-not-in-cl-package "room") nil) (deftest symbol-rotatef (test-if-not-in-cl-package "rotatef") nil) (deftest symbol-round (test-if-not-in-cl-package "round") nil) (deftest symbol-row-major-aref (test-if-not-in-cl-package "row-major-aref") nil) (deftest symbol-rplaca (test-if-not-in-cl-package "rplaca") nil) (deftest symbol-rplacd (test-if-not-in-cl-package "rplacd") nil) (deftest symbol-safety (test-if-not-in-cl-package "safety") nil) (deftest symbol-satisfies (test-if-not-in-cl-package "satisfies") nil) (deftest symbol-sbit (test-if-not-in-cl-package "sbit") nil) (deftest symbol-scale-float (test-if-not-in-cl-package "scale-float") nil) (deftest symbol-schar (test-if-not-in-cl-package "schar") nil) (deftest symbol-search (test-if-not-in-cl-package "search") nil) (deftest symbol-second (test-if-not-in-cl-package "second") nil) (deftest symbol-sequence (test-if-not-in-cl-package "sequence") nil) (deftest symbol-serious-condition (test-if-not-in-cl-package "serious-condition") nil) (deftest symbol-set (test-if-not-in-cl-package "set") nil) (deftest symbol-set-difference (test-if-not-in-cl-package "set-difference") nil) (deftest symbol-set-dispatch-macro-character (test-if-not-in-cl-package "set-dispatch-macro-character") nil) (deftest symbol-set-exclusive-or (test-if-not-in-cl-package "set-exclusive-or") nil) (deftest symbol-set-macro-character (test-if-not-in-cl-package "set-macro-character") nil) (deftest symbol-set-pprint-dispatch (test-if-not-in-cl-package "set-pprint-dispatch") nil) (deftest symbol-set-syntax-from-char (test-if-not-in-cl-package "set-syntax-from-char") nil) (deftest symbol-setf (test-if-not-in-cl-package "setf") nil) (deftest symbol-setq (test-if-not-in-cl-package "setq") nil) (deftest symbol-seventh (test-if-not-in-cl-package "seventh") nil) (deftest symbol-shadow (test-if-not-in-cl-package "shadow") nil) (deftest symbol-shadowing-import (test-if-not-in-cl-package "shadowing-import") nil) (deftest symbol-shared-initialize (test-if-not-in-cl-package "shared-initialize") nil) (deftest symbol-shiftf (test-if-not-in-cl-package "shiftf") nil) (deftest symbol-short-float (test-if-not-in-cl-package "short-float") nil) (deftest symbol-short-float-epsilon (test-if-not-in-cl-package "short-float-epsilon") nil) (deftest symbol-short-float-negative-epsilon (test-if-not-in-cl-package "short-float-negative-epsilon") nil) (deftest symbol-short-site-name (test-if-not-in-cl-package "short-site-name") nil) (deftest symbol-signal (test-if-not-in-cl-package "signal") nil) (deftest symbol-signed-byte (test-if-not-in-cl-package "signed-byte") nil) (deftest symbol-signum (test-if-not-in-cl-package "signum") nil) (deftest symbol-simple-array (test-if-not-in-cl-package "simple-array") nil) (deftest symbol-simple-base-string (test-if-not-in-cl-package "simple-base-string") nil) (deftest symbol-simple-bit-vector (test-if-not-in-cl-package "simple-bit-vector") nil) (deftest symbol-simple-bit-vector-p (test-if-not-in-cl-package "simple-bit-vector-p") nil) (deftest symbol-simple-condition (test-if-not-in-cl-package "simple-condition") nil) (deftest symbol-simple-condition-format-arguments (test-if-not-in-cl-package "simple-condition-format-arguments") nil) (deftest symbol-simple-condition-format-control (test-if-not-in-cl-package "simple-condition-format-control") nil) (deftest symbol-simple-error (test-if-not-in-cl-package "simple-error") nil) (deftest symbol-simple-string (test-if-not-in-cl-package "simple-string") nil) (deftest symbol-simple-string-p (test-if-not-in-cl-package "simple-string-p") nil) (deftest symbol-simple-type-error (test-if-not-in-cl-package "simple-type-error") nil) (deftest symbol-simple-vector (test-if-not-in-cl-package "simple-vector") nil) (deftest symbol-simple-vector-p (test-if-not-in-cl-package "simple-vector-p") nil) (deftest symbol-simple-warning (test-if-not-in-cl-package "simple-warning") nil) (deftest symbol-sin (test-if-not-in-cl-package "sin") nil) (deftest symbol-single-float (test-if-not-in-cl-package "single-float") nil) (deftest symbol-single-float-epsilon (test-if-not-in-cl-package "single-float-epsilon") nil) (deftest symbol-single-float-negative-epsilon (test-if-not-in-cl-package "single-float-negative-epsilon") nil) (deftest symbol-sinh (test-if-not-in-cl-package "sinh") nil) (deftest symbol-sixth (test-if-not-in-cl-package "sixth") nil) (deftest symbol-sleep (test-if-not-in-cl-package "sleep") nil) (deftest symbol-slot-boundp (test-if-not-in-cl-package "slot-boundp") nil) (deftest symbol-slot-exists-p (test-if-not-in-cl-package "slot-exists-p") nil) (deftest symbol-slot-makunbound (test-if-not-in-cl-package "slot-makunbound") nil) (deftest symbol-slot-missing (test-if-not-in-cl-package "slot-missing") nil) (deftest symbol-slot-unbound (test-if-not-in-cl-package "slot-unbound") nil) (deftest symbol-slot-value (test-if-not-in-cl-package "slot-value") nil) (deftest symbol-software-type (test-if-not-in-cl-package "software-type") nil) (deftest symbol-software-version (test-if-not-in-cl-package "software-version") nil) (deftest symbol-some (test-if-not-in-cl-package "some") nil) (deftest symbol-sort (test-if-not-in-cl-package "sort") nil) (deftest symbol-space (test-if-not-in-cl-package "space") nil) (deftest symbol-special (test-if-not-in-cl-package "special") nil) (deftest symbol-special-operator-p (test-if-not-in-cl-package "special-operator-p") nil) (deftest symbol-speed (test-if-not-in-cl-package "speed") nil) (deftest symbol-sqrt (test-if-not-in-cl-package "sqrt") nil) (deftest symbol-stable-sort (test-if-not-in-cl-package "stable-sort") nil) (deftest symbol-standard (test-if-not-in-cl-package "standard") nil) (deftest symbol-standard-char (test-if-not-in-cl-package "standard-char") nil) (deftest symbol-standard-char-p (test-if-not-in-cl-package "standard-char-p") nil) (deftest symbol-standard-class (test-if-not-in-cl-package "standard-class") nil) (deftest symbol-standard-generic-function (test-if-not-in-cl-package "standard-generic-function") nil) (deftest symbol-standard-method (test-if-not-in-cl-package "standard-method") nil) (deftest symbol-standard-object (test-if-not-in-cl-package "standard-object") nil) (deftest symbol-step (test-if-not-in-cl-package "step") nil) (deftest symbol-storage-condition (test-if-not-in-cl-package "storage-condition") nil) (deftest symbol-store-value (test-if-not-in-cl-package "store-value") nil) (deftest symbol-stream (test-if-not-in-cl-package "stream") nil) (deftest symbol-stream-element-type (test-if-not-in-cl-package "stream-element-type") nil) (deftest symbol-stream-error (test-if-not-in-cl-package "stream-error") nil) (deftest symbol-stream-error-stream (test-if-not-in-cl-package "stream-error-stream") nil) (deftest symbol-stream-external-format (test-if-not-in-cl-package "stream-external-format") nil) (deftest symbol-streamp (test-if-not-in-cl-package "streamp") nil) (deftest symbol-string (test-if-not-in-cl-package "string") nil) (deftest symbol-string-capitalize (test-if-not-in-cl-package "string-capitalize") nil) (deftest symbol-string-downcase (test-if-not-in-cl-package "string-downcase") nil) (deftest symbol-string-equal (test-if-not-in-cl-package "string-equal") nil) (deftest symbol-string-greaterp (test-if-not-in-cl-package "string-greaterp") nil) (deftest symbol-string-left-trim (test-if-not-in-cl-package "string-left-trim") nil) (deftest symbol-string-lessp (test-if-not-in-cl-package "string-lessp") nil) (deftest symbol-string-not-equal (test-if-not-in-cl-package "string-not-equal") nil) (deftest symbol-string-not-greaterp (test-if-not-in-cl-package "string-not-greaterp") nil) (deftest symbol-string-not-lessp (test-if-not-in-cl-package "string-not-lessp") nil) (deftest symbol-string-right-trim (test-if-not-in-cl-package "string-right-trim") nil) (deftest symbol-string-stream (test-if-not-in-cl-package "string-stream") nil) (deftest symbol-string-trim (test-if-not-in-cl-package "string-trim") nil) (deftest symbol-string-upcase (test-if-not-in-cl-package "string-upcase") nil) (deftest symbol-string/= (test-if-not-in-cl-package "string/=") nil) (deftest symbol-string< (test-if-not-in-cl-package "string<") nil) (deftest symbol-string<= (test-if-not-in-cl-package "string<=") nil) (deftest symbol-string= (test-if-not-in-cl-package "string=") nil) (deftest symbol-string> (test-if-not-in-cl-package "string>") nil) (deftest symbol-string>= (test-if-not-in-cl-package "string>=") nil) (deftest symbol-stringp (test-if-not-in-cl-package "stringp") nil) (deftest symbol-structure (test-if-not-in-cl-package "structure") nil) (deftest symbol-structure-class (test-if-not-in-cl-package "structure-class") nil) (deftest symbol-structure-object (test-if-not-in-cl-package "structure-object") nil) (deftest symbol-style-warning (test-if-not-in-cl-package "style-warning") nil) (deftest symbol-sublis (test-if-not-in-cl-package "sublis") nil) (deftest symbol-subseq (test-if-not-in-cl-package "subseq") nil) (deftest symbol-subsetp (test-if-not-in-cl-package "subsetp") nil) (deftest symbol-subst (test-if-not-in-cl-package "subst") nil) (deftest symbol-subst-if (test-if-not-in-cl-package "subst-if") nil) (deftest symbol-subst-if-not (test-if-not-in-cl-package "subst-if-not") nil) (deftest symbol-substitute (test-if-not-in-cl-package "substitute") nil) (deftest symbol-substitute-if (test-if-not-in-cl-package "substitute-if") nil) (deftest symbol-substitute-if-not (test-if-not-in-cl-package "substitute-if-not") nil) (deftest symbol-subtypep (test-if-not-in-cl-package "subtypep") nil) (deftest symbol-svref (test-if-not-in-cl-package "svref") nil) (deftest symbol-sxhash (test-if-not-in-cl-package "sxhash") nil) (deftest symbol-symbol (test-if-not-in-cl-package "symbol") nil) (deftest symbol-symbol-function (test-if-not-in-cl-package "symbol-function") nil) (deftest symbol-symbol-macrolet (test-if-not-in-cl-package "symbol-macrolet") nil) (deftest symbol-symbol-name (test-if-not-in-cl-package "symbol-name") nil) (deftest symbol-symbol-package (test-if-not-in-cl-package "symbol-package") nil) (deftest symbol-symbol-plist (test-if-not-in-cl-package "symbol-plist") nil) (deftest symbol-symbol-value (test-if-not-in-cl-package "symbol-value") nil) (deftest symbol-symbolp (test-if-not-in-cl-package "symbolp") nil) (deftest symbol-synonym-stream (test-if-not-in-cl-package "synonym-stream") nil) (deftest symbol-synonym-stream-symbol (test-if-not-in-cl-package "synonym-stream-symbol") nil) (deftest symbol-t (test-if-not-in-cl-package "t") nil) (deftest symbol-tagbody (test-if-not-in-cl-package "tagbody") nil) (deftest symbol-tailp (test-if-not-in-cl-package "tailp") nil) (deftest symbol-tan (test-if-not-in-cl-package "tan") nil) (deftest symbol-tanh (test-if-not-in-cl-package "tanh") nil) (deftest symbol-tenth (test-if-not-in-cl-package "tenth") nil) (deftest symbol-terpri (test-if-not-in-cl-package "terpri") nil) (deftest symbol-the (test-if-not-in-cl-package "the") nil) (deftest symbol-third (test-if-not-in-cl-package "third") nil) (deftest symbol-throw (test-if-not-in-cl-package "throw") nil) (deftest symbol-time (test-if-not-in-cl-package "time") nil) (deftest symbol-trace (test-if-not-in-cl-package "trace") nil) (deftest symbol-translate-logical-pathname (test-if-not-in-cl-package "translate-logical-pathname") nil) (deftest symbol-translate-pathname (test-if-not-in-cl-package "translate-pathname") nil) (deftest symbol-tree-equal (test-if-not-in-cl-package "tree-equal") nil) (deftest symbol-truename (test-if-not-in-cl-package "truename") nil) (deftest symbol-truncate (test-if-not-in-cl-package "truncate") nil) (deftest symbol-two-way-stream (test-if-not-in-cl-package "two-way-stream") nil) (deftest symbol-two-way-stream-input-stream (test-if-not-in-cl-package "two-way-stream-input-stream") nil) (deftest symbol-two-way-stream-output-stream (test-if-not-in-cl-package "two-way-stream-output-stream") nil) (deftest symbol-type (test-if-not-in-cl-package "type") nil) (deftest symbol-type-error (test-if-not-in-cl-package "type-error") nil) (deftest symbol-type-error-datum (test-if-not-in-cl-package "type-error-datum") nil) (deftest symbol-type-error-expected-type (test-if-not-in-cl-package "type-error-expected-type") nil) (deftest symbol-type-of (test-if-not-in-cl-package "type-of") nil) (deftest symbol-typecase (test-if-not-in-cl-package "typecase") nil) (deftest symbol-typep (test-if-not-in-cl-package "typep") nil) (deftest symbol-unbound-slot (test-if-not-in-cl-package "unbound-slot") nil) (deftest symbol-unbound-slot-instance (test-if-not-in-cl-package "unbound-slot-instance") nil) (deftest symbol-unbound-variable (test-if-not-in-cl-package "unbound-variable") nil) (deftest symbol-undefined-function (test-if-not-in-cl-package "undefined-function") nil) (deftest symbol-unexport (test-if-not-in-cl-package "unexport") nil) (deftest symbol-unintern (test-if-not-in-cl-package "unintern") nil) (deftest symbol-union (test-if-not-in-cl-package "union") nil) (deftest symbol-unless (test-if-not-in-cl-package "unless") nil) (deftest symbol-unread-char (test-if-not-in-cl-package "unread-char") nil) (deftest symbol-unsigned-byte (test-if-not-in-cl-package "unsigned-byte") nil) (deftest symbol-untrace (test-if-not-in-cl-package "untrace") nil) (deftest symbol-unuse-package (test-if-not-in-cl-package "unuse-package") nil) (deftest symbol-unwind-protect (test-if-not-in-cl-package "unwind-protect") nil) (deftest symbol-update-instance-for-different-class (test-if-not-in-cl-package "update-instance-for-different-class") nil) (deftest symbol-update-instance-for-redefined-class (test-if-not-in-cl-package "update-instance-for-redefined-class") nil) (deftest symbol-upgraded-array-element-type (test-if-not-in-cl-package "upgraded-array-element-type") nil) (deftest symbol-upgraded-complex-part-type (test-if-not-in-cl-package "upgraded-complex-part-type") nil) (deftest symbol-upper-case-p (test-if-not-in-cl-package "upper-case-p") nil) (deftest symbol-use-package (test-if-not-in-cl-package "use-package") nil) (deftest symbol-use-value (test-if-not-in-cl-package "use-value") nil) (deftest symbol-user-homedir-pathname (test-if-not-in-cl-package "user-homedir-pathname") nil) (deftest symbol-values (test-if-not-in-cl-package "values") nil) (deftest symbol-values-list (test-if-not-in-cl-package "values-list") nil) (deftest symbol-variable (test-if-not-in-cl-package "variable") nil) (deftest symbol-vector (test-if-not-in-cl-package "vector") nil) (deftest symbol-vector-pop (test-if-not-in-cl-package "vector-pop") nil) (deftest symbol-vector-push (test-if-not-in-cl-package "vector-push") nil) (deftest symbol-vector-push-extend (test-if-not-in-cl-package "vector-push-extend") nil) (deftest symbol-vectorp (test-if-not-in-cl-package "vectorp") nil) (deftest symbol-warn (test-if-not-in-cl-package "warn") nil) (deftest symbol-warning (test-if-not-in-cl-package "warning") nil) (deftest symbol-when (test-if-not-in-cl-package "when") nil) (deftest symbol-wild-pathname-p (test-if-not-in-cl-package "wild-pathname-p") nil) (deftest symbol-with-accessors (test-if-not-in-cl-package "with-accessors") nil) (deftest symbol-with-compilation-unit (test-if-not-in-cl-package "with-compilation-unit") nil) (deftest symbol-with-condition-restarts (test-if-not-in-cl-package "with-condition-restarts") nil) (deftest symbol-with-hash-table-iterator (test-if-not-in-cl-package "with-hash-table-iterator") nil) (deftest symbol-with-input-from-string (test-if-not-in-cl-package "with-input-from-string") nil) (deftest symbol-with-open-file (test-if-not-in-cl-package "with-open-file") nil) (deftest symbol-with-open-stream (test-if-not-in-cl-package "with-open-stream") nil) (deftest symbol-with-output-to-string (test-if-not-in-cl-package "with-output-to-string") nil) (deftest symbol-with-package-iterator (test-if-not-in-cl-package "with-package-iterator") nil) (deftest symbol-with-simple-restart (test-if-not-in-cl-package "with-simple-restart") nil) (deftest symbol-with-slots (test-if-not-in-cl-package "with-slots") nil) (deftest symbol-with-standard-io-syntax (test-if-not-in-cl-package "with-standard-io-syntax") nil) (deftest symbol-write (test-if-not-in-cl-package "write") nil) (deftest symbol-write-byte (test-if-not-in-cl-package "write-byte") nil) (deftest symbol-write-char (test-if-not-in-cl-package "write-char") nil) (deftest symbol-write-line (test-if-not-in-cl-package "write-line") nil) (deftest symbol-write-sequence (test-if-not-in-cl-package "write-sequence") nil) (deftest symbol-write-string (test-if-not-in-cl-package "write-string") nil) (deftest symbol-write-to-string (test-if-not-in-cl-package "write-to-string") nil) (deftest symbol-y-or-n-p (test-if-not-in-cl-package "y-or-n-p") nil) (deftest symbol-yes-or-no-p (test-if-not-in-cl-package "yes-or-no-p") nil) (deftest symbol-zerop (test-if-not-in-cl-package "zerop") nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Test that all keywords have themselves as their value, ;;; are external if present in KEYWORD, and have themselves ;;; as their values (and are constant). Symbols that are ;;; merely used in KEYWORD but not present there are exempt. (deftest keyword-behavior (let ((result nil) (keyword-package (find-package "KEYWORD"))) (do-symbols (s keyword-package result) (multiple-value-bind (sym status) (find-symbol (symbol-name s) keyword-package) (cond ((not (eqt s sym)) (push (list s sym) result)) ((eqt status :internal) (push (list s status) result)) ((eqt status :external) (unless (and (eqt (symbol-value s) s) (constantp s)) (push (list s sym 'not-constant) result))))))) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; special-operator-p ;;; See section 3.1.2.1.2.1 (defparameter +special-operators+ '(block let* return-from catch load-time-value setq eval-when locally symbol-macrolet flet macrolet tagbody function multiple-value-call the go multiple-value-prog1 throw if progn unwind-protect labels progv let quote)) ;;; All the symbols in +special-operators+ are special operators (deftest special-operator-p.1 (loop for s in +special-operators+ unless (special-operator-p s) collect s) nil) ;;; None of the standard symbols except those in +special-operators+ ;;; are special operators, unless they have a macro function ;;; (See the page for MACRO-FUNCTION) (deftest special-operator-p.2 (let ((p (find-package "CL"))) (loop for name in *cl-symbol-names* unless (or (member name +special-operators+ :test #'string=) (let ((sym (find-symbol name p))) (or (not (special-operator-p sym)) (macro-function sym)))) collect name)) nil) (deftest special-operator-p.order.1 (let ((i 0)) (values (notnot (special-operator-p (progn (incf i) 'catch))) i)) t 1) (deftest special-operator-p.error.1 (classify-error (special-operator-p 1)) type-error) (deftest special-operator-p.error.2 (classify-error (special-operator-p)) program-error) (deftest special-operator-p.error.3 (classify-error (special-operator-p 'cons 'cons)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; keywordp (deftest keywordp.1 (keywordp 'hefalump) nil) (deftest keywordp.2 (keywordp 17) nil) (deftest keywordp.3 (notnot-mv (keywordp :stream)) t) (deftest keywordp.4 (notnot-mv (keywordp ':stream)) t) (deftest keywordp.5 (keywordp nil) nil) (deftest keywordp.6 (notnot-mv (keywordp :nil)) t) (deftest keywordp.7 (keywordp '(:stream)) nil) (deftest keywordp.8 (keywordp "rest") nil) (deftest keywordp.9 (keywordp ":rest") nil) (deftest keywordp.10 (keywordp '&body) nil) ;;; This next test was busted. ::foo is not portable syntax ;;(deftest keywordp.11 (notnot-mv (keywordp ::foo)) t) (deftest keywordp.12 (keywordp t) nil) (deftest keywordp.order.1 (let ((i 0)) (values (keywordp (progn (incf i) nil)) i)) nil 1) (deftest keywordp.error.1 (classify-error (keywordp)) program-error) (deftest keywordp.error.2 (classify-error (keywordp :x :x)) program-error) (deftest keywordp.error.3 (classify-error (keywordp)) program-error) (deftest keywordp.error.4 (classify-error (keywordp nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; symbol-name (deftest symbol-name.1 (symbol-name '|ABCD|) "ABCD") (deftest symbol-name.2 (symbol-name '|1234abcdABCD|) "1234abcdABCD") (deftest symbol-name.3 (classify-error (symbol-name 1)) type-error) (deftest symbol-name.4 (classify-error (symbol-name '(a))) type-error) (deftest symbol-name.5 (classify-error (symbol-name "ABCDE")) type-error) (deftest symbol-name.6 (classify-error (symbol-name 12913.0213)) type-error) (deftest symbol-name.7 (symbol-name :|abcdefg|) "abcdefg") (deftest symbol-name.error.1 (classify-error (symbol-name)) program-error) (deftest symbol-name.error.2 (classify-error (symbol-name 'a 'b)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; make-symbol (deftest make-symbol.1 (notnot-mv (symbolp (make-symbol "FOO"))) t) (deftest make-symbol.2 (symbol-package (make-symbol "BAR")) nil) (deftest make-symbol.3 (symbol-package (make-symbol "CL::FOO")) nil) (deftest make-symbol.4 (symbol-package (make-symbol "CL:FOO")) nil) (deftest make-symbol.5 (symbol-name (make-symbol "xyz")) "xyz") (deftest make-symbol.6 (eqt (make-symbol "A") (make-symbol "A")) nil) (deftest make-symbol.7 (boundp (make-symbol "B")) nil) (deftest make-symbol.8 (symbol-plist (make-symbol "C")) nil) (deftest make-symbol.9 (fboundp (make-symbol "D")) nil) (deftest make-symbol.10 (symbol-name (make-symbol "")) "") (deftest make-symbol.order.1 (let ((i 0)) (values (symbol-name (make-symbol (progn (incf i) "ABC"))) i)) "ABC" 1) (deftest make-symbol.error.1 (classify-error (make-symbol nil)) type-error) (deftest make-symbol.error.2 (classify-error (make-symbol 'a)) type-error) (deftest make-symbol.error.3 (classify-error (make-symbol 1)) type-error) (deftest make-symbol.error.4 (classify-error (make-symbol -1)) type-error) (deftest make-symbol.error.5 (classify-error (make-symbol 1.213)) type-error) (deftest make-symbol.error.6 (classify-error (make-symbol -1312.2)) type-error) (deftest make-symbol.error.7 (classify-error (make-symbol #\w)) type-error) (deftest make-symbol.error.8 (classify-error (make-symbol '(a))) type-error) (deftest make-symbol.error.9 (classify-error (make-symbol)) program-error) (deftest make-symbol.error.10 (classify-error (make-symbol "a" "a")) program-error) (deftest make-symbol.error.11 (classify-error (make-symbol '(#\a #\b #\c))) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; copy-symbol (deftest copy-symbol.1 (notnot-mv (every #'(lambda (x) (let ((y (copy-symbol x))) (and (null (symbol-plist y)) (symbolp y) (not (boundp y)) (not (fboundp y)) (null (symbol-package y)) (string= (symbol-name x) (symbol-name y)) (symbolp (copy-symbol y)) ))) '(nil t a b |a| |123|))) t) (deftest copy-symbol.2 (progn (setf (symbol-plist '|foo|) '(a b c d)) (makunbound '|foo|) (notnot-mv (every #'(lambda (x) (let ((y (copy-symbol x t))) (and (equal (symbol-plist y) (symbol-plist x)) (symbolp y) (if (boundp x) (boundp y) (not (boundp y))) (if (fboundp x) (fboundp y) (not (fboundp y))) (null (symbol-package y)) (string= (symbol-name x) (symbol-name y)) ))) '(nil t a b |foo| |a| |123|)))) t) (deftest copy-symbol.3 (progn (setf (symbol-plist '|foo|) '(a b c d)) (setf (symbol-value '|a|) 12345) (notnot-mv (every #'(lambda (x) (let ((y (copy-symbol x t))) (and (eql (length (symbol-plist y)) (length (symbol-plist x))) ;; Is a list copy (every #'eq (symbol-plist y) (symbol-plist x)) (symbolp y) (if (boundp x) (eqt (symbol-value x) (symbol-value y)) (not (boundp y))) (if (fboundp x) (fboundp y) (not (fboundp y))) (null (symbol-package y)) (string= (symbol-name x) (symbol-name y)) (eql (length (symbol-plist x)) (length (symbol-plist y))) ))) '(nil t a b |foo| |a| |123|)))) t) (deftest copy-symbol.4 (eqt (copy-symbol 'a) (copy-symbol 'a)) nil) (deftest copy-symbol.5 (let ((i 0) x y (s '#:|x|)) (let ((s2 (copy-symbol (progn (setf x (incf i)) s) (progn (setf y (incf i)) nil)))) (values (symbol-name s2) (eq s s2) i x y))) "x" nil 2 1 2) (deftest copy-symbol.error.1 (classify-error (copy-symbol)) program-error) (deftest copy-symbol.error.2 (classify-error (copy-symbol 'a t 'foo)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; gensym ;;; Gensym returns unique symbols (deftest gensym.1 (equal (gensym) (gensym)) nil) ;;; Gensym returns symbols with distinct print names (deftest gensym.2 (string= (symbol-name (gensym)) (symbol-name (gensym))) nil) ;;; Gensym uses the *gensym-counter* special variable, ;;; but does not increment it until after the symbol ;;; has been created. (deftest gensym.3 (let ((*gensym-counter* 1)) (declare (special *gensym-counter*)) (symbol-name (gensym))) #.(string '#:g1)) ;;; Gensym uses the string argument instead of the default (deftest gensym.4 (let ((*gensym-counter* 1327)) (declare (special *gensym-counter*)) (symbol-name (gensym "FOO"))) "FOO1327") ;;; The symbol returned by gensym should be unbound (deftest gensym.5 (boundp (gensym)) nil) ;;; The symbol returned by gensym should have no function binding (deftest gensym.6 (fboundp (gensym)) nil) ;;; The symbol returned by gensym should have no property list (deftest gensym.7 (symbol-plist (gensym)) nil) ;;; The symbol returned by gensym should be uninterned (deftest gensym.8 (symbol-package (gensym)) nil) ;;; *gensym-counter* is incremented by gensym (deftest gensym.9 (let ((*gensym-counter* 12345)) (declare (special *gensym-counter*)) (gensym) *gensym-counter*) 12346) ;;; Gensym works when *gensym-counter* is Really Big ;;; (and does not increment the counter until after creating ;;; the symbol.) (deftest gensym.10 (let ((*gensym-counter* 1234567890123456789012345678901234567890)) (declare (special *gensym-counter*)) (symbol-name (gensym))) #.(string '#:g1234567890123456789012345678901234567890)) ;;; gensym increments Really Big values of *gensym-counter* (deftest gensym.11 (let ((*gensym-counter* 12345678901234567890123456789012345678901234567890)) (declare (special *gensym-counter*)) (gensym) *gensym-counter*) 12345678901234567890123456789012345678901234567891) ;;; Gensym uses an integer argument instead of the counter (deftest gensym.12 (let ((*gensym-counter* 10)) (declare (special *gensym-counter*)) (symbol-name (gensym 123))) #.(string '#:g123)) ;;; When given an integer argument, gensym does not increment the ;;; *gensym-counter* (deftest gensym.13 (let ((*gensym-counter* 10)) (declare (special *gensym-counter*)) (gensym 123) *gensym-counter*) 10) ;;; Check response to erroneous arguments ;;; Note! NIL is not the same as no argument ;;; gensym should be implemented so that its only ;;; argument defaults to "G", with NIL causing an error. (deftest gensym.error.1 (classify-error (gensym 'aaa)) type-error) (deftest gensym.error.2 (classify-error (gensym 12.3)) type-error) (deftest gensym.error.3 (classify-error (gensym t)) type-error) (deftest gensym.error.4 (classify-error (gensym nil)) type-error) ;; NIL /= no argument! (deftest gensym.error.5 (classify-error (gensym '(a))) type-error) (deftest gensym.error.6 (classify-error (gensym #\x)) type-error) (deftest gensym.error.7 (classify-error (gensym 10 'foo)) program-error) (deftest gensym.error.8 (classify-error (locally (gensym t) t)) type-error) ;;;;;;;;;;;;;;;;;;;; ;;; Tests of CL package constraints from section 11.1.2.1.1 ;;; Check that all symbols listed as 'functions' or 'accessors' ;;; are indeed functions. (deftest cl-function-symbols.1 (loop for s in (append *cl-function-symbols* *cl-accessor-symbols*) when (or (not (fboundp s)) (macro-function s) (special-operator-p s) (not (symbol-function s))) collect s) nil) ;;; Check that all symols listed as 'macros' are macros. (deftest cl-macro-symbols.1 (loop for s in *cl-macro-symbols* when (or (not (fboundp s)) (not (macro-function s))) collect s) nil) ;;; Check that all constants are indeed constant (deftest cl-constant-symbols.1 (loop for s in *cl-constant-symbols* when (or (not (boundp s)) (not (constantp s))) collect s) nil) ;;; Check that all global variables have values (deftest cl-variable-symbols.1 (loop for s in *cl-variable-symbols* when (not (boundp s)) collect s) nil) ;;; Check that all types that are classes name classes. ;;; "Many but not all of the predefined type specifiers have ;;; a corresponding class with the same proper name as the type. ;;; These type specifiers are listed in Figure 4-8." -- section 4.3.7 (deftest cl-types-that-are-classes.1 ;; Collect class names that violate the condition in the ;; above quotation. (loop for s in *cl-types-that-are-classes-symbols* for c = (find-class s nil) unless (and c (eq (class-name c) s) (typep c 'class)) collect s) nil) (deftest cl-types-that-are-classes.2 ;; The same as cl-types-that-are-classes.1 ;; with an environment argument (loop for s in *cl-types-that-are-classes-symbols* for c = (find-class s nil nil) unless (and c (eq (class-name c) s) (typep c 'class)) collect s) nil) (deftest cl-types-that-are-classes.3 ;; The same as cl-types-that-are-classes.1, ;; with an environment argument (loop for s in *cl-types-that-are-classes-symbols* for c = (eval `(macrolet ((%foo (&environment env) (list 'quote (find-class ',s nil env)))) (%foo))) unless (and c (eq (class-name c) s) (typep c 'class)) collect s) nil) ;;; Various error cases for symbol-related functions (deftest symbolp.error.1 (classify-error (symbolp)) program-error) (deftest symbolp.error.2 (classify-error (symbolp nil nil)) program-error) (deftest symbol-function.error.1 (classify-error (symbol-function)) program-error) (deftest symbol-function.error.2 (classify-error (symbol-function 'cons nil)) program-error) (deftest symbol-package.error.1 (classify-error (symbol-package)) program-error) (deftest symbol-package.error.2 (classify-error (symbol-package 'cons nil)) program-error) (deftest symbol-plist.error.1 (classify-error (symbol-plist)) program-error) (deftest symbol-plist.error.2 (classify-error (symbol-plist 'cons nil)) program-error) (deftest symbol-value.error.1 (classify-error (symbol-value)) program-error) (deftest symbol-value.error.2 (classify-error (symbol-value '*package* nil)) program-error) gcl/ansi-tests/cl-test-package.lsp000066400000000000000000000005301242227143400174000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 14 10:13:21 1998 ;;;; Contains: CL test case package definition (defpackage :cl-test (:use :cl :regression-test) ;; #+gcl (:use defpackage) (:nicknames) (:import-from "COMMON-LISP-USER" #:compile-and-load "==>") (:export)) #+cmu (import 'cl::quit :cl-test) gcl/ansi-tests/cltest.system000066400000000000000000000050531242227143400164650ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Mar 27 09:57:28 1998 ;;;; Contains: MK portable system file for CL test suite ;;; NOTE!! This file is not being maintained right now. ;;; To run the test suite, load "gclload.lsp" (mk::defsystem "cltest" :source-pathname #.(directory-namestring *LOAD-TRUENAME*) :source-extension "lsp" :binary-pathname #.(mk::append-directories (directory-namestring *LOAD-TRUENAME*) "binary/") :binary-extension #+CMU #.(C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*) #+ALLEGRO "fasl" #+(OR AKCL GCL) "o" #+CLISP "fas" #-(OR CMU ALLEGRO AKCL GCL CLISP) #.(pathname-type (compile-file-pathname "foo.lisp")) :initially-do (progn (load "rt/rt.system") (mk::compile-system "rt")) :components ("cl-test-package" (:subsystem "cl-test-code" :source-pathname "" :binary-pathname "" :depends-on ("cl-test-package") :components ( "ansi-aux" "universe" "cons-test-01" "cons-test-02" "cons-test-03" "cons-test-04" "cons-test-05" "cons-test-06" "cons-test-07" "cons-test-08" "cons-test-09" "cons-test-10" "cons-test-11" "cons-test-12" "cons-test-13" "cons-test-14" "cons-test-15" "cons-test-16" "cons-test-17" "cons-test-18" "cons-test-19" "cons-test-20" "cons-test-21" "cons-test-22" "cons-test-23" "cons-test-24" "types-and-class" "cl-symbols" "cases-14-1-arrays" "cases-14-1-list" "reader-test" "packages-00" "packages-01" "packages-02" "packages-03" "packages-04" "packages-05" "packages-06" "packages-07" "packages-08" "packages-09" "packages-10" "packages-11" "packages-12" "packages-13" "packages-14" "packages-15" "packages-16" "packages-17" "packages-18" "fill-strings" "make-sequence" "map" "map-into" "reduce" "count" "count-if" "count-if-not" "reverse" "nreverse" "sort" "find" "find-if" "find-if-not" "position" "search-aux" "search-list" "search-vector" "search-bitvector" "search-string" "mismatch" "replace" "substitute" "substitute-if" "substitute-if-not" "nsubstitute" "nsubstitute-if" "nsubstitute-if-not" "concatenate" "merge" "remove" ;; need to extend these tests "structure-00" "structures-01" "structures-02" )))) gcl/ansi-tests/coerce.lsp000066400000000000000000000067311242227143400157050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Dec 13 20:48:04 2002 ;;;; Contains: Tests for COERCE (in-package :cl-test) (deftest coerce.1 (loop for x in *universe* for type = (type-of x) unless (and (consp type) (eqt (car type) 'function)) count (not (eq (coerce x type) x))) 0) (deftest coerce.2 (loop for x in *universe* count (not (eq (coerce x t) x))) 0) (deftest coerce.3 (loop for x in *universe* for class = (class-of x) count (and class (not (eq (coerce x class) x)))) 0) (deftest coerce.4 (loop for x in '(() #() #*) never (coerce x 'list)) t) (deftest coerce.5 (loop for x in '((1 0) #(1 0) #*10) always (equal (coerce x 'list) '(1 0))) t) (deftest coerce.6 (loop for x in '(() #() #*) always (equalp (coerce x 'vector) #())) t) (deftest coerce.7 (loop for x in '((1 0) #(1 0) #*10) for y = (coerce x 'vector) always (and (equalp y #(1 0)) (vectorp y))) t) (deftest coerce.8 (loop for x in '((1 0) #(1 0) #*10) for y = (coerce x '(vector *)) always (and (equalp y #(1 0)) (vectorp y))) t) (deftest coerce.9 (loop for x in '((1 0) #(1 0) #*10) for y = (coerce x '(vector * 2)) always (and (equalp y #(1 0)) (vectorp y))) t) (deftest coerce.10 (values (coerce #\A 'character) (coerce '|A| 'character) (coerce "A" 'character)) #\A #\A #\A) (deftest coerce.11 (loop with class = (find-class 'vector) for x in '((1 0) #(1 0) #*10) for y = (coerce x class) always (and (equalp y #(1 0)) (vectorp y))) t) (deftest coerce.12 (loop for x in '((1 0) #(1 0) #*10) for y = (coerce x 'bit-vector) always (and (equalp y #*10) (bit-vector-p y))) t) (deftest coerce.13 (loop for x in '((#\a #\b #\c) "abc") for y = (coerce x 'string) always (and (stringp y) (string= y "abc"))) t) (deftest coerce.14 (loop for x in '((#\a #\b #\c) "abc") for y = (coerce x 'simple-string) always (and (typep y 'simple-string) (string= y "abc"))) t) (deftest coerce.15 (loop for x in '((1 0) #(1 0) #*10) for y = (coerce x 'simple-vector) always (and (equalp y #(1 0)) (simple-vector-p y))) t) (deftest coerce.16 (coerce 0 'integer) 0) (deftest coerce.17 (coerce 0 'complex) 0) (deftest coerce.18 (coerce 3 'complex) 3) (deftest coerce.19 (coerce 5/3 'complex) 5/3) (deftest coerce.20 (coerce 1.0 'complex) #c(1.0 0.0)) (deftest coerce.21 (eqt (symbol-function 'car) (coerce 'car 'function)) t) (deftest coerce.22 (funcall (coerce '(lambda () 10) 'function)) 10) (deftest coerce.order.1 (let ((i 0) a b) (values (coerce (progn (setf a (incf i)) 10) (progn (setf b (incf i)) 'single-float)) i a b)) 10.0f0 2 1 2) ;;; Error tests ;;; (deftest coerce.error.1 ;;; (classify-error (coerce -1 '(integer 0 100))) ;;; type-error) (deftest coerce.error.2 (classify-error (coerce '(a b c) '(vector * 2))) type-error) (deftest coerce.error.3 (classify-error (coerce '(a b c) '(vector * 4))) type-error) (deftest coerce.error.4 (classify-error (coerce nil 'cons)) type-error) (deftest coerce.error.5 (handler-case (eval '(coerce 'not-a-bound-function 'function)) (error () :caught)) :caught) (deftest coerce.error.6 (classify-error (coerce)) program-error) (deftest coerce.error.7 (classify-error (coerce t)) program-error) (deftest coerce.error.8 (classify-error (coerce 'x t 'foo)) program-error) (deftest coerce.error.9 (classify-error (locally (coerce nil 'cons) t)) type-error) gcl/ansi-tests/compile-and-load.lsp000066400000000000000000000016301242227143400175430ustar00rootroot00000000000000(in-package :common-lisp-user) #+allegro (progn (setq *ignore-package-name-case* t) (when (eq excl:*current-case-mode* :case-sensitive-lower) (push :lower-case *features*))) (eval-when (load eval compile) (intern "==>" "CL-USER") (unless (fboundp 'compile-file-pathname) (defun compile-file-pathname (pathname) (make-pathname :defaults pathname :type "o")))) (defun compile-and-load (pathspec) "Find the file indicated by PATHSPEC, compiling it first if the associated compiled file is out of date." (let* ((pathname (pathname pathspec)) (compile-pathname (compile-file-pathname pathname)) (source-write-time (file-write-date pathname)) (target-write-time (and (probe-file compile-pathname) (file-write-date compile-pathname)))) (when (or (not target-write-time) (<= target-write-time source-write-time)) (compile-file pathname)) (load compile-pathname))) gcl/ansi-tests/compile.lsp000066400000000000000000000040471242227143400160730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 20:54:20 2002 ;;;; Contains: Tests for COMPILE, COMPILED-FUNCTION-P, COMPILED-FUNCTION (in-package :cl-test) (deftest compile.1 (progn (fmakunbound 'compile.1-fn) (values (defun compile.1-fn (x) x) (compiled-function-p 'compile.1-fn) (let ((x (compile 'compile.1-fn))) (or (eqt x 'compile.1-fn) (notnot (compiled-function-p x)))) (compiled-function-p 'compile.1-fn) (not (compiled-function-p #'compile.1-fn)) (fmakunbound 'compile.1-fn))) compile.1-fn nil t nil nil compile.1-fn) ;;; COMPILE returns three values (function, warnings-p, failure-p) (deftest compile.2 (let* ((results (multiple-value-list (compile nil '(lambda (x y) (cons y x))))) (fn (car results))) (values (length results) (funcall fn 'a 'b) (second results) (third results))) 3 (b . a) nil nil) ;;; Compile does not coalesce literal constants (deftest compile.3 (let ((x (list 'a 'b)) (y (list 'a 'b))) (and (not (eqt x y)) (funcall (compile nil `(lambda () (eqt ',x ',y)))))) nil) (deftest compile.4 (let ((x (copy-seq "abc")) (y (copy-seq "abc"))) (and (not (eqt x y)) (funcall (compile nil `(lambda () (eqt ,x ,y)))))) nil) (deftest compile.5 (let ((x (copy-seq "abc"))) (funcall (compile nil `(lambda () (eqt ,x ,x))))) t) (deftest compile.6 (let ((x (copy-seq "abc"))) (funcall (compile nil `(lambda () (eqt ',x ',x))))) t) (deftest compile.7 (let ((x (copy-seq "abc"))) (eqt x (funcall (compile nil `(lambda () ,x))))) t) (deftest compile.8 (let ((x (list 'a 'b))) (eqt x (funcall (compile nil `(lambda () ',x))))) t) (deftest compile.9 (let ((i 0) a b) (values (funcall (compile (progn (setf a (incf i)) nil) (progn (setf b (incf i)) '(lambda () 'z)))) i a b)) z 2 1 2) (deftest compile.error.1 (classify-error (compile)) program-error) (deftest compile.error.2 (classify-error (compile nil '(lambda () nil) 'garbage)) program-error) gcl/ansi-tests/compiled-function-p.lsp000066400000000000000000000016241242227143400203150ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 16:32:44 2003 ;;;; Contains: Tests of COMPILED-FUNCTION-P (in-package :cl-test) (deftest compiled-function-p.1 (some #'(lambda (obj) (if (check-values (compiled-function-p obj)) (not (typep obj 'compiled-function)) (typep obj 'compiled-function))) *universe*) nil) (deftest compiled-function-p.2 (compiled-function-p '(lambda (x y) (cons y x))) nil) (deftest compiled-function-p.3 (notnot-mv (compiled-function-p (compile nil '(lambda (y x) (cons x y))))) t) (deftest compiled-function-p.order.1 (let ((i 0)) (values (compiled-function-p (progn (incf i) '(lambda () nil))) i)) nil 1) (deftest compiled-function-p.error.1 (classify-error (compiled-function-p)) program-error) (deftest compiled-function-p.error.2 (classify-error (compiled-function-p nil nil)) program-error) gcl/ansi-tests/compiler-macros.lsp000066400000000000000000000003011242227143400175240ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 18:51:30 2003 ;;;; Contains: Tests for compiler macros (in-package :cl-test) ;;; Compiler macro tests will go here gcl/ansi-tests/complement.lsp000066400000000000000000000023401242227143400166000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 6 20:04:33 2002 ;;;; Contains: Tests for COMPLEMENT (in-package :cl-test) (deftest complement.1 (notnot-mv (funcall (complement #'identity) nil)) t) (deftest complement.2 (funcall (complement #'identity) t) nil) (deftest complement.3 (every #'(lambda (x) (eql (funcall (cl::complement #'not) x) (not (not x)))) *universe*) t) (deftest complement.4 (let ((x '(#\b))) (loop for i from 2 to (min 256 (1- call-arguments-limit)) always (progn (push #\a x) (apply (complement #'char=) x)))) t) (deftest complement.5 (notnot-mv (complement #'identity)) t) (deftest complement.order.1 (let ((i 0)) (let ((fn (complement (progn (incf i) #'null)))) (values i (mapcar fn '(a b nil c 1 nil t nil)) i))) 1 (t t nil t t nil t nil) 1) (deftest complement.error.1 (classify-error (complement)) program-error) (deftest complement.error.2 (classify-error (complement #'not t)) program-error) (deftest complement.error.3 (classify-error (funcall (complement #'identity))) program-error) (deftest complement.error.4 (classify-error (funcall (complement #'identity) t t)) program-error) gcl/ansi-tests/concatenate.lsp000066400000000000000000000122221242227143400167210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Sep 4 22:53:51 2002 ;;;; Contains: Tests for CONCATENATE (in-package :cl-test) (deftest concatenate.1 (concatenate 'list) nil) (deftest concatenate.2 (let* ((orig (list 'a 'b 'c 'd 'e)) (copy (concatenate 'list orig))) (values copy (intersection (loop for e on orig collect e) (loop for e on copy collect e) :test #'eq))) (a b c d e) nil) (deftest concatenate.3 (concatenate 'list "") nil) (deftest concatenate.4 (concatenate 'list "abcd" '(x y z) nil #*1101 #()) (#\a #\b #\c #\d x y z 1 1 0 1)) (deftest concatenate.5 (concatenate 'vector) #()) (deftest concatenate.6 (concatenate 'vector nil "abcd" '(x y z) nil #*1101 #()) #(#\a #\b #\c #\d x y z 1 1 0 1)) (deftest concatenate.7 (let* ((orig (vector 'a 'b 'c 'd 'e)) (copy (concatenate 'vector orig))) (values copy (eqt copy orig))) #(a b c d e) nil) (deftest concatenate.8 (concatenate 'simple-vector '(a b c) #(1 2 3)) #(a b c 1 2 3)) (deftest concatenate.9 (concatenate 'simple-vector) #()) (deftest concatenate.10 (concatenate 'bit-vector nil) #*) (deftest concatenate.11 (concatenate 'bit-vector) #*) (deftest concatenate.12 (concatenate 'bit-vector '(0 1 1) nil #(1 0 1) #()) #*011101) (deftest concatenate.13 (concatenate 'simple-bit-vector nil) #*) (deftest concatenate.14 (concatenate 'simple-bit-vector) #*) (deftest concatenate.15 (concatenate 'simple-bit-vector '(0 1 1) nil #(1 0 1) #()) #*011101) (deftest concatenate.16 (concatenate 'string "abc" '(#\d #\e) nil #() "fg") "abcdefg") (deftest concatenate.17 (concatenate 'simple-string "abc" '(#\d #\e) nil #() "fg") "abcdefg") (deftest concatenate.18 (concatenate '(vector * *) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.19 (concatenate '(vector * 8) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.20 (concatenate '(vector symbol 8) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.21 (concatenate '(vector symbol) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.22 (concatenate '(vector symbol *) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.23 (concatenate 'cons '(a b c) '(d e f)) (a b c d e f)) (deftest concatenate.24 (concatenate 'null nil nil) nil) ;;; Tests on vectors with fill pointers (deftest concatenate.25 (let ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) :fill-pointer 5))) (concatenate 'list x x)) (a b c d e a b c d e)) (deftest concatenate.26 (let ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) :fill-pointer 5))) (concatenate 'list x)) (a b c d e)) (deftest concatenate.27 (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) :fill-pointer 5)) (result (concatenate 'vector x))) (values (not (simple-vector-p result)) result)) nil #(a b c d e)) (deftest concatenate.28 (let* ((x (make-array '(10) :initial-contents "abcdefghij" :fill-pointer 5 :element-type 'character))) (values (concatenate 'string x '(#\z)) (concatenate 'string '(#\z) x) (concatenate 'string x x) (concatenate 'string x) (not (simple-string-p (concatenate 'string x))) )) "abcdez" "zabcde" "abcdeabcde" "abcde" nil) (deftest concatenate.29 (let* ((x (make-array '(10) :initial-contents "abcdefghij" :fill-pointer 5 :element-type 'base-char))) (values (concatenate 'string x '(#\z)) (concatenate 'string '(#\z) x) (concatenate 'string x x) (concatenate 'string x) (not (simple-string-p (concatenate 'string x))) )) "abcdez" "zabcde" "abcdeabcde" "abcde" nil) (deftest concatenate.30 (let* ((x (make-array '(10) :initial-contents #*0110010111 :fill-pointer 5 :element-type 'bit))) (values (concatenate 'bit-vector x '(0)) (concatenate 'bit-vector '(0) x) (concatenate 'bit-vector x x) (concatenate 'bit-vector x) (not (simple-bit-vector-p (concatenate 'bit-vector x))) )) #*011000 #*001100 #*0110001100 #*01100 nil) (deftest concatenate.order.1 (let ((i 0) w x y z) (values (concatenate (progn (setf w (incf i)) 'string) (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "def") (progn (setf z (incf i)) "ghi")) i w x y z)) "abcdefghi" 4 1 2 3 4) (deftest concatenate.order.2 (let ((i 0) x y z) (values (concatenate 'string (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "def") (progn (setf z (incf i)) "ghi")) i x y z)) "abcdefghi" 3 1 2 3) ;;; Error tests (deftest concatenate.error.1 (subtypep* (classify-error (concatenate 'sequence '(a b c))) 'error) t t) (deftest concatenate.error.2 (subtypep* (classify-error (concatenate 'fixnum '(a b c d e))) 'error) t t) (deftest concatenate.error.3 (classify-error (concatenate '(vector * 3) '(a b c d e))) type-error) (deftest concatenate.error.4 (classify-error (concatenate)) program-error) (deftest concatenate.error.5 (classify-error (locally (concatenate '(vector * 3) '(a b c d e)) t)) type-error) gcl/ansi-tests/cond.lsp000066400000000000000000000017271242227143400153700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 07:37:58 2002 ;;;; Contains: Tests of COND (in-package :cl-test) (deftest cond.1 (cond) nil) (deftest cond.2 (cond ('a)) a) (deftest cond.3 (cond (nil)) nil) (deftest cond.4 (cond (nil 'a) (nil 'b)) nil) (deftest cond.5 (cond (nil 'a) ('b)) b) (deftest cond.6 (cond (t 'a) (t 'b)) a) (deftest cond.7 (let ((x 0)) (values (cond ((progn (incf x) nil) 'a) (t 'b) ((incf x) 'c)) x)) b 1) (deftest cond.8 (let ((x 0)) (values (cond (nil (incf x) 'a) (nil (incf x 10) 'b) (t (incf x 2) 'c) (t (incf x 100) 'd)) x)) c 2) (deftest cond.9 (cond ((values 'a 'b 'c))) a) (deftest cond.10 (cond (t (values 'a 'b 'c))) a b c) (deftest cond.11 (cond ((values nil t) 'a) (t 'b)) b) (deftest cond.12 (cond ((values))) nil) (deftest cond.13 (cond ((values)) (t 'a)) a) (deftest cond.14 (cond (t (values)))) gcl/ansi-tests/condition.lsp000066400000000000000000000052121242227143400164240ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 27 22:13:25 2003 ;;;; Contains: Tests of class CONDITION (in-package :cl-test) (deftest condition.1 (notnot-mv (find-class 'condition nil)) t) (defparameter *allowed-condition-inclusions* '( (arithmetic-error error serious-condition condition) (cell-error error serious-condition condition) (condition) (control-error error serious-condition condition) (division-by-zero arithmetic-error error serious-condition condition) (end-of-file stream-error error serious-condition condition) (error serious-condition condition) (file-error error serious-condition condition) (floating-point-inexact arithmetic-error error serious-condition condition) (floating-point-invalid-operation arithmetic-error error serious-condition condition) (floating-point-overflow arithmetic-error error serious-condition condition) (floating-point-underflow arithmetic-error error serious-condition condition) (package-error error serious-condition condition) (parse-error error serious-condition condition) (print-not-readable error serious-condition condition) (program-error error serious-condition condition) (reader-error parse-error stream-error error serious-condition condition) (serious-condition condition) (simple-condition condition) (simple-error simple-condition error serious-condition condition) (simple-type-error simple-condition type-error error serious-condition condition) (simple-warning simple-condition warning condition) (storage-condition serious-condition condition) (stream-error error serious-condition condition) (style-warning warning condition) (type-error error serious-condition condition) (unbound-slot cell-error error serious-condition condition) (unbound-variable cell-error error serious-condition condition) (undefined-function cell-error error serious-condition condition) (warning condition) )) ;;; Relationships given in *allowed-condition-inclusions* are the only ;;; subtype relationships allowed on condition types (deftest condition.2 (loop for (cnd . supers) in *allowed-condition-inclusions* append (loop for super in supers unless (subtypep cnd super) collect (list cnd super))) nil) (deftest condition.3 ;; Relationships given in *allowed-condition-inclusions* are the only ;; subtype relationships allowed on condition types (loop for cnds in *allowed-condition-inclusions* for cnd = (first cnds) append (loop for super in (set-difference *condition-types* cnds) when (subtypep cnd super) collect (list cnd super))) nil) gcl/ansi-tests/cons-test-01.lsp000066400000000000000000000202171242227143400165750ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:29:48 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 1 (in-package :cl-test) (declaim (optimize (safety 3))) ;; ;; Test the subtype relationships between null, list, cons and atom ;; (deftest subtypep-null-list (subtypep* 'null 'list) t t) (deftest subtypep-cons-list (subtypep* 'cons 'list) t t) (deftest subtypep-null-cons (subtypep* 'null 'cons) nil t) (deftest subtypep-cons-null (subtypep* 'cons 'null) nil t) (deftest subtypep-null-atom (subtypep* 'null 'atom) t t) (deftest subtypep-cons-atom (subtypep* 'cons 'atom) nil t) (deftest subtypep-atom-cons (subtypep* 'atom 'cons) nil t) (deftest subtypep-atom-list (subtypep* 'atom 'list) nil t) (deftest subtypep-list-atom (subtypep* 'list 'atom) nil t) ;; ;; Check that the elements of *universe* in type null ;; are those for which the null predice is true. ;; (deftest null-null-universe (check-type-predicate 'null 'null) 0) (defvar *cons-fns* (list 'cons 'consp 'atom 'rplaca 'rplacd 'car 'cdr 'caar 'cadr 'cdar 'cddr 'caaar 'caadr 'cadar 'caddr 'cdaar 'cdadr 'cddar 'cdddr 'caaaar 'caaadr 'caadar 'caaddr 'cadaar 'cadadr 'caddar 'cadddr 'cdaaar 'cdaadr 'cdadar 'cdaddr 'cddaar 'cddadr 'cdddar 'cddddr 'copy-tree 'sublis 'nsublis 'subst 'subst-if 'subst-if-not 'nsubst 'nsubst-if 'nsubst-if-not 'tree-equal 'copy-list 'list 'list* 'list-length 'listp 'make-list 'first 'second 'third 'fourth 'fifth 'sixth 'seventh 'eighth 'ninth 'tenth 'nth 'endp 'null 'nconc 'append 'revappend 'nreconc 'butlast 'nbutlast 'last 'ldiff 'tailp 'nthcdr 'rest 'member 'member-if 'member-if-not 'mapc 'mapcar 'mapcan 'mapl 'maplist 'mapcon 'acons 'assoc 'assoc-if 'assoc-if-not 'copy-alist 'pairlis 'rassoc 'rassoc-if 'rassoc-if-not 'get-properties 'getf 'intersection 'nintersection 'adjoin 'set-difference 'nset-difference 'set-exclusive-or 'nset-exclusive-or 'subsetp 'union 'nunion )) ;; All the cons functions have a function binding (deftest function-bound-cons-fns (loop for x in *cons-fns* count (when (or (not (fboundp x)) (not (functionp (symbol-function x)))) (format t "~%~S not bound to a function" x) t)) 0) ;; All the cons-related macros have a macro binding (deftest macro-bound-cons-macros (notnot-mv (every #'macro-function (list 'push 'pop 'pushnew 'remf))) t) ;; None of the cons-related functions have macro bindings (deftest no-cons-fns-are-macros (some #'macro-function *cons-fns*) nil) ;; Various easy tests of cons (deftest cons-of-symbols (cons 'a 'b) (a . b)) (deftest cons-with-nil (cons 'a nil) (a)) ;; successive calls to cons produces results that are equal, but not eq (deftest cons-eq-equal (let ((x (cons 'a 'b)) (y (cons 'a 'b))) (and (not (eqt x y)) (equalt x y))) t) ;; list can be expressed as a bunch of conses (with nil) (deftest cons-equal-list (equalt (cons 'a (cons 'b (cons 'c nil))) (list 'a 'b 'c)) t) ;;; Order of evaluation of cons arguments (deftest cons.order.1 (let ((i 0)) (values (cons (incf i) (incf i)) i)) (1 . 2) 2) ;; Lists satisfy consp (deftest consp-list (notnot-mv (consp '(a))) t) ;; cons satisfies consp (deftest consp-cons (notnot-mv (consp (cons nil nil))) t) ;; nil is not a consp (deftest consp-nil (consp nil) nil) ;; The empty list is not a cons (deftest consp-empty-list (consp (list)) nil) ;; A single element list is a cons (deftest consp-single-element-list (notnot-mv (consp (list 'a))) t) ;; For everything in *universe*, it is either an atom, or satisfies ;; consp, but not both (deftest consp-xor-atom-universe (notnot-mv (every #'(lambda (x) (or (and (consp x) (not (atom x))) (and (not (consp x)) (atom x)))) *universe*)) t) ;; Everything in type cons satisfies consp, and vice versa (deftest consp-cons-universe (check-type-predicate 'consp 'cons) 0) (deftest consp.order.1 (let ((i 0)) (values (consp (incf i)) i)) nil 1) (deftest consp.error.1 (classify-error (consp)) program-error) (deftest consp.error.2 (classify-error (consp 'a 'b)) program-error) (deftest atom.order.1 (let ((i 0)) (values (atom (progn (incf i) '(a b))) i)) nil 1) (deftest atom.error.1 (classify-error (atom)) program-error) (deftest atom.error.2 (classify-error (atom 'a 'b)) program-error) ;; Tests of car, cdr and compound forms (deftest cons.23 (car '(a)) a) (deftest cons.24 (cdr '(a . b)) b) (deftest cons.25 (caar '((a))) a) (deftest cons.26 (cdar '((a . b))) b) (deftest cons.27 (cadr '(a b)) b) (deftest cons.28 (cddr '(a b . c)) c) (deftest cons.29 (caaar '(((a)))) a) (deftest cons.30 (cdaar '(((a . b)))) b) (deftest cons.31 (cadar (cons (cons 'a (cons 'b 'c)) 'd)) b) (deftest cons.32 (cddar (cons (cons 'a (cons 'b 'c)) 'd)) c) (deftest cons.33 (caadr (cons 'a (cons (cons 'b 'c) 'd))) b) (deftest cons.34 (caddr (cons 'a (cons 'b (cons 'c 'd)))) c) (deftest cons.36 (cdadr (cons 'a (cons (cons 'b 'c) 'd))) c) (deftest cons.37 (cdddr (cons 'a (cons 'b (cons 'c 'd)))) d) (defvar *cons-test-4* (cons (cons (cons (cons 'a 'b) (cons 'c 'd)) (cons (cons 'e 'f) (cons 'g 'h))) (cons (cons (cons 'i 'j) (cons 'k 'l)) (cons (cons 'm 'n) (cons 'o 'p))))) (deftest cons.38 (caaaar *cons-test-4*) a) (deftest cons.39 (cdaaar *cons-test-4*) b) (deftest cons.40 (cadaar *cons-test-4*) c) (deftest cons.41 (cddaar *cons-test-4*) d) (deftest cons.42 (caadar *cons-test-4*) e) (deftest cons.43 (cdadar *cons-test-4*) f) (deftest cons.44 (caddar *cons-test-4*) g) (deftest cons.45 (cdddar *cons-test-4*) h) ;;; (deftest cons.46 (caaadr *cons-test-4*) i) (deftest cons.47 (cdaadr *cons-test-4*) j) (deftest cons.48 (cadadr *cons-test-4*) k) (deftest cons.49 (cddadr *cons-test-4*) l) (deftest cons.50 (caaddr *cons-test-4*) m) (deftest cons.51 (cdaddr *cons-test-4*) n) (deftest cons.52 (cadddr *cons-test-4*) o) (deftest cons.53 (cddddr *cons-test-4*) p) (deftest cons.error.1 (classify-error (cons)) program-error) (deftest cons.error.2 (classify-error (cons 'a)) program-error) (deftest cons.error.3 (classify-error (cons 'a 'b 'c)) program-error) ;; Test rplaca, rplacd (deftest rplaca.1 (let ((x (cons 'a 'b))) (let ((y x)) (and (eqt (rplaca x 'c) y) (eqt x y) (eqt (car x) 'c) (eqt (cdr x) 'b)))) t) (deftest rplaca.order.1 (let ((x (cons 'a 'b)) (i 0) a b) (values (rplaca (progn (setf a (incf i)) x) (progn (setf b (incf i)) 'c)) i a b)) (c . b) 2 1 2) (deftest rplacd.1 (let ((x (cons 'a 'b))) (let ((y x)) (and (eqt (rplacd x 'd) y) (eqt x y) (eqt (car x) 'a) (eqt (cdr x) 'd)))) t) (deftest rplacd.order.1 (let ((x (cons 'a 'b)) (i 0) a b) (values (rplacd (progn (setf a (incf i)) x) (progn (setf b (incf i)) 'c)) i a b)) (a . c) 2 1 2) ;; rplaca on a fixnum is a type error (deftest rplaca.error.1 (loop for x in *universe* thereis (and (not (consp x)) (not (eq (catch-type-error (rplaca x 1)) 'type-error)))) nil) (deftest rplaca.error.2 (classify-error (rplaca)) program-error) (deftest rplaca.error.3 (classify-error (rplaca (cons 'a 'b))) program-error) (deftest rplaca.error.4 (classify-error (rplaca (cons 'a 'b) (cons 'c 'd) 'garbage)) program-error) (deftest rplaca.error.5 (classify-error (rplaca 'a 1)) type-error) (deftest rplaca.error.6 (classify-error (locally (rplaca 'a 1) t)) type-error) ;; rplacd on a fixnum is a type error (deftest rplacd.error.1 (loop for x in *universe* thereis (and (not (consp x)) (not (eq (catch-type-error (rplacd x 1)) 'type-error)))) nil) (deftest rplacd.error.2 (classify-error (rplacd)) program-error) (deftest rplacd.error.3 (classify-error (rplacd (cons 'a 'b))) program-error) (deftest rplacd.error.4 (classify-error (rplacd (cons 'a 'b) (cons 'c 'd) 'garbage)) program-error) (deftest rplacd.error.5 (classify-error (rplacd 'a 1)) type-error) (deftest rplacd.error.6 (classify-error (locally (rplacd 'a 1) t)) type-error) gcl/ansi-tests/cons-test-02.lsp000066400000000000000000000637671242227143400166170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:30:50 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 2 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; copy-tree ;; Try copy-tree on a tree containing elements of various kinds (deftest copy-tree.1 (let ((x (cons 'a (list (cons 'b 'c) (cons 1 1.2) (list (list "abcde" (make-array '(10) :initial-element (cons 'e 'f))) 'g))))) (let ((y (copy-tree x))) (check-cons-copy x y))) t) ;; Try copy-tree on *universe* (deftest copy-tree.2 (let* ((x (copy-list *universe*)) (y (copy-tree x))) (check-cons-copy x y)) t) (deftest copy-tree.order.1 (let ((i 0)) (values (copy-tree (progn (incf i) '(a b c))) i)) (a b c) 1) (deftest copy-tree.error.1 (classify-error (copy-tree)) program-error) (deftest copy-tree.error.2 (classify-error (copy-tree 'a 'b)) program-error) ;;; (deftest sublis.1 (check-sublis '((a b) g (d e 10 g h) 15 . g) '((e . e2) (g . 17))) ((a b) 17 (d e2 10 17 h) 15 . 17)) (deftest sublis.2 (check-sublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) :test #'equal) (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) (deftest sublis.3 (check-sublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) '((30 . "foo"))) (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) (deftest sublis.4 (check-sublis (sublis (copy-tree '((a . 2) (b . 4) (c . 1))) (copy-tree '(a b c d e (a b c a d b) f))) '((t . "yes")) :key #'(lambda (x) (and (typep x 'integer) (evenp x)))) ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) (deftest sublis.5 (check-sublis '("fee" (("fee" "Fie" "foo")) fie ("fee" "fie")) `((,(copy-seq "fie") . #\f))) ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) (deftest sublis.6 (check-sublis '("fee" fie (("fee" "Fie" "foo") 1) ("fee" "fie")) `((,(copy-seq "fie") . #\f)) :test 'equal) ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) (deftest sublis.7 (check-sublis '(("aa" a b) (z "bb" d) ((x . "aa"))) `((,(copy-seq "aa") . 1) (,(copy-seq "bb") . 2)) :test 'equal :key #'(lambda (x) (if (consp x) (car x) '*not-present*))) (1 (z . 2) ((x . "aa")))) ;; Check that a null key arg is ignored. (deftest sublis.8 (check-sublis '(1 2 a b) '((1 . 2) (a . b)) :key nil) (2 2 b b)) ;;; Order of argument evaluation (deftest sublis.order.1 (let ((i 0) w x y z) (values (sublis (progn (setf w (incf i)) '((a . z))) (progn (setf x (incf i)) (copy-tree '(a b c d))) :test (progn (setf y (incf i)) #'eql) :key (progn (setf z (incf i)) #'identity)) i w x y z)) (z b c d) 4 1 2 3 4) (deftest sublis.order.2 (let ((i 0) w x y z) (values (sublis (progn (setf w (incf i)) '((a . z))) (progn (setf x (incf i)) (copy-tree '(a b c d))) :key (progn (setf y (incf i)) #'identity) :test-not (progn (setf z (incf i)) (complement #'eql)) ) i w x y z)) (z b c d) 4 1 2 3 4) ;;; Keyword tests (deftest sublis.allow-other-keys.1 (sublis nil 'a :bad t :allow-other-keys t) a) (deftest sublis.allow-other-keys.2 (sublis nil 'a :allow-other-keys t :bad t) a) (deftest sublis.allow-other-keys.3 (sublis nil 'a :allow-other-keys t) a) (deftest sublis.allow-other-keys.4 (sublis nil 'a :allow-other-keys nil) a) (deftest sublis.allow-other-keys.5 (sublis nil 'a :allow-other-keys t :allow-other-keys t :bad t) a) (deftest sublis.keywords.6 (sublis '((1 . a)) (list 0 1 2) :key #'(lambda (x) (if (numberp x) (1+ x) x)) :key #'identity) (a 1 2)) ;; Argument error cases (deftest sublis.error.1 (classify-error (sublis)) program-error) (deftest sublis.error.2 (classify-error (sublis nil)) program-error) (deftest sublis.error.3 (classify-error (sublis nil 'a :test)) program-error) (deftest sublis.error.4 (classify-error (sublis nil 'a :bad-keyword t)) program-error) (deftest sublis.error.5 (classify-error (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test #'identity)) program-error) (deftest sublis.error.6 (classify-error (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :key #'cons)) program-error) (deftest sublis.error.7 (classify-error (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test-not #'identity)) program-error) ;; nsublis (deftest nsublis.1 (check-nsublis '((a b) g (d e 10 g h) 15 . g) '((e . e2) (g . 17))) ((a b) 17 (d e2 10 17 h) 15 . 17)) (deftest nsublis.2 (check-nsublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) :test #'equal) (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) (deftest nsublis.3 (check-nsublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) '((30 . "foo"))) (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) (deftest nsublis.4 (check-nsublis (nsublis (copy-tree '((a . 2) (b . 4) (c . 1))) (copy-tree '(a b c d e (a b c a d b) f))) '((t . "yes")) :key #'(lambda (x) (and (typep x 'integer) (evenp x)))) ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) (deftest nsublis.5 (check-nsublis '("fee" (("fee" "Fie" "foo")) fie ("fee" "fie")) `((,(copy-seq "fie") . #\f))) ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) (deftest nsublis.6 (check-nsublis '("fee" fie (("fee" "Fie" "foo") 1) ("fee" "fie")) `((,(copy-seq "fie") . #\f)) :test 'equal) ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) (deftest nsublis.7 (check-nsublis '(("aa" a b) (z "bb" d) ((x . "aa"))) `((,(copy-seq "aa") . 1) (,(copy-seq "bb") . 2)) :test 'equal :key #'(lambda (x) (if (consp x) (car x) '*not-present*))) (1 (z . 2) ((x . "aa")))) (deftest nsublis.8 (nsublis nil 'a :bad-keyword t :allow-other-keys t) a) ;; Check that a null key arg is ignored. (deftest nsublis.9 (check-nsublis '(1 2 a b) '((1 . 2) (a . b)) :key nil) (2 2 b b)) ;;; Order of argument evaluation (deftest nsublis.order.1 (let ((i 0) w x y z) (values (nsublis (progn (setf w (incf i)) '((a . z))) (progn (setf x (incf i)) (copy-tree '(a b c d))) :test (progn (setf y (incf i)) #'eql) :key (progn (setf z (incf i)) #'identity)) i w x y z)) (z b c d) 4 1 2 3 4) (deftest nsublis.order.2 (let ((i 0) w x y z) (values (nsublis (progn (setf w (incf i)) '((a . z))) (progn (setf x (incf i)) (copy-tree '(a b c d))) :key (progn (setf y (incf i)) #'identity) :test-not (progn (setf z (incf i)) (complement #'eql)) ) i w x y z)) (z b c d) 4 1 2 3 4) ;;; Keyword tests (deftest nsublis.allow-other-keys.1 (nsublis nil 'a :bad t :allow-other-keys t) a) (deftest nsublis.allow-other-keys.2 (nsublis nil 'a :allow-other-keys t :bad t) a) (deftest nsublis.allow-other-keys.3 (nsublis nil 'a :allow-other-keys t) a) (deftest nsublis.allow-other-keys.4 (nsublis nil 'a :allow-other-keys nil) a) (deftest nsublis.allow-other-keys.5 (nsublis nil 'a :allow-other-keys t :allow-other-keys t :bad t) a) (deftest nsublis.keywords.6 (nsublis '((1 . a)) (list 0 1 2) :key #'(lambda (x) (if (numberp x) (1+ x) x)) :key #'identity) (a 1 2)) ;; Argument error cases (deftest nsublis.error.1 (classify-error (nsublis)) program-error) (deftest nsublis.error.2 (classify-error (nsublis nil)) program-error) (deftest nsublis.error.3 (classify-error (nsublis nil 'a :test)) program-error) (deftest nsublis.error.4 (classify-error (nsublis nil 'a :bad-keyword t)) program-error) (deftest nsublis.error.5 (classify-error (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test #'identity)) program-error) (deftest nsublis.error.6 (classify-error (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :key #'cons)) program-error) (deftest nsublis.error.7 (classify-error (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test-not #'identity)) program-error) ;;;;;; (deftest sublis.shared (let* ((shared-piece (list 'a 'b)) (a (list shared-piece shared-piece))) (check-sublis a '((a . b) (b . a)))) ((b a) (b a))) (defvar *subst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) (deftest subst.1 (check-subst "Z" 30 (copy-tree *subst-tree-1*)) (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) (deftest subst.2 (check-subst "A" 0 (copy-tree *subst-tree-1*)) (10 (30 20 10) (20 10) (10 20 30 40))) (deftest subst.3 (check-subst "Z" 100 (copy-tree *subst-tree-1*) :test-not #'eql) "Z") (deftest subst.4 (check-subst 'grape 'dick '(melville wrote (moby dick))) (melville wrote (moby grape))) (deftest subst.5 (check-subst 'cha-cha-cha 'nil '(melville wrote (moby dick))) (melville wrote (moby dick . cha-cha-cha) . cha-cha-cha)) (deftest subst.6 (check-subst '(1 2) '(foo . bar) '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) :test #'equal) ((foo . baz) (1 2) (bar . foo) (baz 1 2))) (deftest subst.7 (check-subst 'foo "aaa" '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) :key #'(lambda (x) (if (and (numberp x) (evenp x)) "aaa" nil)) :test #'string=) ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) (deftest subst.8 (check-subst 'foo nil '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) :key #'(lambda (x) (if (and (numberp x) (evenp x)) (copy-seq "aaa") nil)) :test-not #'equal) ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) (deftest subst.9 (check-subst 'a 'b (copy-tree '(a b c d a b)) :key nil) (a a c d a a)) ;;; Order of argument evaluation (deftest subst.order.1 (let ((i 0) v w x y z) (values (subst (progn (setf v (incf i)) 'b) (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) :key (progn (setf y (incf i)) #'identity) :test (progn (setf z (incf i)) #'eql)) i v w x y z)) ((10 b . b) b b c ((b)) z) 5 1 2 3 4 5) (deftest subst.order.2 (let ((i 0) v w x y z) (values (subst (progn (setf v (incf i)) 'b) (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) :test-not (progn (setf y (incf i)) (complement #'eql)) :key (progn (setf z (incf i)) #'identity) ) i v w x y z)) ((10 b . b) b b c ((b)) z) 5 1 2 3 4 5) ;;; Keyword tests for subst (deftest subst.allow-other-keys.1 (subst 'a 'b (list 'a 'b 'c) :bad t :allow-other-keys t) (a a c)) (deftest subst.allow-other-keys.2 (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t) (a a c)) (deftest subst.allow-other-keys.3 (subst 'a 'b (list 'a 'b 'c) :allow-other-keys nil) (a a c)) (deftest subst.allow-other-keys.4 (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t :bad t) (a a c)) (deftest subst.allow-other-keys.5 (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil :bad t) (a a c)) (deftest subst.keywords.6 (subst 'a 'b (list 'a 'b 'c) :test #'eq :test (complement #'eq)) (a a c)) ;;; Tests for subst-if, subst-if-not (deftest subst-if.1 (check-subst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) a) (deftest subst-if-not.1 (check-subst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) ((x) ((x) (x) x) ((x) (x) (x) x) ((x) (x) (x) (x) x) x)) (deftest subst-if.2 (check-subst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) (17 (17 17) (17 17 17) (17 nil 17 17 17))) (deftest subst-if.3 (check-subst-if '(z) (complement #'consp) '(a (a b) (c d e) (f g h i))) ((z) ((z) (z) z) ((z) (z) (z) z) ((z) (z) (z) (z) z) z)) (deftest subst-if-not.2 (check-subst-if-not 'a (complement #'listp) '((100 1) (2 3) (4 3 2 1) (a b c))) a) (deftest subst-if.4 (check-subst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) :key #'listp) b) (deftest subst-if-not.3 (check-subst-if-not 'c #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) :key (complement #'listp)) c) (deftest subst-if.5 (check-subst-if 4 #'(lambda (x) (eql x 1)) '((1 3) (1) (1 10 20 30) (1 3 x y)) :key #'(lambda (x) (and (consp x) (car x)))) (4 4 4 4)) (deftest subst-if-not.4 (check-subst-if-not 40 #'(lambda (x) (not (eql x 17))) '((17) (17 22) (17 22 31) (17 21 34 54)) :key #'(lambda (x) (and (consp x) (car x)))) (40 40 40 40)) (deftest subst-if.6 (check-subst-if 'a #'(lambda (x) (eql x 'b)) '((a) (b) (c) (d)) :key nil) ((a) (a) (c) (d))) (deftest subst-if-not.5 (check-subst-if-not 'a #'(lambda (x) (not (eql x 'b))) '((a) (b) (c) (d)) :key nil) ((a) (a) (c) (d))) (deftest subst-if.7 (let ((i 0) w x y z) (values (subst-if (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) (progn (setf y (incf i)) (copy-list '(1 2 a b c))) :key (progn (setf z (incf i)) #'identity)) i w x y z)) (1 2 a a c) 4 1 2 3 4) (deftest subst-if-not.7 (let ((i 0) w x y z) (values (subst-if-not (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) (progn (setf y (incf i)) (copy-list '(1 2 a b c))) :key (progn (setf z (incf i)) #'identity)) i w x y z)) (1 2 a a c) 4 1 2 3 4) ;;; Keyword tests for subst-if (deftest subst-if.allow-other-keys.1 (subst-if 'a #'null nil :bad t :allow-other-keys t) a) (deftest subst-if.allow-other-keys.2 (subst-if 'a #'null nil :allow-other-keys t) a) (deftest subst-if.allow-other-keys.3 (subst-if 'a #'null nil :allow-other-keys nil) a) (deftest subst-if.allow-other-keys.4 (subst-if 'a #'null nil :allow-other-keys t :bad t) a) (deftest subst-if.allow-other-keys.5 (subst-if 'a #'null nil :allow-other-keys t :allow-other-keys nil :bad t) a) (deftest subst-if.keywords.6 (subst-if 'a #'null nil :key nil :key (constantly 'b)) a) ;;; Keywords tests for subst-if-not (deftest subst-if-not.allow-other-keys.1 (subst-if-not 'a #'identity nil :bad t :allow-other-keys t) a) (deftest subst-if-not.allow-other-keys.2 (subst-if-not 'a #'identity nil :allow-other-keys t) a) (deftest subst-if-not.allow-other-keys.3 (subst-if-not 'a #'identity nil :allow-other-keys nil) a) (deftest subst-if-not.allow-other-keys.4 (subst-if-not 'a #'identity nil :allow-other-keys t :bad t) a) (deftest subst-if-not.allow-other-keys.5 (subst-if-not 'a #'identity nil :allow-other-keys t :allow-other-keys nil :bad t) a) (deftest subst-if-not.keywords.6 (subst-if-not 'a #'identity nil :key nil :key (constantly 'b)) a) (defvar *nsubst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) (deftest nsubst.1 (check-nsubst "Z" 30 (copy-tree *nsubst-tree-1*)) (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) (deftest nsubst.2 (check-nsubst "A" 0 (copy-tree *nsubst-tree-1*)) (10 (30 20 10) (20 10) (10 20 30 40))) (deftest nsubst.3 (check-nsubst "Z" 100 (copy-tree *nsubst-tree-1*) :test-not #'eql) "Z") (deftest nsubst.4 (check-nsubst 'grape 'dick '(melville wrote (moby dick))) (melville wrote (moby grape))) (deftest nsubst.5 (check-nsubst 'cha-cha-cha 'nil '(melville wrote (moby dick))) (melville wrote (moby dick . cha-cha-cha) . cha-cha-cha)) (deftest nsubst.6 (check-nsubst '(1 2) '(foo . bar) '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) :test #'equal) ((foo . baz) (1 2) (bar . foo) (baz 1 2))) (deftest nsubst.7 (check-nsubst 'foo "aaa" '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) :key #'(lambda (x) (if (and (numberp x) (evenp x)) "aaa" nil)) :test #'string=) ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) (deftest nsubst.8 (check-nsubst 'foo nil '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) :key #'(lambda (x) (if (and (numberp x) (evenp x)) (copy-seq "aaa") nil)) :test-not #'equal) ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) (deftest nsubst.9 (check-nsubst 'a 'b (copy-tree '(a b c d a b)) :key nil) (a a c d a a)) ;;; Order of argument evaluation (deftest nsubst.order.1 (let ((i 0) v w x y z) (values (nsubst (progn (setf v (incf i)) 'b) (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) :key (progn (setf y (incf i)) #'identity) :test (progn (setf z (incf i)) #'eql)) i v w x y z)) ((10 b . b) b b c ((b)) z) 5 1 2 3 4 5) (deftest nsubst.order.2 (let ((i 0) v w x y z) (values (nsubst (progn (setf v (incf i)) 'b) (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) :test-not (progn (setf y (incf i)) (complement #'eql)) :key (progn (setf z (incf i)) #'identity) ) i v w x y z)) ((10 b . b) b b c ((b)) z) 5 1 2 3 4 5) ;;; Keyword tests for nsubst (deftest nsubst.allow-other-keys.1 (nsubst 'a 'b (list 'a 'b 'c) :bad t :allow-other-keys t) (a a c)) (deftest nsubst.allow-other-keys.2 (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t) (a a c)) (deftest nsubst.allow-other-keys.3 (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys nil) (a a c)) (deftest nsubst.allow-other-keys.4 (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t :bad t) (a a c)) (deftest nsubst.allow-other-keys.5 (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil :bad t) (a a c)) (deftest nsubst.keywords.6 (nsubst 'a 'b (list 'a 'b 'c) :test #'eq :test (complement #'eq)) (a a c)) ;;; Tests for nsubst-if, nsubst-if-not (deftest nsubst-if.1 (check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) a) (deftest nsubst-if-not.1 (check-nsubst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) ((x) ((x) (x) x) ((x) (x) (x) x) ((x) (x) (x) (x) x) x)) (deftest nsubst-if.2 (check-nsubst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) (17 (17 17) (17 17 17) (17 nil 17 17 17))) (deftest nsubst-if.3 (check-nsubst-if '(z) (complement #'consp) '(a (a b) (c d e) (f g h i))) ((z) ((z) (z) z) ((z) (z) (z) z) ((z) (z) (z) (z) z) z)) (deftest nsubst-if-not.2 (check-nsubst-if-not 'a (complement #'listp) '((100 1) (2 3) (4 3 2 1) (a b c))) a) (deftest nsubst-if.4 (check-nsubst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) :key #'listp) b) (deftest nsubst-if-not.3 (check-nsubst-if-not 'c #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) :key (complement #'listp)) c) (deftest nsubst-if.5 (check-nsubst-if 4 #'(lambda (x) (eql x 1)) '((1 3) (1) (1 10 20 30) (1 3 x y)) :key #'(lambda (x) (and (consp x) (car x)))) (4 4 4 4)) (deftest nsubst-if-not.4 (check-nsubst-if-not 40 #'(lambda (x) (not (eql x 17))) '((17) (17 22) (17 22 31) (17 21 34 54)) :key #'(lambda (x) (and (consp x) (car x)))) (40 40 40 40)) (deftest nsubst-if.6 (check-nsubst-if 'a #'(lambda (x) (eql x 'b)) '((a) (b) (c) (d)) :key nil) ((a) (a) (c) (d))) (deftest nsubst-if-not.5 (check-nsubst-if-not 'a #'(lambda (x) (not (eql x 'b))) '((a) (b) (c) (d)) :key nil) ((a) (a) (c) (d))) (deftest nsubst-if.7 (nsubst-if 'a #'null nil :bad t :allow-other-keys t) a) (deftest nsubst-if-not.6 (nsubst-if-not 'a #'null nil :bad t :allow-other-keys t) nil) (deftest nsubst-if.8 (let ((i 0) w x y z) (values (nsubst-if (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) (progn (setf y (incf i)) (copy-list '(1 2 a b c))) :key (progn (setf z (incf i)) #'identity)) i w x y z)) (1 2 a a c) 4 1 2 3 4) (deftest nsubst-if-not.7 (let ((i 0) w x y z) (values (nsubst-if-not (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) (progn (setf y (incf i)) (copy-list '(1 2 a b c))) :key (progn (setf z (incf i)) #'identity)) i w x y z)) (1 2 a a c) 4 1 2 3 4) ;;; Keyword tests for nsubst-if (deftest nsubst-if.allow-other-keys.1 (nsubst-if 'a #'null nil :bad t :allow-other-keys t) a) (deftest nsubst-if.allow-other-keys.2 (nsubst-if 'a #'null nil :allow-other-keys t) a) (deftest nsubst-if.allow-other-keys.3 (nsubst-if 'a #'null nil :allow-other-keys nil) a) (deftest nsubst-if.allow-other-keys.4 (nsubst-if 'a #'null nil :allow-other-keys t :bad t) a) (deftest nsubst-if.allow-other-keys.5 (nsubst-if 'a #'null nil :allow-other-keys t :allow-other-keys nil :bad t) a) (deftest nsubst-if.keywords.6 (nsubst-if 'a #'null nil :key nil :key (constantly 'b)) a) ;;; Keywords tests for nsubst-if-not (deftest nsubst-if-not.allow-other-keys.1 (nsubst-if-not 'a #'identity nil :bad t :allow-other-keys t) a) (deftest nsubst-if-not.allow-other-keys.2 (nsubst-if-not 'a #'identity nil :allow-other-keys t) a) (deftest nsubst-if-not.allow-other-keys.3 (nsubst-if-not 'a #'identity nil :allow-other-keys nil) a) (deftest nsubst-if-not.allow-other-keys.4 (nsubst-if-not 'a #'identity nil :allow-other-keys t :bad t) a) (deftest nsubst-if-not.allow-other-keys.5 (nsubst-if-not 'a #'identity nil :allow-other-keys t :allow-other-keys nil :bad t) a) (deftest nsubst-if-not.keywords.6 (nsubst-if-not 'a #'identity nil :key nil :key (constantly 'b)) a) ;;; Error cases ;;; subst (deftest subst.error.1 (classify-error (subst)) program-error) (deftest subst.error.2 (classify-error (subst 'a)) program-error) (deftest subst.error.3 (classify-error (subst 'a 'b)) program-error) (deftest subst.error.4 (classify-error (subst 'a 'b nil :foo nil)) program-error) (deftest subst.error.5 (classify-error (subst 'a 'b nil :test)) program-error) (deftest subst.error.6 (classify-error (subst 'a 'b nil 1)) program-error) (deftest subst.error.7 (classify-error (subst 'a 'b nil :bad t :allow-other-keys nil)) program-error) (deftest subst.error.8 (classify-error (subst 'a 'b (list 'a 'b) :test #'identity)) program-error) (deftest subst.error.9 (classify-error (subst 'a 'b (list 'a 'b) :test-not #'identity)) program-error) (deftest subst.error.10 (classify-error (subst 'a 'b (list 'a 'b) :key #'equal)) program-error) ;;; nsubst (deftest nsubst.error.1 (classify-error (nsubst)) program-error) (deftest nsubst.error.2 (classify-error (nsubst 'a)) program-error) (deftest nsubst.error.3 (classify-error (nsubst 'a 'b)) program-error) (deftest nsubst.error.4 (classify-error (nsubst 'a 'b nil :foo nil)) program-error) (deftest nsubst.error.5 (classify-error (nsubst 'a 'b nil :test)) program-error) (deftest nsubst.error.6 (classify-error (nsubst 'a 'b nil 1)) program-error) (deftest nsubst.error.7 (classify-error (nsubst 'a 'b nil :bad t :allow-other-keys nil)) program-error) (deftest nsubst.error.8 (classify-error (nsubst 'a 'b (list 'a 'b) :test #'identity)) program-error) (deftest nsubst.error.9 (classify-error (nsubst 'a 'b (list 'a 'b) :test-not #'identity)) program-error) (deftest nsubst.error.10 (classify-error (nsubst 'a 'b (list 'a 'b) :key #'equal)) program-error) ;;; subst-if (deftest subst-if.error.1 (classify-error (subst-if)) program-error) (deftest subst-if.error.2 (classify-error (subst-if 'a)) program-error) (deftest subst-if.error.3 (classify-error (subst-if 'a #'null)) program-error) (deftest subst-if.error.4 (classify-error (subst-if 'a #'null nil :foo nil)) program-error) (deftest subst-if.error.5 (classify-error (subst-if 'a #'null nil :test)) program-error) (deftest subst-if.error.6 (classify-error (subst-if 'a #'null nil 1)) program-error) (deftest subst-if.error.7 (classify-error (subst-if 'a #'null nil :bad t :allow-other-keys nil)) program-error) (deftest subst-if.error.8 (classify-error (subst-if 'a #'null (list 'a nil 'c) :key #'cons)) program-error) ;;; subst-if-not (deftest subst-if-not.error.1 (classify-error (subst-if-not)) program-error) (deftest subst-if-not.error.2 (classify-error (subst-if-not 'a)) program-error) (deftest subst-if-not.error.3 (classify-error (subst-if-not 'a #'null)) program-error) (deftest subst-if-not.error.4 (classify-error (subst-if-not 'a #'null nil :foo nil)) program-error) (deftest subst-if-not.error.5 (classify-error (subst-if-not 'a #'null nil :test)) program-error) (deftest subst-if-not.error.6 (classify-error (subst-if-not 'a #'null nil 1)) program-error) (deftest subst-if-not.error.7 (classify-error (subst-if-not 'a #'null nil :bad t :allow-other-keys nil)) program-error) (deftest subst-if-not.error.8 (classify-error (subst-if-not 'a #'null (list 'a nil 'c) :key #'cons)) program-error) ;;; nsubst-if (deftest nsubst-if.error.1 (classify-error (nsubst-if)) program-error) (deftest nsubst-if.error.2 (classify-error (nsubst-if 'a)) program-error) (deftest nsubst-if.error.3 (classify-error (nsubst-if 'a #'null)) program-error) (deftest nsubst-if.error.4 (classify-error (nsubst-if 'a #'null nil :foo nil)) program-error) (deftest nsubst-if.error.5 (classify-error (nsubst-if 'a #'null nil :test)) program-error) (deftest nsubst-if.error.6 (classify-error (nsubst-if 'a #'null nil 1)) program-error) (deftest nsubst-if.error.7 (classify-error (nsubst-if 'a #'null nil :bad t :allow-other-keys nil)) program-error) (deftest nsubst-if.error.8 (classify-error (nsubst-if 'a #'null (list 'a nil 'c) :key #'cons)) program-error) ;;; nsubst-if-not (deftest nsubst-if-not.error.1 (classify-error (nsubst-if-not)) program-error) (deftest nsubst-if-not.error.2 (classify-error (nsubst-if-not 'a)) program-error) (deftest nsubst-if-not.error.3 (classify-error (nsubst-if-not 'a #'null)) program-error) (deftest nsubst-if-not.error.4 (classify-error (nsubst-if-not 'a #'null nil :foo nil)) program-error) (deftest nsubst-if-not.error.5 (classify-error (nsubst-if-not 'a #'null nil :test)) program-error) (deftest nsubst-if-not.error.6 (classify-error (nsubst-if-not 'a #'null nil 1)) program-error) (deftest nsubst-if-not.error.7 (classify-error (nsubst-if-not 'a #'null nil :bad t :allow-other-keys nil)) program-error) (deftest nsubst-if-not.error.8 (classify-error (nsubst-if-not 'a #'null (list 'a nil 'c) :key #'cons)) program-error) gcl/ansi-tests/cons-test-03.lsp000066400000000000000000000146571242227143400166120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:32:20 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 3 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; copy-list (deftest copy-list.1 (check-copy-list '(a b c d)) (a b c d)) ;; Check that copy-list works on dotted lists (deftest copy-list.2 (check-copy-list '(a . b)) (a . b)) (deftest copy-list.3 (check-copy-list '(a b c . d)) (a b c . d)) (deftest copy-list.4 (let ((i 0)) (values (copy-list (progn (incf i) '(a b c))) i)) (a b c) 1) (deftest copy-list.error.1 (classify-error (copy-list)) program-error) (deftest copy-list.error.2 (classify-error (copy-list nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; list, list* (deftest list.1 (list 'a 'b 'c) (a b c)) (deftest list.2 (list) nil) (deftest list.order.1 (let ((i 0)) (list (incf i) (incf i) (incf i) (incf i))) (1 2 3 4)) (deftest list.order.2 (let ((i 0)) (list (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i))) (1 2 3 4 5 6 7 8)) (deftest list.order.3 (let ((i 0)) (list (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i))) (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)) (deftest list*.1 (list* 1 2 3) (1 2 . 3)) (deftest list*.2 (list* 'a) a) (deftest list-list*.1 (list* 'a 'b 'c (list 'd 'e 'f)) (a b c d e f)) (deftest list*.3 (list* 1) 1) (deftest list*.order.1 (let ((i 0)) (list* (incf i) (incf i) (incf i) (incf i))) (1 2 3 . 4)) (deftest list*.order.2 (let ((i 0)) (list* (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i))) (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 . 16)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; list-length (deftest list-length-nil (list-length nil) 0) (deftest list-length-list (list-length '(a b c d e f)) 6) ;; check that list-length returns nil ;; on a circular list (deftest list-length-circular-list (let ((x (cons nil nil))) (let ((y (list* 1 2 3 4 5 6 7 8 9 x))) (setf (cdr x) y) (let ((z (list* 'a 'b 'c 'd 'e y))) (list-length z)))) nil) (deftest list-length.order.1 (let ((i 0)) (values (list-length (progn (incf i) '(a b c))) i)) 3 1) ;; Check that list-length produces a type-error ;; on arguments that are not proper lists or circular lists (deftest list-length.error.1 (loop for x in (list 'a 1 1.0 #\w (make-array '(10)) '(a b . c) (symbol-package 'cons)) count (not (eqt (catch-type-error (list-length x)) 'type-error))) 0) (deftest list-length.error.2 (classify-error (list-length)) program-error) (deftest list-length.error.3 (classify-error (list-length nil nil)) program-error) (deftest list-length.error.4 (classify-error (list-length 'a)) type-error) (deftest list-length.error.5 (classify-error (locally (list-length 'a) t)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; listp ;; Check listp against various simple cases (deftest listp-nil (notnot-mv (listp nil)) t) (deftest listp-symbol (listp 'a) nil) (deftest listp-singleton-list (notnot-mv (listp '(a))) t) (deftest listp-circular-list (let ((x (cons nil nil))) (setf (cdr x) x) (notnot-mv (listp x))) t) (deftest listp-longer-list (notnot-mv (listp '(a b c d e f g h))) t) ;;; Check that (listp x) == (typep x 'list) (deftest listp-universe (check-type-predicate 'listp 'list) 0) (deftest listp.order.1 (let ((i 0)) (values (listp (incf i)) i)) nil 1) (deftest listp.error.1 (classify-error (listp)) program-error) (deftest listp.error.2 (classify-error (listp nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (typep 'list) ;;; These tests are now somewhat redundant (deftest typep-nil-list (notnot-mv (typep nil 'list)) t) (deftest typep-symbol-list (typep 'a 'list) nil) (deftest typep-singleton-list-list (notnot-mv (typep '(a) 'list)) t) (deftest typep-circular-list-list (let ((x (cons nil nil))) (setf (cdr x) x) (notnot-mv (typep x 'list))) t) (deftest typep-longer-list-list (notnot-mv (typep '(a b c d e f g h) 'list)) t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; make-list (deftest make-list-empty.1 (make-list 0) nil) (deftest make-list-empty.2 (make-list 0 :initial-element 'a) nil) (deftest make-list-no-initial-element (make-list 6) (nil nil nil nil nil nil)) (deftest make-list-with-initial-element (make-list 6 :initial-element 'a) (a a a a a a)) (deftest make-list.allow-other-keys.1 (make-list 5 :allow-other-keys t :foo 'a) (nil nil nil nil nil)) (deftest make-list.allow-other-keys.2 (make-list 5 :bar nil :allow-other-keys t) (nil nil nil nil nil)) (deftest make-list.allow-other-keys.3 (make-list 5 :allow-other-keys nil) (nil nil nil nil nil)) (deftest make-list.allow-other-keys.4 (make-list 5 :allow-other-keys t :allow-other-keys nil 'bad t) (nil nil nil nil nil)) (deftest make-list.allow-other-keys.5 (make-list 5 :allow-other-keys t) (nil nil nil nil nil)) (deftest make-list-repeated-keyword (make-list 5 :initial-element 'a :initial-element 'b) (a a a a a)) (deftest make-list.order.1 (let ((i 0) x y) (values (make-list (progn (setf x (incf i)) 5) :initial-element (progn (setf y (incf i)) 'a)) i x y)) (a a a a a) 2 1 2) (deftest make-list.order.2 (let ((i 0) x y z) (values (make-list (progn (setf x (incf i)) 5) :initial-element (progn (setf y (incf i)) 'a) :initial-element (progn (setf z (incf i)) 'b)) i x y z)) (a a a a a) 3 1 2 3) (deftest make-list.error.1 (catch-type-error (make-list -1)) type-error) (deftest make-list.error.2 (classify-error (make-list 'a)) type-error) (deftest make-list.error.3 (classify-error (make-list)) program-error) (deftest make-list.error.4 (classify-error (make-list 5 :bad t)) program-error) (deftest make-list.error.5 (classify-error (make-list 5 :initial-element)) program-error) (deftest make-list.error.6 (classify-error (make-list 5 1 2)) program-error) (deftest make-list.error.7 (classify-error (make-list 5 :bad t :allow-other-keys nil)) program-error) (deftest make-list.error.8 (classify-error (locally (make-list 'a) t)) type-error) gcl/ansi-tests/cons-test-04.lsp000066400000000000000000000222411242227143400165770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:33:20 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 4 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; push ;;; There will be a separate test suite ;;; for ACCESSORS x SETF-like macros ;;; See also places.lsp (deftest push.1 (let ((x nil)) (push 'a x)) (a)) (deftest push.2 (let ((x 'b)) (push 'a x) (push 'c x)) (c a . b)) (deftest push.3 (let ((x (copy-tree '(a)))) (push x x) (and (eqt (car x) (cdr x)) x)) ((a) a)) (deftest push.order.1 (let ((x (list nil)) (i 0) a b) (values (push (progn (setf a (incf i)) 'z) (car (progn (setf b (incf i)) x))) x i a b)) (z) ((z)) 2 1 2) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; pop (deftest pop.1 (let ((x (copy-tree '(a b c)))) (let ((y (pop x))) (list x y))) ((b c) a)) (deftest pop.2 (let ((x nil)) (let ((y (pop x))) (list x y))) (nil nil)) ;;; Confirm argument is executed just once. (deftest pop.order.1 (let ((i 0) (a (vector (list 'a 'b 'c)))) (pop (aref a (progn (incf i) 0))) (values a i)) #((b c)) 1) (deftest push-and-pop (let* ((x (copy-tree '(a b))) (y x)) (push 'c x) (and (eqt (cdr x) y) (pop x))) c) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; pushnew ;;; See also places.lsp (deftest pushnew.1 (let ((x nil)) (let ((y (pushnew 'a x))) (and (eqt x y) (equal x '(a)) t))) t) (deftest pushnew.2 (let* ((x (copy-tree '(b c d a k f q))) (y (pushnew 'a x))) (and (eqt x y) x)) (b c d a k f q)) (deftest pushnew.3 (let* ((x (copy-tree '(1 2 3 4 5 6 7 8))) (y (pushnew 7 x))) (and (eqt x y) x)) (1 2 3 4 5 6 7 8)) (deftest pushnew.4 (let* ((x (copy-tree '((a b) 1 "and" c d e))) (y (pushnew (copy-tree '(c d)) x :test 'equal))) (and (eqt x y) x)) ((c d) (a b) 1 "and" c d e)) (deftest pushnew.5 (let* ((x (copy-tree '((a b) 1 "and" c d e))) (y (pushnew (copy-tree '(a b)) x :test 'equal))) (and (eqt x y) x)) ((a b) 1 "and" c d e)) (deftest pushnew.6 (let* ((x (copy-tree '((a b) (c e) (d f) (g h)))) (y (pushnew (copy-tree '(d i)) x :key #'car)) (z (pushnew (copy-tree '(z 10)) x :key #'car))) (and (eqt y (cdr z)) (eqt z x) x)) ((z 10) (a b) (c e) (d f) (g h))) (deftest pushnew.7 (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) (y (pushnew (copy-tree '("def" 4)) x :key #'car :test #'string=)) (z (pushnew (copy-tree '("xyz" 10)) x :key #'car :test #'string=))) (and (eqt y (cdr x)) (eqt x z) x)) (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) (deftest pushnew.8 (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) (y (pushnew (copy-tree '("def" 4)) x :key #'car :test-not (complement #'string=))) (z (pushnew (copy-tree '("xyz" 10)) x :key #'car :test-not (complement #'string=)))) (and (eqt y (cdr x)) (eqt x z) x)) (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) (deftest pushnew.9 (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) (y (pushnew (copy-tree '("def" 4)) x :key 'car :test-not (complement #'string=))) (z (pushnew (copy-tree '("xyz" 10)) x :key 'car :test-not (complement #'string=)))) (and (eqt y (cdr x)) (eqt x z) x)) (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) ;; Check that a NIL :key argument is the same as no key argument at all (deftest pushnew.10 (let* ((x (list 'a 'b 'c 'd)) (result (pushnew 'z x :key nil))) result) (z a b c d)) ;; Check that a NIL :key argument is the same as no key argument at all (deftest pushnew.11 (let* ((x (copy-tree '((a b) 1 "and" c d e))) (y (pushnew (copy-tree '(a b)) x :test 'equal :key nil))) (and (eqt x y) x)) ((a b) 1 "and" c d e)) (deftest pushnew.12 (let ((i 0) x y z (d '(b c))) (values (pushnew (progn (setf x (incf i)) 'a) d :key (progn (setf y (incf i)) #'identity) :test (progn (setf z (incf i)) #'eql)) d i x y z)) (a b c) (a b c) 3 1 2 3) (deftest pushnew.13 (let ((i 0) x y z (d '(b c))) (values (pushnew (progn (setf x (incf i)) 'a) d :key (progn (setf y (incf i)) #'identity) :test-not (progn (setf z (incf i)) (complement #'eql))) d i x y z)) (a b c) (a b c) 3 1 2 3) (deftest pushnew.14 (let ((i 0) x y z (d '(b c))) (values (pushnew (progn (setf x (incf i)) 'a) d :test (progn (setf z (incf i)) #'eql) :key (progn (setf y (incf i)) #'identity)) d i x y z)) (a b c) (a b c) 3 1 3 2) (deftest pushnew.15 (let ((i 0) x y z (d '(b c))) (values (pushnew (progn (setf x (incf i)) 'a) d :test-not (progn (setf z (incf i)) (complement #'eql)) :key (progn (setf y (incf i)) #'identity)) d i x y z)) (a b c) (a b c) 3 1 3 2) (deftest pushnew.error.1 (classify-error (let ((x '(a b))) (pushnew 'c x :test #'identity))) program-error) (deftest pushnew.error.2 (classify-error (let ((x '(a b))) (pushnew 'c x :test-not #'identity))) program-error) (deftest pushnew.error.3 (classify-error (let ((x '(a b))) (pushnew 'c x :key #'cons))) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; adjoin (deftest adjoin.1 (adjoin 'a nil) (a)) (deftest adjoin.2 (adjoin nil nil) (nil)) (deftest adjoin.3 (adjoin 'a '(a)) (a)) ;; Check that a NIL :key argument is the same as no key argument at all (deftest adjoin.4 (adjoin 'a '(a) :key nil) (a)) (deftest adjoin.5 (adjoin 'a '(a) :key #'identity) (a)) (deftest adjoin.6 (adjoin 'a '(a) :key 'identity) (a)) (deftest adjoin.7 (adjoin (1+ 11) '(4 3 12 2 1)) (4 3 12 2 1)) ;; Check that the test is EQL, not EQ (by adjoining a bignum) (deftest adjoin.8 (adjoin (1+ 999999999999) '(4 1 1000000000000 3816734 a "aa")) (4 1 1000000000000 3816734 a "aa")) (deftest adjoin.9 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a)) ("aaa" aaa "AAA" "aaa" #\a)) (deftest adjoin.10 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test #'equal) (aaa "AAA" "aaa" #\a)) (deftest adjoin.11 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test 'equal) (aaa "AAA" "aaa" #\a)) (deftest adjoin.12 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test-not (complement #'equal)) (aaa "AAA" "aaa" #\a)) (deftest adjoin.14 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test #'equal :key #'identity) (aaa "AAA" "aaa" #\a)) (deftest adjoin.15 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test 'equal :key #'identity) (aaa "AAA" "aaa" #\a)) ;; Test that a :key of NIL is the same as no key at all (deftest adjoin.16 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test #'equal :key nil) (aaa "AAA" "aaa" #\a)) ;; Test that a :key of NIL is the same as no key at all (deftest adjoin.17 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test 'equal :key nil) (aaa "AAA" "aaa" #\a)) ;; Test that a :key of NIL is the same as no key at all (deftest adjoin.18 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test-not (complement #'equal) :key nil) (aaa "AAA" "aaa" #\a)) (deftest adjoin.order.1 (let ((i 0) w x y z) (values (adjoin (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) '(b c d a e)) :key (progn (setf y (incf i)) #'identity) :test (progn (setf z (incf i)) #'eql)) i w x y z)) (b c d a e) 4 1 2 3 4) (deftest adjoin.order.2 (let ((i 0) w x y z p) (values (adjoin (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) '(b c d e)) :test-not (progn (setf y (incf i)) (complement #'eql)) :key (progn (setf z (incf i)) #'identity) :key (progn (setf p (incf i)) nil)) i w x y z p)) (a b c d e) 5 1 2 3 4 5) (deftest adjoin.allow-other-keys.1 (adjoin 'a '(b c) :bad t :allow-other-keys t) (a b c)) (deftest adjoin.allow-other-keys.2 (adjoin 'a '(b c) :allow-other-keys t :foo t) (a b c)) (deftest adjoin.allow-other-keys.3 (adjoin 'a '(b c) :allow-other-keys t) (a b c)) (deftest adjoin.allow-other-keys.4 (adjoin 'a '(b c) :allow-other-keys nil) (a b c)) (deftest adjoin.allow-other-keys.5 (adjoin 'a '(b c) :allow-other-keys t :allow-other-keys nil 'bad t) (a b c)) (deftest adjoin.repeat-key (adjoin 'a '(b c) :test #'eq :test (complement #'eq)) (a b c)) (deftest adjoin.error.1 (classify-error (adjoin)) program-error) (deftest adjoin.error.2 (classify-error (adjoin 'a)) program-error) (deftest adjoin.error.3 (classify-error (adjoin 'a '(b c) :bad t)) program-error) (deftest adjoin.error.4 (classify-error (adjoin 'a '(b c) :allow-other-keys nil :bad t)) program-error) (deftest adjoin.error.5 (classify-error (adjoin 'a '(b c) 1 2)) program-error) (deftest adjoin.error.6 (classify-error (adjoin 'a '(b c) :test)) program-error) (deftest adjoin.error.7 (classify-error (adjoin 'a '(b c) :test #'identity)) program-error) (deftest adjoin.error.8 (classify-error (adjoin 'a '(b c) :test-not #'identity)) program-error) (deftest adjoin.error.9 (classify-error (adjoin 'a '(b c) :key #'cons)) program-error) gcl/ansi-tests/cons-test-05.lsp000066400000000000000000000110341242227143400165760ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:34:08 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 5 (in-package :cl-test) (declaim (optimize (safety 3))) (defparameter *cons-accessors* '(first second third fourth fifth sixth seventh eighth ninth tenth car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; first, ..., tenth (deftest first-etc-1 (let ((x (loop for i from 1 to 20 collect i))) (list (first x) (second x) (third x) (fourth x) (fifth x) (sixth x) (seventh x) (eighth x) (ninth x) (tenth x))) (1 2 3 4 5 6 7 8 9 10)) (deftest first-etc-2 (let ((x (make-list 15 :initial-element 'a))) (and (eql (setf (first x) 1) 1) (eql (setf (second x) 2) 2) (eql (setf (third x) 3) 3) (eql (setf (fourth x) 4) 4) (eql (setf (fifth x) 5) 5) (eql (setf (sixth x) 6) 6) (eql (setf (seventh x) 7) 7) (eql (setf (eighth x) 8) 8) (eql (setf (ninth x) 9) 9) (eql (setf (tenth x) 10) 10) x)) (1 2 3 4 5 6 7 8 9 10 a a a a a)) (deftest rest-set-1 (let ((x (list 'a 'b 'c))) (and (eqt (setf (rest x) 'd) 'd) x)) (a . d)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; setting of C*R accessors (loop for fn in '(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) do (let ((level (- (length (symbol-name fn)) 2))) (eval `(deftest ,(intern (concatenate 'string (symbol-name fn) "-SET") :cl-test) (let ((x (create-c*r-test ,level)) (y (list (create-c*r-test ,level))) (i 0)) (and (setf (,fn (progn (incf i) x)) 'a) (eqlt (,fn x) 'a) (eqlt i 1) (setf (,fn x) 'none) (equalt x (create-c*r-test ,level)) (setf (,fn (progn (incf i) (car y))) 'a) (eqlt (,fn (car y)) 'a) (eqlt i 2) (setf (,fn (car y)) 'none) (null (cdr y)) (equalt (car y) (create-c*r-test ,level)) )) t)))) (loop for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) (fifth 5) (sixth 6) (seventh 7) (eighth 8) (ninth 9) (tenth 10)) do (eval `(deftest ,(intern (concatenate 'string (symbol-name fn) "-SET") :cl-test) (let* ((x (make-list 20 :initial-element nil)) (y (list (copy-list x))) (cnt 0)) (and (setf (,fn (progn (incf cnt) x)) 'a) (eqlt cnt 1) (loop for i from 1 to 20 do (when (and (not (eql i ,len)) (nth (1- i) x)) (return nil)) finally (return t)) (setf (,fn (car y)) 'a) (loop for i from 1 to 20 do (when (and (not (eql i ,len)) (nth (1- i) (car y))) (return nil)) finally (return t)) (eqlt (,fn x) 'a) (eqlt (nth ,(1- len) x) 'a) (eqlt (,fn (car y)) 'a) (nth ,(1- len) (car y)))) a))) ;; set up program error tests (loop for name in *cons-accessors* do (eval `(deftest ,(intern (concatenate 'string (symbol-name name) ".ERROR.NO-ARGS") :cl-test) (classify-error (,name)) program-error)) do (eval `(deftest ,(intern (concatenate 'string (symbol-name name) ".ERROR.EXCESS-ARGS") :cl-test) (classify-error (,name nil nil)) program-error))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nth (deftest nth.1 (nth-1-body (loop for i from 1 to 2000 collect (* 4 i))) 0) (deftest nth.2 (let ((x (loop for i from 1 to 2000 collect i))) (loop for i from 0 to 1999 do (setf (nth i x) (- 1999 i))) (equalt x (loop for i from 1999 downto 0 collect i))) t) ;;; Test side effects, evaluation order in assignment to NTH (deftest nth.order.1 (let ((i 0) (x (list 'a 'b 'c 'd)) y z) (and (eqlt (setf (nth (setf y (incf i)) x) (progn (setf z (incf i)) 'z)) 'z) (eqlt y 1) (eqlt z 2) x)) (a z c d)) (deftest nth.order.2 (let ((i 0) x y (z '(a b c d e))) (values (nth (progn (setf x (incf i)) 1) (progn (setf y (incf i)) z)) i x y)) b 2 1 2) (deftest nth.error.1 (classify-error (nth)) program-error) (deftest nth.error.2 (classify-error (nth 0)) program-error) (deftest nth.error.3 (classify-error (nth 1 '(a b c) nil)) program-error) (deftest nth.error.4 (classify-error (nth 0 '(a b c) nil)) program-error) gcl/ansi-tests/cons-test-06.lsp000066400000000000000000000016741242227143400166100ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:34:40 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 6 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; endp (deftest endp-nil (notnot-mv (endp nil)) t) (deftest endp-cons (endp (cons 'a 'a)) nil) (deftest endp-singleton-list (endp '(a)) nil) (deftest endp.order.1 (let ((i 0)) (values (endp (progn (incf i) '(a b c))) i)) nil 1) (deftest endp-symbol-error (catch-type-error (endp 'a)) type-error) (deftest endp-fixnum-error (catch-type-error (endp 1)) type-error) (deftest endp-float-error (catch-type-error (endp 0.9212d4)) type-error) (deftest endp.error.4 (classify-error (endp)) program-error) (deftest endp.error.5 (classify-error (endp nil nil)) program-error) (deftest endp.error.6 (catch-type-error (locally (endp 1))) type-error) gcl/ansi-tests/cons-test-07.lsp000066400000000000000000000102711242227143400166020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:35:15 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 7 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nconc (deftest nconc.1 (nconc) nil) (deftest nconc.2 (nconc (copy-tree '(a b c d e f))) (a b c d e f)) (deftest nconc.3 (nconc 1) 1) (deftest nconc.4 (let ((x (list 'a 'b 'c)) (y (list 'd 'e 'f))) (let ((ycopy (make-scaffold-copy y))) (let ((result (nconc x y))) (and (check-scaffold-copy y ycopy) (eqt (cdddr x) y) result)))) (a b c d e f)) (deftest nconc.5 (let ((x (list 'a 'b 'c))) (nconc x x) (and (eqt (cdddr x) x) (null (list-length x)))) t) (deftest nconc.6 (let ((x (list 'a 'b 'c)) (y (list 'd 'e 'f 'g 'h)) (z (list 'i 'j 'k))) (let ((result (nconc x y z 'foo))) (and (eqt (nthcdr 3 x) y) (eqt (nthcdr 5 y) z) (eqt (nthcdr 3 z) 'foo) result))) (a b c d e f g h i j k . foo)) (deftest nconc.7 (nconc (copy-tree '(a . b)) (copy-tree '(c . d)) (copy-tree '(e . f)) 'foo) (a c e . foo)) (deftest nconc.order.1 (let ((i 0) x y z) (values (nconc (progn (setf x (incf i)) (copy-list '(a b c))) (progn (setf y (incf i)) (copy-list '(d e f))) (progn (setf z (incf i)) (copy-list '(g h i)))) i x y z)) (a b c d e f g h i) 3 1 2 3) (deftest nconc.order.2 (let ((i 0)) (values (nconc (incf i)) i)) 1 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; append (deftest append.1 (append) nil) (deftest append.2 (append 'x) x) (deftest append.3 (let ((x (list 'a 'b 'c 'd)) (y (list 'e 'f 'g))) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (let ((result (append x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) result)))) (a b c d e f g)) (deftest append.4 (append (list 'a) (list 'b) (list 'c) (list 'd) (list 'e) (list 'f) (list 'g) 'h) (a b c d e f g . h)) (deftest append.5 (append nil nil nil nil nil nil nil nil 'a) a) (deftest append.6 (append-6-body) 0) (deftest append.order.1 (let ((i 0) x y z) (values (append (progn (setf x (incf i)) (copy-list '(a b c))) (progn (setf y (incf i)) (copy-list '(d e f))) (progn (setf z (incf i)) (copy-list '(g h i)))) i x y z)) (a b c d e f g h i) 3 1 2 3) (deftest append.order.2 (let ((i 0)) (values (append (incf i)) i)) 1 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; revappend (deftest revappend.1 (let* ((x (list 'a 'b 'c)) (y (list 'd 'e 'f)) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) ) (let ((result (revappend x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (eqt (cdddr result) y) result))) (c b a d e f)) (deftest revappend.2 (revappend (copy-tree '(a b c d e)) 10) (e d c b a . 10)) (deftest revappend.3 (revappend nil 'a) a) (deftest revappend.4 (revappend (copy-tree '(a (b c) d)) nil) (d (b c) a)) (deftest revappend.order.1 (let ((i 0) x y) (values (revappend (progn (setf x (incf i)) (copy-list '(a b c))) (progn (setf y (incf i)) (copy-list '(d e f)))) i x y)) (c b a d e f) 2 1 2) (deftest revappend.error.1 (classify-error (revappend)) program-error) (deftest revappend.error.2 (classify-error (revappend nil)) program-error) (deftest revappend.error.3 (classify-error (revappend nil nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nreconc (deftest nreconc.1 (let* ((x (list 'a 'b 'c)) (y (copy-tree '(d e f))) (result (nreconc x y))) (and (equal y '(d e f)) result)) (c b a d e f)) (deftest nreconc.2 (nreconc nil 'a) a) (deftest nreconc.order.1 (let ((i 0) x y) (values (nreconc (progn (setf x (incf i)) (copy-list '(a b c))) (progn (setf y (incf i)) (copy-list '(d e f)))) i x y)) (c b a d e f) 2 1 2) (deftest nreconc.error.1 (classify-error (nreconc)) program-error) (deftest nreconc.error.2 (classify-error (nreconc nil)) program-error) (deftest nreconc.error.3 (classify-error (nreconc nil nil nil)) program-error) gcl/ansi-tests/cons-test-08.lsp000066400000000000000000000203721242227143400166060ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:36:01 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 8 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Error checking car, cdr, list-length (deftest car.1 (car '(a)) a) (deftest car-nil (car nil) nil) (deftest car-symbol-error (classify-error (car 'a)) type-error) (deftest car-symbol-error.2 (classify-error (locally (car 'a) t)) type-error) (deftest car.order.1 (let ((i 0)) (values (car (progn (incf i) '(a b))) i)) a 1) (deftest cdr.1 (cdr '(a b)) (b)) (deftest cdr-nil (cdr ()) nil) (deftest cdr.order.1 (let ((i 0)) (values (cdr (progn (incf i) '(a b))) i)) (b) 1) (deftest cdr-symbol-error (classify-error (cdr 'a)) type-error) (deftest cdr-symbol-error.2 (classify-error (locally (cdr 'a) t)) type-error) (deftest list-length.4 (list-length (copy-tree '(a b c))) 3) (deftest list-length-symbol (classify-error (list-length 'a)) type-error) (deftest list-length-dotted-list (classify-error (list-length (copy-tree '(a b c d . e)))) type-error) ;;; Error checking of c*r functions (deftest caar.error.1 (classify-error (caar 'a)) type-error) (deftest caar.error.2 (classify-error (caar '(a))) type-error) (deftest cadr.error.1 (classify-error (cadr 'a)) type-error) (deftest cadr.error.2 (classify-error (cadr '(a . b))) type-error) (deftest cdar.error.1 (classify-error (cdar 'a)) type-error) (deftest cdar.error.2 (classify-error (cdar '(a . b))) type-error) (deftest cddr.error.1 (classify-error (cddr 'a)) type-error) (deftest cddr.error.2 (classify-error (cddr '(a . b))) type-error) (deftest caaar.error.1 (classify-error (caaar 'a)) type-error) (deftest caaar.error.2 (classify-error (caaar '(a))) type-error) (deftest caaar.error.3 (classify-error (caaar '((a)))) type-error) (deftest caadr.error.1 (classify-error (caadr 'a)) type-error) (deftest caadr.error.2 (classify-error (caadr '(a . b))) type-error) (deftest caadr.error.3 (classify-error (caadr '(a . (b)))) type-error) (deftest cadar.error.1 (classify-error (cadar 'a)) type-error) (deftest cadar.error.2 (classify-error (cadar '(a . b))) type-error) (deftest cadar.error.3 (classify-error (cadar '((a . c) . b))) type-error) (deftest caddr.error.1 (classify-error (caddr 'a)) type-error) (deftest caddr.error.2 (classify-error (caddr '(a . b))) type-error) (deftest caddr.error.3 (classify-error (caddr '(a c . b))) type-error) (deftest cdaar.error.1 (classify-error (cdaar 'a)) type-error) (deftest cdaar.error.2 (classify-error (cdaar '(a))) type-error) (deftest cdaar.error.3 (classify-error (cdaar '((a . b)))) type-error) (deftest cdadr.error.1 (classify-error (cdadr 'a)) type-error) (deftest cdadr.error.2 (classify-error (cdadr '(a . b))) type-error) (deftest cdadr.error.3 (classify-error (cdadr '(a b . c))) type-error) (deftest cddar.error.1 (classify-error (cddar 'a)) type-error) (deftest cddar.error.2 (classify-error (cddar '(a . b))) type-error) (deftest cddar.error.3 (classify-error (cddar '((a . b) . b))) type-error) (deftest cdddr.error.1 (classify-error (cdddr 'a)) type-error) (deftest cdddr.error.2 (classify-error (cdddr '(a . b))) type-error) (deftest cdddr.error.3 (classify-error (cdddr '(a c . b))) type-error) ;; (deftest caaaar.error.1 (classify-error (caaaar 'a)) type-error) (deftest caaaar.error.2 (classify-error (caaaar '(a))) type-error) (deftest caaaar.error.3 (classify-error (caaaar '((a)))) type-error) (deftest caaaar.error.4 (classify-error (caaaar '(((a))))) type-error) (deftest caaadr.error.1 (classify-error (caaadr 'a)) type-error) (deftest caaadr.error.2 (classify-error (caaadr '(a . b))) type-error) (deftest caaadr.error.3 (classify-error (caaadr '(a . (b)))) type-error) (deftest caaadr.error.4 (classify-error (caaadr '(a . ((b))))) type-error) (deftest caadar.error.1 (classify-error (caadar 'a)) type-error) (deftest caadar.error.2 (classify-error (caadar '(a . b))) type-error) (deftest caadar.error.3 (classify-error (caadar '((a . c) . b))) type-error) (deftest caadar.error.4 (classify-error (caadar '((a . (c)) . b))) type-error) (deftest caaddr.error.1 (classify-error (caaddr 'a)) type-error) (deftest caaddr.error.2 (classify-error (caaddr '(a . b))) type-error) (deftest caaddr.error.3 (classify-error (caaddr '(a c . b))) type-error) (deftest caaddr.error.4 (classify-error (caaddr '(a c . (b)))) type-error) (deftest cadaar.error.1 (classify-error (cadaar 'a)) type-error) (deftest cadaar.error.2 (classify-error (cadaar '(a))) type-error) (deftest cadaar.error.3 (classify-error (cadaar '((a . b)))) type-error) (deftest cadaar.error.4 (classify-error (cadaar '((a . (b))))) type-error) (deftest cadadr.error.1 (classify-error (cadadr 'a)) type-error) (deftest cadadr.error.2 (classify-error (cadadr '(a . b))) type-error) (deftest cadadr.error.3 (classify-error (cadadr '(a b . c))) type-error) (deftest cadadr.error.4 (classify-error (cadadr '(a (b . e) . c))) type-error) (deftest caddar.error.1 (classify-error (caddar 'a)) type-error) (deftest caddar.error.2 (classify-error (caddar '(a . b))) type-error) (deftest caddar.error.3 (classify-error (caddar '((a . b) . b))) type-error) (deftest caddar.error.4 (classify-error (caddar '((a b . c) . b))) type-error) (deftest cadddr.error.1 (classify-error (cadddr 'a)) type-error) (deftest cadddr.error.2 (classify-error (cadddr '(a . b))) type-error) (deftest cadddr.error.3 (classify-error (cadddr '(a c . b))) type-error) (deftest cadddr.error.4 (classify-error (cadddr '(a c e . b))) type-error) (deftest cdaaar.error.1 (classify-error (cdaaar 'a)) type-error) (deftest cdaaar.error.2 (classify-error (cdaaar '(a))) type-error) (deftest cdaaar.error.3 (classify-error (cdaaar '((a)))) type-error) (deftest cdaaar.error.4 (classify-error (cdaaar '(((a . b))))) type-error) (deftest cdaadr.error.1 (classify-error (cdaadr 'a)) type-error) (deftest cdaadr.error.2 (classify-error (cdaadr '(a . b))) type-error) (deftest cdaadr.error.3 (classify-error (cdaadr '(a . (b)))) type-error) (deftest cdaadr.error.4 (classify-error (cdaadr '(a . ((b . c))))) type-error) (deftest cdadar.error.1 (classify-error (cdadar 'a)) type-error) (deftest cdadar.error.2 (classify-error (cdadar '(a . b))) type-error) (deftest cdadar.error.3 (classify-error (cdadar '((a . c) . b))) type-error) (deftest cdadar.error.4 (classify-error (cdadar '((a . (c . d)) . b))) type-error) (deftest cdaddr.error.1 (classify-error (cdaddr 'a)) type-error) (deftest cdaddr.error.2 (classify-error (cdaddr '(a . b))) type-error) (deftest cdaddr.error.3 (classify-error (cdaddr '(a c . b))) type-error) (deftest cdaddr.error.4 (classify-error (cdaddr '(a c b . d))) type-error) (deftest cddaar.error.1 (classify-error (cddaar 'a)) type-error) (deftest cddaar.error.2 (classify-error (cddaar '(a))) type-error) (deftest cddaar.error.3 (classify-error (cddaar '((a . b)))) type-error) (deftest cddaar.error.4 (classify-error (cddaar '((a . (b))))) type-error) (deftest cddadr.error.1 (classify-error (cddadr 'a)) type-error) (deftest cddadr.error.2 (classify-error (cddadr '(a . b))) type-error) (deftest cddadr.error.3 (classify-error (cddadr '(a b . c))) type-error) (deftest cddadr.error.4 (classify-error (cddadr '(a (b . e) . c))) type-error) (deftest cdddar.error.1 (classify-error (cdddar 'a)) type-error) (deftest cdddar.error.2 (classify-error (cdddar '(a . b))) type-error) (deftest cdddar.error.3 (classify-error (cdddar '((a . b) . b))) type-error) (deftest cdddar.error.4 (classify-error (cdddar '((a b . c) . b))) type-error) (deftest cddddr.error.1 (classify-error (cddddr 'a)) type-error) (deftest cddddr.error.2 (classify-error (cddddr '(a . b))) type-error) (deftest cddddr.error.3 (classify-error (cddddr '(a c . b))) type-error) (deftest cddddr.error.4 (classify-error (cddddr '(a c e . b))) type-error) ;;; Need to add 'locally' wrapped forms of these gcl/ansi-tests/cons-test-09.lsp000066400000000000000000000073311242227143400166070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:36:30 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 9 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; butlast, nbutlast (deftest butlast.1 (let ((x (list 'a 'b 'c 'd 'e))) (let ((xcopy (make-scaffold-copy x))) (let ((result (butlast x 2))) (and (check-scaffold-copy x xcopy) result)))) (a b c)) (deftest butlast.2 (let ((x (list 'a 'b 'c 'd 'e))) (let ((xcopy (make-scaffold-copy x))) (let ((result (butlast x 0))) (and (check-scaffold-copy x xcopy) result)))) (a b c d e)) (deftest butlast.3 (let ((x (list 'a 'b 'c 'd 'e))) (let ((xcopy (make-scaffold-copy x))) (let ((result (butlast x 5))) (and (check-scaffold-copy x xcopy) result)))) nil) (deftest butlast.4 (let ((x (list 'a 'b 'c 'd 'e))) (let ((xcopy (make-scaffold-copy x))) (let ((result (butlast x 6))) (and (check-scaffold-copy x xcopy) result)))) nil) (deftest butlast.5 (butlast (copy-tree '(a b c . d)) 1) (a b)) (deftest butlast.order.1 (let ((i 0) x y) (values (butlast (progn (setf x (incf i)) (list 'a 'b 'c 'd 'e)) (progn (setf y (incf i)) 2)) i x y)) (a b c) 2 1 2) (deftest butlast.order.2 (let ((i 0)) (values (butlast (progn (incf i) '(a b c d))) i)) (a b c) 1) (deftest butlast.error.1 (classify-error (butlast (copy-tree '(a b c d)) 'a)) type-error) (deftest butlast.error.2 (classify-error (butlast 'a 0)) type-error) (deftest butlast.error.3 (classify-error (butlast)) program-error) (deftest butlast.error.4 (classify-error (butlast '(a b c) 3 3)) program-error) (deftest butlast.error.5 (classify-error (locally (butlast 'a 0) t)) type-error) ;;; Tests of NBUTLAST (deftest nbutlast.1 (let ((x (list 'a 'b 'c 'd 'e))) (let ((y (cdr x)) (z (cddr x))) (let ((result (nbutlast x 2))) (and (eqt x result) (eqt (cdr x) y) (eqt (cddr x) z) result)))) (a b c)) (deftest nbutlast.2 (let ((x (list 'a 'b 'c 'd 'e))) (let ((result (nbutlast x 5))) (list x result))) ((a b c d e) nil)) (deftest nbutlast.3 (let ((x (list 'a 'b 'c 'd 'e))) (let ((result (nbutlast x 500))) (list x result))) ((a b c d e) nil)) (deftest nbutlast.4 (let ((x (list* 'a 'b 'c 'd))) (let ((result (nbutlast x 1))) (and (eqt result x) result))) (a b)) (deftest nbutlast.5 (nbutlast nil) nil) (deftest nbutlast.6 (nbutlast (list 'a)) nil) (deftest nbutlast.order.1 (let ((i 0) x y) (values (nbutlast (progn (setf x (incf i)) (list 'a 'b 'c 'd 'e)) (progn (setf y (incf i)) 2)) i x y)) (a b c) 2 1 2) (deftest nbutlast.order.2 (let ((i 0)) (values (nbutlast (progn (incf i) (list 'a 'b 'c 'd))) i)) (a b c) 1) (deftest nbutlast.error.1 (classify-error (let ((x (list* 'a 'b 'c 'd))) (nbutlast x 'a))) type-error) (deftest nbutlast.error.2 (classify-error (nbutlast 'a 10)) type-error) (deftest nbutlast.error.3 (classify-error (nbutlast 2 10)) type-error) (deftest nbutlast.error.4 (classify-error (nbutlast #\w 10)) type-error) (deftest nbutlast.error.5 (classify-error (nbutlast (list 'a 'b 'c 'd) -3)) type-error) (deftest nbutlast.error.6 (classify-error (nbutlast (list 'a) 20.0)) type-error) (deftest nbutlast.error.7 (classify-error (nbutlast (list 'a) -100.0)) type-error) (deftest nbutlast.error.8 (classify-error (nbutlast)) program-error) (deftest nbutlast.error.9 (classify-error (nbutlast (list 'a 'b 'c) 3 3)) program-error) (deftest nbutlast.error.10 (classify-error (locally (nbutlast 'a 10) t)) type-error) gcl/ansi-tests/cons-test-10.lsp000066400000000000000000000032761242227143400166030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:37:21 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 10 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; last (deftest last.1 (last nil) nil) (deftest last.2 (last (copy-tree '(a b))) (b)) (deftest last.3 (last (copy-tree '(a b . c))) (b . c)) (deftest last.4 (last (copy-tree '(a b c d)) 0) nil) (deftest last.5 (last (copy-tree '(a b c d)) 1) (d)) (deftest last.6 (last (copy-tree '(a b c d)) 2) (c d)) (deftest last.7 (last (copy-tree '(a b c d)) 5) (a b c d)) (deftest last.8 (last (cons 'a 'b) 0) b) (deftest last.9 (last (cons 'a 'b) 1) (a . b)) (deftest last.10 (last (cons 'a 'b) 2) (a . b)) (deftest last.order.1 (let ((i 0) x y) (values (last (progn (setf x (incf i)) (list 'a 'b 'c 'd)) (setf y (incf i))) i x y)) (c d) 2 1 2) (deftest last.order.2 (let ((i 0)) (values (last (progn (incf i) (list 'a 'b 'c 'd))) i)) (d) 1) (deftest last.error.1 (classify-error (last (list 'a 'b 'c) -1)) type-error) (deftest last.error.2 (classify-error (last (list 'a 'b 'c) 'a)) type-error) (deftest last.error.3 (classify-error (last (list 'a 'b 'c) 10.0)) type-error) (deftest last.error.4 (classify-error (last (list 'a 'b 'c) -10.0)) type-error) (deftest last.error.5 (classify-error (last (list 'a 'b 'c) #\w)) type-error) (deftest last.error.6 (classify-error (last)) program-error) (deftest last.error.7 (classify-error (last '(a b c) 2 nil)) program-error) (deftest last.error.8 (classify-error (locally (last (list 'a 'b 'c) 'a) t)) type-error) gcl/ansi-tests/cons-test-11.lsp000066400000000000000000000135331242227143400166010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:37:56 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 11 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ldiff, tailp (deftest ldiff.1 (let* ((x (copy-tree '(a b c d e f))) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x (cdddr x)))) (and (check-scaffold-copy x xcopy) result))) (a b c)) (deftest ldiff.2 (let* ((x (copy-tree '(a b c d e f))) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x 'a))) (and (check-scaffold-copy x xcopy) (zerop (loop for a on x and b on result count (eqt a b))) result))) (a b c d e f)) ;; Works when the end of the dotted list is a symbol (deftest ldiff.3 (let* ((x (copy-tree '(a b c d e . f))) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x 'a))) (and (check-scaffold-copy x xcopy) result))) (a b c d e . f)) ;; Works when the end of the dotted list is a fixnum (deftest ldiff.4 (let* ((n 18) (x (list* 'a 'b 'c 18)) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x n))) (and (check-scaffold-copy x xcopy) result))) (a b c)) ;; Works when the end of the dotted list is a larger ;; integer (that is eql, but probably not eq). (deftest ldiff.5 (let* ((n 18000000000000) (x (list* 'a 'b 'c (1- 18000000000001))) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x n))) (and (check-scaffold-copy x xcopy) result))) (a b c)) ;; Test works when the end of a dotted list is a string (deftest ldiff.6 (let* ((n (copy-seq "abcde")) (x (list* 'a 'b 'c n)) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x n))) (if (equal result (list 'a 'b 'c)) (check-scaffold-copy x xcopy) result))) t) ;; Check that having the cdr of a dotted list be string-equal, but ;; not eql, does not result in success (deftest ldiff.7 (let* ((n (copy-seq "abcde")) (x (list* 'a 'b 'c n)) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x (copy-seq n)))) (if (equal result x) (check-scaffold-copy x xcopy) result))) t) ;; Check that on failure, the list returned by ldiff is ;; a copy of the list, not the list itself. (deftest ldiff.8 (let ((x (list 'a 'b 'c 'd))) (let ((result (ldiff x '(e)))) (and (equal x result) (loop for c1 on x for c2 on result count (eqt c1 c2))))) 0) (deftest ldiff.order.1 (let ((i 0) x y) (values (ldiff (progn (setf x (incf i)) (list* 'a 'b 'c 'd)) (progn (setf y (incf i)) 'd)) i x y)) (a b c) 2 1 2) ;; Error checking (deftest ldiff.error.1 (classify-error (ldiff 10 'a)) type-error) ;; Single atoms are not dotted lists, so the next ;; case should be a type-error (deftest ldiff.error.2 (classify-error (ldiff 'a 'a)) type-error) (deftest ldiff.error.3 (classify-error (ldiff (make-array '(10) :initial-element 'a) '(a))) type-error) (deftest ldiff.error.4 (classify-error (ldiff 1.23 t)) type-error) (deftest ldiff.error.5 (classify-error (ldiff #\w 'a)) type-error) (deftest ldiff.error.6 (classify-error (ldiff)) program-error) (deftest ldiff.error.7 (classify-error (ldiff nil)) program-error) (deftest ldiff.error.8 (classify-error (ldiff nil nil nil)) program-error) ;; Note! The spec is ambiguous on whether this next test ;; is correct. The spec says that ldiff should be prepared ;; to signal an error if the list argument is not a proper ;; list or dotted list. If listp is false, the list argument ;; is neither (atoms are not dotted lists). ;; ;; However, the sample implementation *does* work even if ;; the list argument is an atom. ;; #| (defun ldiff-12-body () (loop for x in *universe* count (and (not (listp x)) (not (eqt 'type-error (catch-type-error (ldiff x x))))))) (deftest ldiff-12 (ldiff-12-body) 0) |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; tailp (deftest tailp.1 (let ((x (copy-tree '(a b c d e . f)))) (and (tailp x x) (tailp (cdr x) x) (tailp (cddr x) x) (tailp (cdddr x) x) (tailp (cddddr x) x) t)) t) ;; The next four tests test that tailp handles dotted lists. See ;; TAILP-NIL:T in the X3J13 documentation. (deftest tailp.2 (notnot-mv (tailp 'e (copy-tree '(a b c d . e)))) t) (deftest tailp.3 (tailp 'z (copy-tree '(a b c d . e))) nil) (deftest tailp.4 (notnot-mv (tailp 10203040506070 (list* 'a 'b (1- 10203040506071)))) t) (deftest tailp.5 (let ((x "abcde")) (tailp x (list* 'a 'b (copy-seq x)))) nil) (deftest tailp.error.5 (classify-error (tailp)) program-error) (deftest tailp.error.6 (classify-error (tailp nil)) program-error) (deftest tailp.error.7 (classify-error (tailp nil nil nil)) program-error) ;; Test that tailp does not modify its arguments (deftest tailp.6 (let* ((x (copy-list '(a b c d e))) (y (cddr x))) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (and (tailp y x) (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy)))) t) ;; Note! The spec is ambiguous on whether this next test ;; is correct. The spec says that tailp should be prepared ;; to signal an error if the list argument is not a proper ;; list or dotted list. If listp is false, the list argument ;; is neither (atoms are not dotted lists). ;; ;; However, the sample implementation *does* work even if ;; the list argument is an atom. ;; #| (defun tailp.7-body () (loop for x in *universe* count (and (not (listp x)) (eqt 'type-error (catch-type-error (tailp x x)))))) (deftest tailp.7 (tailp.7-body) 0) |# (deftest tailp.order.1 (let ((i 0) x y) (values (notnot (tailp (progn (setf x (incf i)) 'd) (progn (setf y (incf i)) '(a b c . d)))) i x y)) t 2 1 2) gcl/ansi-tests/cons-test-12.lsp000066400000000000000000000037531242227143400166050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:38:26 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 12 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nthcdr (deftest nthcdr.error.1 (classify-error (nthcdr nil (copy-tree '(a b c d)))) type-error) (deftest nthcdr.error.2 (classify-error (nthcdr 'a (copy-tree '(a b c d)))) type-error) (deftest nthcdr.error.3 (classify-error (nthcdr 0.1 (copy-tree '(a b c d)))) type-error) (deftest nthcdr.error.4 (classify-error (nthcdr #\A (copy-tree '(a b c d)))) type-error) (deftest nthcdr.error.5 (classify-error (nthcdr '(a) (copy-tree '(a b c d)))) type-error) (deftest nthcdr.error.6 (classify-error (nthcdr -10 (copy-tree '(a b c d)))) type-error) (deftest nthcdr.error.7 (classify-error (nthcdr)) program-error) (deftest nthcdr.error.8 (classify-error (nthcdr 0)) program-error) (deftest nthcdr.error.9 (classify-error (nthcdr 0 nil nil)) program-error) (deftest nthcdr.error.10 (classify-error (nthcdr 3 (cons 'a 'b))) type-error) (deftest nthcdr.error.11 (classify-error (locally (nthcdr 'a (copy-tree '(a b c d))) t)) type-error) (deftest nthcdr.1 (nthcdr 0 (copy-tree '(a b c d . e))) (a b c d . e)) (deftest nthcdr.2 (nthcdr 1 (copy-tree '(a b c d))) (b c d)) (deftest nthcdr.3 (nthcdr 10 nil) nil) (deftest nthcdr.4 (nthcdr 4 (list 'a 'b 'c)) nil) (deftest nthcdr.5 (nthcdr 1 (cons 'a 'b)) b) (deftest nthcdr.order.1 (let ((i 0) x y) (values (nthcdr (setf x (incf i)) (progn (setf y (incf i)) '(a b c d))) i x y)) (b c d) 2 1 2) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; rest (deftest rest.1 (rest (list 'a 'b 'c)) (b c)) (deftest rest.order.1 (let ((i 0)) (values (rest (progn (incf i) '(a b))) i)) (b) 1) (deftest rest.error.1 (classify-error (rest)) program-error) (deftest rest.error.2 (classify-error (rest nil nil)) program-error) gcl/ansi-tests/cons-test-13.lsp000066400000000000000000000147071242227143400166070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:38:57 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 13 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; member (deftest member.1 (let* ((x (copy-tree '(a b c d e f))) (xcopy (make-scaffold-copy x)) (result (member 'c x))) (and (eqt result (cddr x)) (check-scaffold-copy x xcopy))) t) (deftest member.2 (let* ((x (copy-tree '(a b c d e f))) (xcopy (make-scaffold-copy x)) (result (member 'e x))) (and (eqt result (cddddr x)) (check-scaffold-copy x xcopy))) t) (deftest member.3 (let* ((x (copy-tree '(1 2 3 4 5 6 7))) (xcopy (make-scaffold-copy x)) (result (member 4 x))) (and (eqt result (cdddr x)) (check-scaffold-copy x xcopy))) t) (deftest member.4 (let* ((x (copy-tree '(2 4 6 8 10 12))) (xcopy (make-scaffold-copy x)) (result (member 9 x :key #'1+))) (and (eqt result (cdddr x)) (check-scaffold-copy x xcopy))) t) (deftest member.5 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) (xcopy (make-scaffold-copy x)) (result (member '(c d) x :test #'equal))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) t) (deftest member.6 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) (xcopy (make-scaffold-copy x)) (result (member 'c x :key #'car))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) t) (deftest member.7 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) (xcopy (make-scaffold-copy x)) (result (member 'c x :key #'car :test #'eq))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) t) (deftest member.8 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) (xcopy (make-scaffold-copy x)) (result (member 'c x :key #'car :test-not (complement #'eq)))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) t) (deftest member.9 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) (xcopy (make-scaffold-copy x)) (result (member 'c x :key #'car :test #'eql))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) t) (deftest member.10 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) (xcopy (make-scaffold-copy x)) (result (member (list 'd) x :key #'cdr :test #'equal))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) t) (deftest member.11 (member (copy-seq "cc") (copy-tree '("aa" "bb" "cc" "dd" "ee"))) nil) (deftest member.12 (member 1 (copy-tree '(3 4 1 31 423))) (1 31 423)) (deftest member.13 (member (copy-seq "cc") (copy-tree '("aa" "bb" "cc" "dd" "ee")) :test #'equal) ("cc" "dd" "ee")) (deftest member.14 (member 'a nil) nil) (deftest member.15 (member nil nil) nil) (deftest member.16 (member nil nil :test #'equal) nil) (deftest member.16-a (member nil nil :test #'(lambda (x y) (error "Should not call this function"))) nil) (deftest member.17 (member 'a nil :test #'(lambda (x y) (error "Should not call this function"))) nil) ;; Check that a null key argument is ignored (deftest member.18 (member 'a '(c d a b e) :key nil) (a b e)) (deftest member.19 (member 'z '(a b c d) :key nil) nil) ;;; Order of evaluation (deftest member.order.1 (let ((i 0) x y) (values (member (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '(a b c d))) i x y)) (c d) 2 1 2) (deftest member.order.2 (let ((i 0) x y z p) (values (member (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '(a b c d)) :key (progn (setf z (incf i)) #'identity) :test (progn (setf p (incf i)) #'eq)) i x y z p)) (c d) 4 1 2 3 4) (deftest member.order.3 (let ((i 0) x y) (values (member (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '(a b c d)) :test #'eq) i x y)) (c d) 2 1 2) (deftest member.order.4 (let ((i 0) x y z p q) (values (member (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '(a b c d)) :key (progn (setf z (incf i)) #'identity) :test (progn (setf p (incf i)) #'eq) :key (progn (setf q (incf i)) (constantly 'z))) i x y z p q)) (c d) 5 1 2 3 4 5) (deftest member.order.5 (let ((i 0) x y z q) (values (member (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '(a b c d)) :test #'eq :key (progn (setf z (incf i)) #'identity) :key (progn (setf q (incf i)) (constantly 'z))) i x y z q)) (c d) 4 1 2 3 4) ;;; Keyword tests (deftest member.allow-other-keys.1 (member 'b '(a b c) :bad t :allow-other-keys t) (b c)) (deftest member.allow-other-keys.2 (member 'b '(a b c) :allow-other-keys t :bad t) (b c)) (deftest member.allow-other-keys.3 (member 'b '(a b c) :allow-other-keys t) (b c)) (deftest member.allow-other-keys.4 (member 'b '(a b c) :allow-other-keys nil) (b c)) (deftest member.allow-other-keys.5 (member 'b '(a b c) :allow-other-keys 17 :allow-other-keys nil '#:x t) (b c)) (deftest member.keywords.6 (member 'b '(a b c) :test #'eq :test (complement #'eq)) (b c)) ;;; Error cases (deftest member.error.1 (classify-error (member 'a 'b)) type-error) (deftest member.error.2 (classify-error (member 'a 1.3)) type-error) (deftest member.error.3 (classify-error (member 'a 1)) type-error) (deftest member.error.4 (classify-error (member 'a 0)) type-error) (deftest member.error.5 (classify-error (member 'a "abcde")) type-error) (deftest member.error.6 (classify-error (member 'a #\w)) type-error) (deftest member.error.7 (classify-error (member 'a t)) type-error) (deftest member.error.8 (classify-error (member)) program-error) (deftest member.error.9 (classify-error (member nil)) program-error) (deftest member.error.10 (classify-error (member nil nil :bad t)) program-error) (deftest member.error.11 (classify-error (member nil nil :test)) program-error) (deftest member.error.12 (classify-error (member nil nil :bad t :allow-other-keys nil)) program-error) (deftest member.error.13 (classify-error (member nil nil nil)) program-error) (deftest member.error.14 (classify-error (locally (member 'a t) t)) type-error) (deftest member.error.15 (classify-error (member 'a '(a b c) :test #'identity)) program-error) (deftest member.error.16 (classify-error (member 'a '(a b c) :test-not #'identity)) program-error) (deftest member.error.17 (classify-error (member 'a '(a b c) :key #'cons)) program-error) gcl/ansi-tests/cons-test-14.lsp000066400000000000000000000151151242227143400166020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:39:29 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 14 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; member-if (deftest member-if.1 (member-if #'listp nil) nil) (deftest member-if.2 (member-if #'(lambda (x) (eqt x 'a)) '(1 2 a 3 4)) (a 3 4)) (deftest member-if.3 (member-if #'(lambda (x) (eql x 12)) '(4 12 11 73 11) :key #'1+) (11 73 11)) (deftest member-if.4 (let ((test-inputs `(1 a 11.3121 11.31s3 1.123f5 -1 0 13.13122d34 581.131e-10 (a b c . d) ,(make-array '(10)) "ancadas" #\w))) (notnot-mv (every #'(lambda (x) (let ((result (catch-type-error (member-if #'listp x)))) (or (eqt result 'type-error) (progn (format t "~%On ~S: returned ~%~S" x result) nil)))) test-inputs))) t) (deftest member-if.5 (member-if #'identity '(1 2 3 4 5) :key #'evenp) (2 3 4 5)) ;;; Order of argument tests (deftest member-if.order.1 (let ((i 0) x y) (values (member-if (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '(nil nil a b nil c d))) i x y)) (a b nil c d) 2 1 2) (deftest member-if.order.2 (let ((i 0) x y z w) (values (member-if (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '(nil nil a b nil c d)) :key (progn (setf z (incf i)) #'identity) :key (progn (setf w (incf i)) #'not)) i x y z w)) (a b nil c d) 4 1 2 3 4) ;;; Keyword tests (deftest member-if.keywords.1 (member-if #'identity '(1 2 3 4 5) :key #'evenp :key #'oddp) (2 3 4 5)) (deftest member-if.allow-other-keys.2 (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t :bad t) (2 3 4 5)) (deftest member-if.allow-other-keys.3 (member-if #'identity '(nil 2 3 4 5) :bad t :allow-other-keys t) (2 3 4 5)) (deftest member-if.allow-other-keys.4 (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t) (2 3 4 5)) (deftest member-if.allow-other-keys.5 (member-if #'identity '(nil 2 3 4 5) :allow-other-keys nil) (2 3 4 5)) (deftest member-if.allow-other-keys.6 (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t :allow-other-keys nil) (2 3 4 5)) (deftest member-if.allow-other-keys.7 (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t :allow-other-keys nil :key #'identity :key #'null) (2 3 4 5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; member-if-not (deftest member-if-not.1 (member-if-not #'listp nil) nil) (deftest member-if-not.2 (member-if-not #'(lambda (x) (eqt x 'a)) '(a 1 2 a 3 4)) (1 2 a 3 4)) (deftest member-if-not.3 (member-if-not #'(lambda (x) (not (eql x 12))) '(4 12 11 73 11) :key #'1+) (11 73 11)) (deftest member-if-not.4 (let ((test-inputs `(1 a 11.3121 11.31s3 1.123f5 -1 0 13.13122d34 581.131e-10 ((a) (b) (c) . d) ,(make-array '(10)) "ancadas" #\w))) (not (every #'(lambda (x) (let ((result (catch-type-error (member-if-not #'listp x)))) (or (eqt result 'type-error) (progn (format t "~%On x = ~S, returns: ~%~S" x result) nil)))) test-inputs))) nil) (deftest member-if-not.5 (member-if-not #'not '(1 2 3 4 5) :key #'evenp) (2 3 4 5)) ;;; Order of evaluation tests (deftest member-if-not.order.1 (let ((i 0) x y) (values (member-if-not (progn (setf x (incf i)) #'not) (progn (setf y (incf i)) '(nil nil a b nil c d))) i x y)) (a b nil c d) 2 1 2) (deftest member-if-not.order.2 (let ((i 0) x y z w) (values (member-if-not (progn (setf x (incf i)) #'not) (progn (setf y (incf i)) '(nil nil a b nil c d)) :key (progn (setf z (incf i)) #'identity) :key (progn (setf w (incf i)) #'not)) i x y z w)) (a b nil c d) 4 1 2 3 4) ;;; Keyword tests (deftest member-if-not.keywords.1 (member-if-not #'not '(1 2 3 4 5) :key #'evenp :key #'oddp) (2 3 4 5)) (deftest member-if-not.allow-other-keys.2 (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t :bad t) (2 3 4 5)) (deftest member-if-not.allow-other-keys.3 (member-if-not #'not '(nil 2 3 4 5) :bad t :allow-other-keys t) (2 3 4 5)) (deftest member-if-not.allow-other-keys.4 (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t) (2 3 4 5)) (deftest member-if-not.allow-other-keys.5 (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys nil) (2 3 4 5)) (deftest member-if-not.allow-other-keys.6 (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t :allow-other-keys nil :key #'identity :key #'null) (2 3 4 5)) ;;; Error cases (deftest member-if.error.1 (classify-error (member-if #'identity 'a)) type-error) (deftest member-if.error.2 (classify-error (member-if)) program-error) (deftest member-if.error.3 (classify-error (member-if #'null)) program-error) (deftest member-if.error.4 (classify-error (member-if #'null '(a b c) :bad t)) program-error) (deftest member-if.error.5 (classify-error (member-if #'null '(a b c) :bad t :allow-other-keys nil)) program-error) (deftest member-if.error.6 (classify-error (member-if #'null '(a b c) :key)) program-error) (deftest member-if.error.7 (classify-error (member-if #'null '(a b c) 1 2)) program-error) (deftest member-if.error.8 (classify-error (locally (member-if #'identity 'a) t)) type-error) (deftest member-if.error.9 (classify-error (member-if #'cons '(a b c))) program-error) (deftest member-if.error.10 (classify-error (member-if #'identity '(a b c) :key #'cons)) program-error) (deftest member-if-not.error.1 (classify-error (member-if-not #'identity 'a)) type-error) (deftest member-if-not.error.2 (classify-error (member-if-not)) program-error) (deftest member-if-not.error.3 (classify-error (member-if-not #'null)) program-error) (deftest member-if-not.error.4 (classify-error (member-if-not #'null '(a b c) :bad t)) program-error) (deftest member-if-not.error.5 (classify-error (member-if-not #'null '(a b c) :bad t :allow-other-keys nil)) program-error) (deftest member-if-not.error.6 (classify-error (member-if-not #'null '(a b c) :key)) program-error) (deftest member-if-not.error.7 (classify-error (member-if-not #'null '(a b c) 1 2)) program-error) (deftest member-if-not.error.8 (classify-error (locally (member-if-not #'identity 'a) t)) type-error) (deftest member-if-not.error.9 (classify-error (member-if-not #'cons '(a b c))) program-error) (deftest member-if-not.error.10 (classify-error (member-if-not #'identity '(a b c) :key #'cons)) program-error) gcl/ansi-tests/cons-test-15.lsp000066400000000000000000000327461242227143400166140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:40:12 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 15 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mapc (deftest mapc.1 (mapc #'list nil) nil) (deftest mapc.2 (let ((x 0)) (let ((result (mapc #'(lambda (y) (incf x y)) '(1 2 3 4)))) (list result x))) ((1 2 3 4) 10)) (deftest mapc.3 (let ((x 0)) (list (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) (make-list 5 :initial-element 'a) (make-list 5 )) x)) ((a a a a a) 5)) (deftest mapc.4 (let ((x 0)) (list (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) (make-list 5 :initial-element 'a) (make-list 10)) x)) ((a a a a a) 5)) (deftest mapc.5 (let ((x 0)) (list (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) (make-list 5 :initial-element 'a) (make-list 3)) x)) ((a a a a a) 3)) (defvar *mapc.6-var* nil) (defun mapc.6-fun (x) (push x *mapc.6-var*) x) (deftest mapc.6 (let* ((x (copy-list '(a b c d e f g h))) (xcopy (make-scaffold-copy x))) (setf *mapc.6-var* nil) (let ((result (mapc 'mapc.6-fun x))) (and (check-scaffold-copy x xcopy) (eqt result x) *mapc.6-var*))) (h g f e d c b a)) (deftest mapc.order.1 (let ((i 0) x y z) (values (mapc (progn (setf x (incf i)) #'list) (progn (setf y (incf i)) '(a b c)) (progn (setf z (incf i)) '(1 2 3))) i x y z)) (a b c) 3 1 2 3) (deftest mapc.error.1 (classify-error (mapc #'identity 1)) type-error) (deftest mapc.error.2 (classify-error (mapc)) program-error) (deftest mapc.error.3 (classify-error (mapc #'append)) program-error) (deftest mapc.error.4 (classify-error (locally (mapc #'identity 1) t)) type-error) (deftest mapc.error.5 (classify-error (mapc #'cons '(a b c))) program-error) (deftest mapc.error.6 (classify-error (mapc #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) (deftest mapc.error.7 (classify-error (mapc #'car '(a b c))) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mapcar (deftest mapcar.1 (mapcar #'1+ nil) nil) (deftest mapcar.2 (let* ((x (copy-list '(1 2 3 4))) (xcopy (make-scaffold-copy x))) (let ((result (mapcar #'1+ x))) (and (check-scaffold-copy x xcopy) result))) (2 3 4 5)) (deftest mapcar.3 (let* ((n 0) (x (copy-list '(a b c d))) (xcopy (make-scaffold-copy x))) (let ((result (mapcar #'(lambda (y) (declare (ignore y)) (incf n)) x))) (and (check-scaffold-copy x xcopy) result))) (1 2 3 4)) (deftest mapcar.4 (let* ((n 0) (x (copy-list '(a b c d))) (xcopy (make-scaffold-copy x)) (x2 (copy-list '(a b c d e f))) (x2copy (make-scaffold-copy x2)) (result (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) x x2))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy x2 x2copy) (list result n))) ((1 2 3 4) 4)) (deftest mapcar.5 (let* ((n 0) (x (copy-list '(a b c d))) (xcopy (make-scaffold-copy x)) (x2 (copy-list '(a b c d e f))) (x2copy (make-scaffold-copy x2)) (result (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) x2 x))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy x2 x2copy) (list result n))) ((1 2 3 4) 4)) (deftest mapcar.6 (let* ((x (copy-list '(a b c d e f g h))) (xcopy (make-scaffold-copy x))) (setf *mapc.6-var* nil) (let ((result (mapcar 'mapc.6-fun x))) (and (check-scaffold-copy x xcopy) (list *mapc.6-var* result)))) ((h g f e d c b a) (a b c d e f g h))) (deftest mapcar.order.1 (let ((i 0) x y z) (values (mapcar (progn (setf x (incf i)) #'list) (progn (setf y (incf i)) '(a b c)) (progn (setf z (incf i)) '(1 2 3))) i x y z)) ((a 1) (b 2) (c 3)) 3 1 2 3) (deftest mapcar.error.1 (classify-error (mapcar #'identity 1)) type-error) (deftest mapcar.error.2 (classify-error (mapcar)) program-error) (deftest mapcar.error.3 (classify-error (mapcar #'append)) program-error) (deftest mapcar.error.4 (classify-error (locally (mapcar #'identity 1) t)) type-error) (deftest mapcar.error.5 (classify-error (mapcar #'car '(a b c))) type-error) (deftest mapcar.error.6 (classify-error (mapcar #'cons '(a b c))) program-error) (deftest mapcar.error.7 (classify-error (mapcar #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mapcan (deftest mapcan.1 (mapcan #'list nil) nil) (deftest mapcan.2 (mapcan #'list (copy-list '(a b c d e f))) (a b c d e f)) (deftest mapcan.3 (let* ((x (list 'a 'b 'c 'd)) (xcopy (make-scaffold-copy x)) (result (mapcan #'list x))) (and (= (length x) (length result)) (check-scaffold-copy x xcopy) (loop for e1 on x and e2 on result count (or (eqt e1 e2) (not (eql (car e1) (car e2))))))) 0) (deftest mapcan.4 (mapcan #'list (copy-list '(1 2 3 4)) (copy-list '(a b c d))) (1 a 2 b 3 c 4 d)) (deftest mapcan.5 (mapcan #'(lambda (x y) (make-list y :initial-element x)) (copy-list '(a b c d)) (copy-list '(1 2 3 4))) (a b b c c c d d d d)) (defvar *mapcan.6-var* nil) (defun mapcan.6-fun (x) (push x *mapcan.6-var*) (copy-list *mapcan.6-var*)) (deftest mapcan.6 (progn (setf *mapcan.6-var* nil) (mapcan 'mapcan.6-fun (copy-list '(a b c d)))) (a b a c b a d c b a)) (deftest mapcan.order.1 (let ((i 0) x y z) (values (mapcan (progn (setf x (incf i)) #'list) (progn (setf y (incf i)) '(a b c)) (progn (setf z (incf i)) '(1 2 3))) i x y z)) (a 1 b 2 c 3) 3 1 2 3) (deftest mapcan.8 (mapcan #'(lambda (x y) (make-list y :initial-element x)) (copy-list '(a b c d)) (copy-list '(1 2 3 4 5 6))) (a b b c c c d d d d)) (deftest mapcan.9 (mapcan #'(lambda (x y) (make-list y :initial-element x)) (copy-list '(a b c d e f)) (copy-list '(1 2 3 4))) (a b b c c c d d d d)) (deftest mapcan.10 (mapcan #'list (copy-list '(a b c d)) (copy-list '(1 2 3 4)) nil) nil) (deftest mapcan.11 (mapcan (constantly 1) (list 'a)) 1) (deftest mapcan.error.1 (classify-error (mapcan #'identity 1)) type-error) (deftest mapcan.error.2 (classify-error (mapcan)) program-error) (deftest mapcan.error.3 (classify-error (mapcan #'append)) program-error) (deftest mapcan.error.4 (classify-error (locally (mapcan #'identity 1) t)) type-error) (deftest mapcan.error.5 (classify-error (mapcan #'car '(a b c))) type-error) (deftest mapcan.error.6 (classify-error (mapcan #'cons '(a b c))) program-error) (deftest mapcan.error.7 (classify-error (mapcan #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mapl (deftest mapl.1 (mapl #'list nil) nil) (deftest mapl.2 (let* ((a nil) (x (copy-list '(a b c))) (xcopy (make-scaffold-copy x)) (result (mapl #'(lambda (y) (push y a)) x))) (and (check-scaffold-copy x xcopy) (eqt result x) a)) ((c) (b c) (a b c))) (deftest mapl.3 (let* ((a nil) (x (copy-list '(a b c d))) (y (copy-list '(1 2 3 4))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (mapl #'(lambda (xtail ytail) (setf a (append (mapcar #'list xtail ytail) a))) x y))) (and (eqt result x) (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) a)) ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) (a 1) (b 2) (c 3) (d 4))) (deftest mapl.4 (let* ((a nil) (x (copy-list '(a b c d))) (y (copy-list '(1 2 3 4 5 6 7 8))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (mapl #'(lambda (xtail ytail) (setf a (append (mapcar #'list xtail ytail) a))) x y))) (and (eqt result x) (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) a)) ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) (a 1) (b 2) (c 3) (d 4))) (deftest mapl.5 (let* ((a nil) (x (copy-list '(a b c d e f g))) (y (copy-list '(1 2 3 4))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (mapl #'(lambda (xtail ytail) (setf a (append (mapcar #'list xtail ytail) a))) x y))) (and (eqt result x) (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) a)) ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) (a 1) (b 2) (c 3) (d 4))) (deftest mapl.order.1 (let ((i 0) x y z) (values (mapl (progn (setf x (incf i)) (constantly nil)) (progn (setf y (incf i)) '(a b c)) (progn (setf z (incf i)) '(1 2 3))) i x y z)) (a b c) 3 1 2 3) (deftest mapl.error.1 (classify-error (mapl #'identity 1)) type-error) (deftest mapl.error.2 (classify-error (mapl)) program-error) (deftest mapl.error.3 (classify-error (mapl #'append)) program-error) (deftest mapl.error.4 (classify-error (locally (mapl #'identity 1) t)) type-error) (deftest mapl.error.5 (classify-error (mapl #'cons '(a b c))) program-error) (deftest mapl.error.6 (classify-error (mapl #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) (deftest mapl.error.7 (classify-error (mapl #'caar '(a b c))) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; maplist (deftest maplist.1 (maplist #'list nil) nil) (deftest maplist.2 (let* ((x (copy-list '(a b c))) (xcopy (make-scaffold-copy x)) (result (maplist #'identity x))) (and (check-scaffold-copy x xcopy) result)) ((a b c) (b c) (c))) (deftest maplist.3 (let* ((x (copy-list '(a b c d))) (y (copy-list '(1 2 3 4))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (maplist #'append x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) result)) ((a b c d 1 2 3 4) (b c d 2 3 4) (c d 3 4) (d 4))) (deftest maplist.4 (let* ((x (copy-list '(a b c d))) (y (copy-list '(1 2 3 4 5))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (maplist #'append x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) result)) ((a b c d 1 2 3 4 5) (b c d 2 3 4 5) (c d 3 4 5) (d 4 5))) (deftest maplist.5 (let* ((x (copy-list '(a b c d e))) (y (copy-list '(1 2 3 4))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (maplist #'append x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) result)) ((a b c d e 1 2 3 4) (b c d e 2 3 4) (c d e 3 4) (d e 4))) (deftest maplist.6 (maplist 'append '(a b c) '(1 2 3)) ((a b c 1 2 3) (b c 2 3) (c 3))) (deftest maplist.7 (maplist #'(lambda (x y) (nth (car x) y)) '(0 1 0 1 0 1 0) '(a b c d e f g) ) (a c c e e g g)) (deftest maplist.order.1 (let ((i 0) x y z) (values (maplist (progn (setf x (incf i)) #'(lambda (x y) (declare (ignore x)) (car y))) (progn (setf y (incf i)) '(a b c)) (progn (setf z (incf i)) '(1 2 3))) i x y z)) (1 2 3) 3 1 2 3) (deftest maplist.error.1 (classify-error (maplist #'identity 'a)) type-error) (deftest maplist.error.2 (classify-error (maplist #'identity 1)) type-error) (deftest maplist.error.3 (classify-error (maplist #'identity 1.1323)) type-error) (deftest maplist.error.4 (classify-error (maplist #'identity "abcde")) type-error) (deftest maplist.error.5 (classify-error (maplist)) program-error) (deftest maplist.error.6 (classify-error (maplist #'append)) program-error) (deftest maplist.error.7 (classify-error (locally (maplist #'identity 'a) t)) type-error) (deftest maplist.error.8 (classify-error (maplist #'caar '(a b c))) type-error) (deftest maplist.error.9 (classify-error (maplist #'cons '(a b c))) program-error) (deftest maplist.error.10 (classify-error (maplist #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mapcon (deftest mapcon.1 (mapcon #'(lambda (x) (append '(a) x nil)) nil) nil) (deftest mapcon.2 (let* ((x (copy-list '(1 2 3 4))) (xcopy (make-scaffold-copy x)) (result (mapcon #'(lambda (y) (append '(a) y nil)) x))) (and (check-scaffold-copy x xcopy) result)) (a 1 2 3 4 a 2 3 4 a 3 4 a 4)) (deftest mapcon.3 (let* ((x (copy-list '(4 2 3 2 2))) (y (copy-list '(a b c d e f g h i j k l))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (mapcon #'(lambda (xt yt) (subseq yt 0 (car xt))) x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) result)) (a b c d b c c d e d e e f)) (deftest mapcon.4 (mapcon (constantly 1) (list 'a)) 1) (deftest mapcon.order.1 (let ((i 0) x y z) (values (mapcon (progn (setf x (incf i)) #'(lambda (x y) (list (car x) (car y)))) (progn (setf y (incf i)) '(a b c)) (progn (setf z (incf i)) '(1 2 3))) i x y z)) (a 1 b 2 c 3) 3 1 2 3) (deftest mapcon.error.1 (classify-error (mapcon #'identity 1)) type-error) (deftest mapcon.error.2 (classify-error (mapcon)) program-error) (deftest mapcon.error.3 (classify-error (mapcon #'append)) program-error) (deftest mapcon.error.4 (classify-error (locally (mapcon #'identity 1) t)) type-error) (deftest mapcon.error.5 (classify-error (mapcon #'caar '(a b c))) type-error) (deftest mapcon.error.6 (classify-error (mapcon #'cons '(a b c))) program-error) (deftest mapcon.error.7 (classify-error (mapcon #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) gcl/ansi-tests/cons-test-16.lsp000066400000000000000000000376141242227143400166140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:41:13 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 16 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; acons (deftest acons.1 (let* ((x (copy-tree '((c . d) (e . f)))) (xcopy (make-scaffold-copy x)) (result (acons 'a 'b x))) (and (check-scaffold-copy x xcopy) (eqt (cdr result) x) result)) ((a . b) (c . d) (e . f))) (deftest acons.2 (acons 'a 'b nil) ((a . b))) (deftest acons.3 (acons 'a 'b 'c) ((a . b) . c)) (deftest acons.4 (acons '((a b)) '(((c d) e) f) '((1 . 2))) (( ((a b)) . (((c d) e) f)) (1 . 2))) (deftest acons.5 (acons "ancd" 1.143 nil) (("ancd" . 1.143))) (deftest acons.6 (acons #\R :foo :bar) ((#\R . :foo) . :bar)) (deftest acons.order.1 (let ((i 0) x y z) (values (acons (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) 'b) (progn (setf z (incf i)) '((c . d)))) i x y z)) ((a . b)(c . d)) 3 1 2 3) (deftest acons.error.1 (classify-error (acons)) program-error) (deftest acons.error.2 (classify-error (acons 'a)) program-error) (deftest acons.error.3 (classify-error (acons 'a 'b)) program-error) (deftest acons.error.4 (classify-error (acons 'a 'b 'c 'd)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; assoc (deftest assoc.1 (assoc nil nil) nil) (deftest assoc.2 (assoc nil '(nil)) nil) (deftest assoc.3 (assoc nil '(nil (nil . 2) (a . b))) (nil . 2)) (deftest assoc.4 (assoc nil '((a . b) (c . d))) nil) (deftest assoc.5 (assoc 'a '((a . b))) (a . b)) (deftest assoc.6 (assoc 'a '((:a . b) (#:a . c) (a . d) (a . e) (z . f))) (a . d)) (deftest assoc.7 (let* ((x (copy-tree '((a . b) (b . c) (c . d)))) (xcopy (make-scaffold-copy x)) (result (assoc 'b x))) (and (eqt result (second x)) (check-scaffold-copy x xcopy))) t) (deftest assoc.8 (assoc 1 '((0 . a) (1 . b) (2 . c))) (1 . b)) (deftest assoc.9 (assoc (copy-seq "abc") '((abc . 1) ("abc" . 2) ("abc" . 3))) nil) (deftest assoc.10 (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c))))) nil) (deftest assoc.11 (let ((x (list 'a 'b))) (assoc x `(((a b) c) (,x . d) (,x . e) ((a b) 1)))) ((a b) . d)) (deftest assoc.12 (assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)) :key #'(lambda (x) (char x 1))) ("aevgd" . 2)) (deftest assoc.13 (assoc nil '(((a) . b) ( nil . c ) ((nil) . d)) :key #'car) (nil . c)) (deftest assoc.14 (assoc (copy-seq "abc") '((abc . 1) ("abc" . 2) ("abc" . 3)) :test #'equal) ("abc" . 2)) (deftest assoc.15 (assoc (copy-seq "abc") '((abc . 1) ("abc" . 2) ("abc" . 3)) :test #'equalp) ("abc" . 2)) (deftest assoc.16 (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c)))) :test #'equal) ((a) b)) (deftest assoc.17 (assoc (copy-seq "abc") '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)) :test-not (complement #'equalp)) ("abc" . 2)) (deftest assoc.18 (assoc 'a '((a . d)(b . c)) :test-not #'eq) (b . c)) (deftest assoc.19 (assoc 'a '((a . d)(b . c)) :test (complement #'eq)) (b . c)) (deftest assoc.20 (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) :key #'(lambda (x) (and (stringp x) (string-downcase x))) :test #'equal) ("A" . 6)) (deftest assoc.21 (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) :key #'(lambda (x) (and (stringp x) x)) :test #'equal) ("a" . 3)) (deftest assoc.22 (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) :key #'(lambda (x) (and (stringp x) (string-downcase x))) :test-not (complement #'equal)) ("A" . 6)) (deftest assoc.23 (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) :key #'(lambda (x) (and (stringp x) x)) :test-not (complement #'equal)) ("a" . 3)) ;; Check that it works when test returns a true value ;; other than T (deftest assoc.24 (assoc 'a '((b . 1) (a . 2) (c . 3)) :test #'(lambda (x y) (and (eqt x y) 'matched))) (a . 2)) ;; Check that the order of the arguments to test is correct (deftest assoc.25 (block fail (assoc 'a '((b . 1) (c . 2) (a . 3)) :test #'(lambda (x y) (unless (eqt x 'a) (return-from fail 'fail)) (eqt x y)))) (a . 3)) ;;; Order of argument evaluation (deftest assoc.order.1 (let ((i 0) x y) (values (assoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4)))) i x y)) (c . 3) 2 1 2) (deftest assoc.order.2 (let ((i 0) x y z) (values (assoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) :test (progn (setf z (incf i)) #'eq)) i x y z)) (c . 3) 3 1 2 3) (deftest assoc.order.3 (let ((i 0) x y) (values (assoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) :test #'eq) i x y)) (c . 3) 2 1 2) (deftest assoc.order.4 (let ((i 0) x y z w) (values (assoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) :key (progn (setf z (incf i)) #'identity) :key (progn (setf w (incf i)) #'not)) i x y z w)) (c . 3) 4 1 2 3 4) ;;; Keyword tests (deftest assoc.allow-other-keys.1 (assoc 'b '((a . 1) (b . 2) (c . 3)) :bad t :allow-other-keys t) (b . 2)) (deftest assoc.allow-other-keys.2 (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t) (b . 2)) (deftest assoc.allow-other-keys.3 (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t :test-not #'eql) (a . 1)) (deftest assoc.allow-other-keys.4 (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t) (b . 2)) (deftest assoc.allow-other-keys.5 (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys nil) (b . 2)) (deftest assoc.keywords.6 (assoc 'b '((a . 1) (b . 2) (c . 3)) :key #'identity :key #'null) (b . 2)) (deftest assoc.keywords.7 (assoc 'b '((a . 1) (b . 2) (c . 3)) :key nil :key #'null) (b . 2)) (deftest assoc.error.1 (classify-error (assoc)) program-error) (deftest assoc.error.2 (classify-error (assoc nil)) program-error) (deftest assoc.error.3 (classify-error (assoc nil nil :bad t)) program-error) (deftest assoc.error.4 (classify-error (assoc nil nil :key)) program-error) (deftest assoc.error.5 (classify-error (assoc nil nil 1 1)) program-error) (deftest assoc.error.6 (classify-error (assoc nil nil :bad t :allow-other-keys nil)) program-error) (deftest assoc.error.7 (classify-error (assoc 'a '((a . b)) :test #'identity)) program-error) (deftest assoc.error.8 (classify-error (assoc 'a '((a . b)) :test-not #'identity)) program-error) (deftest assoc.error.9 (classify-error (assoc 'a '((a . b)) :key #'cons)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; assoc-if (deftest assoc-if.1 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (assoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (6 . c)) (deftest assoc-if.2 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (assoc-if #'oddp x :key #'1+))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (6 . c)) (deftest assoc-if.3 (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (assoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) (eqt result (fourth x)) result)) (6 . c)) (deftest assoc-if.4 (assoc-if #'null '((a . b) nil (c . d) (nil . e) (f . g))) (nil . e)) ;;; Order of argument evaluation (deftest assoc-if.order.1 (let ((i 0) x y) (values (assoc-if (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '((a . 1) (b . 2) (nil . 17) (d . 4)))) i x y)) (nil . 17) 2 1 2) (deftest assoc-if.order.2 (let ((i 0) x y z) (values (assoc-if (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '((a . 1) (b . 2) (nil . 17) (d . 4))) :key (progn (setf z (incf i)) #'null)) i x y z)) (a . 1) 3 1 2 3) ;;; Keyword tests (deftest assoc-if.allow-other-keys.1 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) (nil . 2)) (deftest assoc-if.allow-other-keys.2 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t :also-bad t) (nil . 2)) (deftest assoc-if.allow-other-keys.3 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t :also-bad t :key #'not) (a . 1)) (deftest assoc-if.allow-other-keys.4 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t) (nil . 2)) (deftest assoc-if.allow-other-keys.5 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil) (nil . 2)) (deftest assoc-if.keywords.6 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key #'identity :key #'null) (nil . 2)) (deftest assoc-if.keywords.7 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null) (nil . 2)) ;;; Error cases (deftest assoc-if.error.1 (classify-error (assoc-if)) program-error) (deftest assoc-if.error.2 (classify-error (assoc-if #'null)) program-error) (deftest assoc-if.error.3 (classify-error (assoc-if #'null nil :bad t)) program-error) (deftest assoc-if.error.4 (classify-error (assoc-if #'null nil :key)) program-error) (deftest assoc-if.error.5 (classify-error (assoc-if #'null nil 1 1)) program-error) (deftest assoc-if.error.6 (classify-error (assoc-if #'null nil :bad t :allow-other-keys nil)) program-error) (deftest assoc-if.error.7 (classify-error (assoc-if #'cons '((a b)(c d)))) program-error) (deftest assoc-if.error.8 (classify-error (assoc-if #'identity '((a b)(c d)) :key #'cons)) program-error) (deftest assoc-if.error.9 (classify-error (assoc-if #'car '((a b)(c d)))) type-error) (deftest assoc-if.error.10 (classify-error (assoc-if #'identity '((a b)(c d)) :key #'car)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; assoc-if-not (deftest assoc-if-not.1 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (assoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (6 . c)) (deftest assoc-if-not.2 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (assoc-if-not #'evenp x :key #'1+))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (6 . c)) (deftest assoc-if-not.3 (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (assoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) (eqt result (fourth x)) result)) (6 . c)) (deftest assoc-if-not.4 (assoc-if-not #'identity '((a . b) nil (c . d) (nil . e) (f . g))) (nil . e)) ;;; Order of argument evaluation tests (deftest assoc-if-not.order.1 (let ((i 0) x y) (values (assoc-if-not (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '((a . 1) (b . 2) (nil . 17) (d . 4)))) i x y)) (nil . 17) 2 1 2) (deftest assoc-if-not.order.2 (let ((i 0) x y z) (values (assoc-if-not (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '((a . 1) (b . 2) (nil . 17) (d . 4))) :key (progn (setf z (incf i)) #'null)) i x y z)) (a . 1) 3 1 2 3) ;;; Keyword tests (deftest assoc-if-not.allow-other-keys.1 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) (nil . 2)) (deftest assoc-if-not.allow-other-keys.2 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t :also-bad t) (nil . 2)) (deftest assoc-if-not.allow-other-keys.3 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t :also-bad t :key #'not) (a . 1)) (deftest assoc-if-not.allow-other-keys.4 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t) (nil . 2)) (deftest assoc-if-not.allow-other-keys.5 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil) (nil . 2)) (deftest assoc-if-not.keywords.6 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :key #'identity :key #'null) (nil . 2)) (deftest assoc-if-not.keywords.7 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null) (nil . 2)) ;;; Error tests (deftest assoc-if-not.error.1 (classify-error (assoc-if-not)) program-error) (deftest assoc-if-not.error.2 (classify-error (assoc-if-not #'null)) program-error) (deftest assoc-if-not.error.3 (classify-error (assoc-if-not #'null nil :bad t)) program-error) (deftest assoc-if-not.error.4 (classify-error (assoc-if-not #'null nil :key)) program-error) (deftest assoc-if-not.error.5 (classify-error (assoc-if-not #'null nil 1 1)) program-error) (deftest assoc-if-not.error.6 (classify-error (assoc-if-not #'null nil :bad t :allow-other-keys nil)) program-error) (deftest assoc-if-not.error.7 (classify-error (assoc-if-not #'cons '((a b)(c d)))) program-error) (deftest assoc-if-not.error.8 (classify-error (assoc-if-not #'identity '((a b)(c d)) :key #'cons)) program-error) (deftest assoc-if-not.error.9 (classify-error (assoc-if-not #'car '((a b)(c d)))) type-error) (deftest assoc-if-not.error.10 (classify-error (assoc-if-not #'identity '((a b)(c d)) :key #'car)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; copy-alist (deftest copy-alist-1 (let* ((x (copy-tree '((a . b) (c . d) nil (e f) ((x) ((y z)) w) ("foo" . "bar") (#\w . 1.234) (1/3 . 4123.4d5)))) (xcopy (make-scaffold-copy x)) (result (copy-alist x))) (and (check-scaffold-copy x xcopy) (= (length x) (length result)) (every #'(lambda (p1 p2) (or (and (null p1) (null p2)) (and (not (eqt p1 p2)) (eqt (car p1) (car p2)) (eqt (cdr p1) (cdr p2))))) x result) t)) t) (deftest copy-alist.error.1 (classify-error (copy-alist)) program-error) (deftest copy-alist.error.2 (classify-error (copy-alist nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; pairlis ;; Pairlis has two legal behaviors: the pairs ;; can be prepended in the same order, or in the ;; reverse order, that they appear in the first ;; two arguments (defun my-pairlis (x y &optional alist) (if (null x) alist (acons (car x) (car y) (my-pairlis (cdr x) (cdr y) alist)))) (deftest pairlis-1 (pairlis nil nil nil) nil) (deftest pairlis-2 (pairlis '(a) '(b) nil) ((a . b))) (deftest pairlis-3 (let* ((x (copy-list '(a b c d e))) (xcopy (make-scaffold-copy x)) (y (copy-list '(1 2 3 4 5))) (ycopy (make-scaffold-copy y)) (result (pairlis x y)) (expected (my-pairlis x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (or (equal result expected) (equal result (reverse expected))) t)) t) (deftest pairlis-4 (let* ((x (copy-list '(a b c d e))) (xcopy (make-scaffold-copy x)) (y (copy-list '(1 2 3 4 5))) (ycopy (make-scaffold-copy y)) (z '((x . 10) (y . 20))) (zcopy (make-scaffold-copy z)) (result (pairlis x y z)) (expected (my-pairlis x y z))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (check-scaffold-copy z zcopy) (eqt (cdr (cddr (cddr result))) z) (or (equal result expected) (equal result (append (reverse (subseq expected 0 5)) (subseq expected 5)))) t)) t) (deftest pairlis.error.1 (classify-error (pairlis)) program-error) (deftest pairlis.error.2 (classify-error (pairlis nil)) program-error) (deftest pairlis.error.3 (classify-error (pairlis nil nil nil nil)) program-error) gcl/ansi-tests/cons-test-17.lsp000066400000000000000000000320221242227143400166010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 09:45:22 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 17 (in-package :cl-test) (declaim (optimize (safety 3))) (defun rev-assoc-list (x) (cond ((null x) nil) ((null (car x)) (cons nil (rev-assoc-list (cdr x)))) (t (acons (cdar x) (caar x) (rev-assoc-list (cdr x)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; rassoc (deftest rassoc.1 (rassoc nil nil) nil) (deftest rassoc.2 (rassoc nil '(nil)) nil) (deftest rassoc.3 (rassoc nil (rev-assoc-list '(nil (nil . 2) (a . b)))) (2 . nil)) (deftest rassoc.4 (rassoc nil '((a . b) (c . d))) nil) (deftest rassoc.5 (rassoc 'a '((b . a))) (b . a)) (deftest rassoc.6 (rassoc 'a (rev-assoc-list '((:a . b) (#:a . c) (a . d) (a . e) (z . f)))) (d . a)) (deftest rassoc.7 (let* ((x (copy-tree (rev-assoc-list '((a . b) (b . c) (c . d))))) (xcopy (make-scaffold-copy x)) (result (rassoc 'b x))) (and (eqt result (second x)) (check-scaffold-copy x xcopy))) t) (deftest rassoc.8 (rassoc 1 (rev-assoc-list '((0 . a) (1 . b) (2 . c)))) (b . 1)) (deftest rassoc.9 (rassoc (copy-seq "abc") (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3)))) nil) (deftest rassoc.10 (rassoc (copy-list '(a)) (copy-tree (rev-assoc-list '(((a) b) ((a) (c)))))) nil) (deftest rassoc.11 (let ((x (list 'a 'b))) (rassoc x (rev-assoc-list `(((a b) c) (,x . d) (,x . e) ((a b) 1))))) (d a b)) (deftest rassoc.12 (rassoc #\e (copy-tree (rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)))) :key #'(lambda (x) (char x 1))) (2 . "aevgd")) (deftest rassoc.13 (rassoc nil (copy-tree (rev-assoc-list '(((a) . b) ( nil . c ) ((nil) . d)))) :key #'car) (c)) (deftest rassoc.14 (rassoc (copy-seq "abc") (copy-tree (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3)))) :test #'equal) (2 . "abc")) (deftest rassoc.15 (rassoc (copy-seq "abc") (copy-tree (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3)))) :test #'equalp) (2 . "abc")) (deftest rassoc.16 (rassoc (copy-list '(a)) (copy-tree (rev-assoc-list '(((a) b) ((a) (c))))) :test #'equal) ((b) a)) (deftest rassoc.17 (rassoc (copy-seq "abc") (copy-tree (rev-assoc-list '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)))) :test-not (complement #'equalp)) (2 . "abc")) (deftest rassoc.18 (rassoc 'a (copy-tree (rev-assoc-list '((a . d)(b . c)))) :test-not #'eq) (c . b)) (deftest rassoc.19 (rassoc 'a (copy-tree (rev-assoc-list '((a . d)(b . c)))) :test (complement #'eq)) (c . b)) (deftest rassoc.20 (rassoc "a" (copy-tree (rev-assoc-list '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) :key #'(lambda (x) (and (stringp x) (string-downcase x))) :test #'equal) (6 . "A")) (deftest rassoc.21 (rassoc "a" (copy-tree (rev-assoc-list '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) :key #'(lambda (x) (and (stringp x) x)) :test #'equal) (3 . "a")) (deftest rassoc.22 (rassoc "a" (copy-tree (rev-assoc-list '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) :key #'(lambda (x) (and (stringp x) (string-downcase x))) :test-not (complement #'equal)) (6 . "A")) (deftest rassoc.23 (rassoc "a" (copy-tree (rev-assoc-list '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) :key #'(lambda (x) (and (stringp x) x)) :test-not (complement #'equal)) (3 . "a")) ;; Check that it works when test returns a true value ;; other than T (deftest rassoc.24 (rassoc 'a (copy-tree (rev-assoc-list '((b . 1) (a . 2) (c . 3)))) :test #'(lambda (x y) (and (eqt x y) 'matched))) (2 . a)) ;; Check that the order of the arguments to :test is correct (deftest rassoc.25 (block fail (rassoc 'a '((1 . b) (2 . c) (3 . a)) :test #'(lambda (x y) (unless (eqt x 'a) (return-from fail 'fail)) (eqt x y)))) (3 . a)) ;;; Order of argument evaluation (deftest rassoc.order.1 (let ((i 0) x y) (values (rassoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c)))) i x y)) (3 . c) 2 1 2) (deftest rassoc.order.2 (let ((i 0) x y z) (values (rassoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) :test (progn (setf z (incf i)) #'eql)) i x y z)) (3 . c) 3 1 2 3) (deftest rassoc.order.3 (let ((i 0) x y) (values (rassoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) :test #'eql) i x y)) (3 . c) 2 1 2) (deftest rassoc.order.4 (let ((i 0) x y z w) (values (rassoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) :key (progn (setf z (incf i)) #'identity) :key (progn (setf w (incf i)) #'not)) i x y z w)) (3 . c) 4 1 2 3 4) ;;; Keyword tests (deftest rassoc.allow-other-keys.1 (rassoc 'b '((1 . a) (2 . b) (3 . c)) :bad t :allow-other-keys t) (2 . b)) (deftest rassoc.allow-other-keys.2 (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys t :bad t) (2 . b)) (deftest rassoc.allow-other-keys.3 (rassoc 'a '((1 . a) (2 . b) (3 . c)) :allow-other-keys t :bad t :test-not #'eql) (2 . b)) (deftest rassoc.allow-other-keys.4 (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys t) (2 . b)) (deftest rassoc.allow-other-keys.5 (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys nil) (2 . b)) (deftest rassoc.keywords.6 (rassoc 'b '((1 . a) (2 . b) (3 . c)) :test #'eql :test (complement #'eql)) (2 . b)) ;;; Error tests (deftest rassoc.error.1 (classify-error (rassoc)) program-error) (deftest rassoc.error.2 (classify-error (rassoc nil)) program-error) (deftest rassoc.error.3 (classify-error (rassoc nil nil :bad t)) program-error) (deftest rassoc.error.4 (classify-error (rassoc nil nil :key)) program-error) (deftest rassoc.error.5 (classify-error (rassoc nil nil 1 1)) program-error) (deftest rassoc.error.6 (classify-error (rassoc nil nil :bad t :allow-other-keys nil)) program-error) (deftest rassoc.error.7 (classify-error (rassoc 'a '((b . a)(c . d)) :test #'identity)) program-error) (deftest rassoc.error.8 (classify-error (rassoc 'a '((b . a)(c . d)) :test-not #'identity)) program-error) (deftest rassoc.error.9 (classify-error (rassoc 'a '((b . a)(c . d)) :key #'cons)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; rassoc-if (deftest rassoc-if.1 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (rassoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (c . 6)) (deftest rassoc-if.2 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (rassoc-if #'oddp x :key #'1+))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (c . 6)) (deftest rassoc-if.3 (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (rassoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) (eqt result (fourth x)) result)) (c . 6)) (deftest rassoc-if.4 (rassoc-if #'null (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) (e)) ;;; Order of argument evaluation (deftest rassoc-if.order.1 (let ((i 0) x y) (values (rassoc-if (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '((1 . a) (2 . b) (17) (4 . d)))) i x y)) (17) 2 1 2) (deftest rassoc-if.order.2 (let ((i 0) x y z) (values (rassoc-if (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '((1 . a) (2 . b) (17) (4 . d))) :key (progn (setf z (incf i)) #'null)) i x y z)) (1 . a) 3 1 2 3) ;;; Keyword tests (deftest rassoc-if.allow-other-keys.1 (rassoc-if #'null '((1 . a) (2) (3 . c)) :bad t :allow-other-keys t) (2)) (deftest rassoc-if.allow-other-keys.2 (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t) (2)) (deftest rassoc-if.allow-other-keys.3 (rassoc-if #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t :key 'not) (2)) (deftest rassoc-if.allow-other-keys.4 (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys t) (2)) (deftest rassoc-if.allow-other-keys.5 (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys nil) (2)) (deftest rassoc-if.keywords.6 (rassoc-if #'identity '((1 . a) (2) (3 . c)) :key #'not :key #'identity) (2)) ;;; Error tests (deftest rassoc-if.error.1 (classify-error (rassoc-if)) program-error) (deftest rassoc-if.error.2 (classify-error (rassoc-if #'null)) program-error) (deftest rassoc-if.error.3 (classify-error (rassoc-if #'null nil :bad t)) program-error) (deftest rassoc-if.error.4 (classify-error (rassoc-if #'null nil :key)) program-error) (deftest rassoc-if.error.5 (classify-error (rassoc-if #'null nil 1 1)) program-error) (deftest rassoc-if.error.6 (classify-error (rassoc-if #'null nil :bad t :allow-other-keys nil)) program-error) (deftest rassoc-if.error.7 (classify-error (rassoc-if #'cons '((a . b)(c . d)))) program-error) (deftest rassoc-if.error.8 (classify-error (rassoc-if #'car '((a . b)(c . d)))) type-error) (deftest rassoc-if.error.9 (classify-error (rassoc-if #'identity '((a . b)(c . d)) :key #'cons)) program-error) (deftest rassoc-if.error.10 (classify-error (rassoc-if #'identity '((a . b)(c . d)) :key #'car)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; rassoc-if-not (deftest rassoc-if-not.1 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (rassoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (c . 6)) (deftest rassoc-if-not.2 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (rassoc-if-not #'evenp x :key #'1+))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (c . 6)) (deftest rassoc-if-not.3 (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (rassoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) (eqt result (fourth x)) result)) (c . 6)) (deftest rassoc-if-not.4 (rassoc-if-not #'identity (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) (e)) ;;; Order of argument evaluation (deftest rassoc-if-not.order.1 (let ((i 0) x y) (values (rassoc-if-not (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '((1 . a) (2 . b) (17) (4 . d)))) i x y)) (17) 2 1 2) (deftest rassoc-if-not.order.2 (let ((i 0) x y z) (values (rassoc-if-not (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '((1 . a) (2 . b) (17) (4 . d))) :key (progn (setf z (incf i)) #'null)) i x y z)) (1 . a) 3 1 2 3) ;;; Keyword tests (deftest rassoc-if-not.allow-other-keys.1 (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :bad t :allow-other-keys t) (2)) (deftest rassoc-if-not.allow-other-keys.2 (rassoc-if-not #'values '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t) (2)) (deftest rassoc-if-not.allow-other-keys.3 (rassoc-if-not #'not '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t :key 'not) (2)) (deftest rassoc-if-not.allow-other-keys.4 (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t) (2)) (deftest rassoc-if-not.allow-other-keys.5 (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys nil) (2)) (deftest rassoc-if-not.allow-other-keys.6 (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t :allow-other-keys nil :bad t) (2)) (deftest rassoc-if-not.keywords.7 (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :key #'not :key nil) (1 . a)) ;;; Error tests (deftest rassoc-if-not.error.1 (classify-error (rassoc-if-not)) program-error) (deftest rassoc-if-not.error.2 (classify-error (rassoc-if-not #'null)) program-error) (deftest rassoc-if-not.error.3 (classify-error (rassoc-if-not #'null nil :bad t)) program-error) (deftest rassoc-if-not.error.4 (classify-error (rassoc-if-not #'null nil :key)) program-error) (deftest rassoc-if-not.error.5 (classify-error (rassoc-if-not #'null nil 1 1)) program-error) (deftest rassoc-if-not.error.6 (classify-error (rassoc-if-not #'null nil :bad t :allow-other-keys nil)) program-error) (deftest rassoc-if-not.error.7 (classify-error (rassoc-if-not #'cons '((a . b)(c . d)))) program-error) (deftest rassoc-if-not.error.8 (classify-error (rassoc-if-not #'car '((a . b)(c . d)))) type-error) (deftest rassoc-if-not.error.9 (classify-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'cons)) program-error) (deftest rassoc-if-not.error.10 (classify-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'car)) type-error) gcl/ansi-tests/cons-test-18.lsp000066400000000000000000000155621242227143400166140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 10:23:31 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 18 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; get-properties (deftest get-properties.1 (get-properties nil nil) nil nil nil) (deftest get-properties.2 (get-properties '(a b) nil) nil nil nil) (deftest get-properties.3 (get-properties '(a b c d) '(a)) a b (a b c d)) (deftest get-properties.4 (get-properties '(a b c d) '(c)) c d (c d)) (deftest get-properties.5 (get-properties '(a b c d) '(c a)) a b (a b c d)) (deftest get-properties.6 (get-properties '(a b c d) '(b)) nil nil nil) (deftest get-properties.7 (get-properties '("aa" b c d) (list (copy-seq "aa"))) nil nil nil) (deftest get-properties.8 (get-properties '(1000000000000 b c d) (list (1+ 999999999999))) nil nil nil) (deftest get-properties.9 (let* ((x (copy-list '(a b c d e f g h a c))) (xcopy (make-scaffold-copy x)) (y (copy-list '(x y f g))) (ycopy (make-scaffold-copy y))) (multiple-value-bind (indicator value tail) (get-properties x y) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (eqt tail (nthcdr 6 x)) (values indicator value tail)))) g h (g h a c)) (deftest get-properties.order.1 (let ((i 0) x y) (values (multiple-value-list (get-properties (progn (setf x (incf i)) '(a b c d)) (progn (setf y (incf i)) '(c)))) i x y)) (c d (c d)) 2 1 2) (deftest get-properties.error.1 (classify-error (get-properties)) program-error) (deftest get-properties.error.2 (classify-error (get-properties nil)) program-error) (deftest get-properties.error.3 (classify-error (get-properties nil nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; getf (deftest getf.1 (getf nil 'a) nil) (deftest getf.2 (getf nil 'a 'b) b) (deftest getf.3 (getf '(a b) 'a) b) (deftest getf.4 (getf '(a b) 'a 'c) b) (deftest getf.5 (let ((x 0)) (values (getf '(a b) 'a (incf x)) x)) b 1) (deftest getf.order.1 (let ((i 0) x y) (values (getf (progn (setf x (incf i)) '(a b)) (progn (setf y (incf i)) 'a)) i x y)) b 2 1 2) (deftest getf.order.2 (let ((i 0) x y z) (values (getf (progn (setf x (incf i)) '(a b)) (progn (setf y (incf i)) 'a) (setf z (incf i))) i x y z)) b 3 1 2 3) (deftest setf-getf.1 (let ((p (copy-list '(a 1 b 2)))) (setf (getf p 'c) 3) ;; Must check that only a, b, c have properties (and (eqlt (getf p 'a) 1) (eqlt (getf p 'b) 2) (eqlt (getf p 'c) 3) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b c)))) 0) t)) t) (deftest setf-getf.2 (let ((p (copy-list '(a 1 b 2)))) (setf (getf p 'a) 3) ;; Must check that only a, b have properties (and (eqlt (getf p 'a) 3) (eqlt (getf p 'b) 2) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b)))) 0) t)) t) (deftest setf-getf.3 (let ((p (copy-list '(a 1 b 2)))) (setf (getf p 'c 17) 3) ;; Must check that only a, b, c have properties (and (eqlt (getf p 'a) 1) (eqlt (getf p 'b) 2) (eqlt (getf p 'c) 3) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b c)))) 0) t)) t) (deftest setf-getf.4 (let ((p (copy-list '(a 1 b 2)))) (setf (getf p 'a 17) 3) ;; Must check that only a, b have properties (and (eqlt (getf p 'a) 3) (eqlt (getf p 'b) 2) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b)))) 0) t)) t) (deftest setf-getf.5 (let ((p (copy-list '(a 1 b 2))) (foo nil)) (setf (getf p 'a (progn (setf foo t) 0)) 3) ;; Must check that only a, b have properties (and (eqlt (getf p 'a) 3) (eqlt (getf p 'b) 2) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b)))) 0) foo)) t) (deftest setf-getf.order.1 (let ((p (list (copy-list '(a 1 b 2)))) (cnt1 0) (cnt2 0) (cnt3 0)) (setf (getf (car (progn (incf cnt1) p)) 'c (incf cnt3)) (progn (incf cnt2) 3)) ;; Must check that only a, b, c have properties (and (eqlt cnt1 1) (eqlt cnt2 1) (eqlt cnt3 1) (eqlt (getf (car p) 'a) 1) (eqlt (getf (car p) 'b) 2) (eqlt (getf (car p) 'c) 3) (eqlt (loop for ptr on (car p) by #'cddr count (not (member (car ptr) '(a b c)))) 0) t)) t) (deftest setf-getf.order.2 (let ((p (list (copy-list '(a 1 b 2)))) (i 0) x y z w) (setf (getf (car (progn (setf x (incf i)) p)) (progn (setf y (incf i)) 'c) (setf z (incf i))) (progn (setf w (incf i)) 3)) ;; Must check that only a, b, c have properties (and (eqlt i 4) (eqlt x 1) (eqlt y 2) (eqlt z 3) (eqlt w 4) (eqlt (getf (car p) 'a) 1) (eqlt (getf (car p) 'b) 2) (eqlt (getf (car p) 'c) 3) (eqlt (loop for ptr on (car p) by #'cddr count (not (member (car ptr) '(a b c)))) 0) t)) t) (deftest incf-getf.1 (let ((p (copy-list '(a 1 b 2)))) (incf (getf p 'b)) ;; Must check that only a, b have properties (and (eqlt (getf p 'a) 1) (eqlt (getf p 'b) 3) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b)))) 0) t)) t) (deftest incf-getf.2 (let ((p (copy-list '(a 1 b 2)))) (incf (getf p 'c 19)) ;; Must check that only a, b have properties (and (eqlt (getf p 'a) 1) (eqlt (getf p 'b) 2) (eqlt (getf p 'c) 20) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b c)))) 0) t)) t) (deftest push-getf.1 (let ((p nil)) (values (push 'x (getf p 'a)) p)) (x) (a (x))) (deftest getf.error.1 (classify-error (getf)) program-error) (deftest getf.error.2 (classify-error (getf nil)) program-error) (deftest getf.error.3 (classify-error (getf nil nil nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; remf (deftest remf.1 (let ((x nil)) (values (remf x 'a) x)) nil ()) (deftest remf.2 (let ((x (list 'a 'b))) (values (not (null (remf x 'a))) x)) t ()) (deftest remf.3 (let ((x (list 'a 'b 'a 'c))) (values (not (null (remf x 'a))) x)) t (a c)) (deftest remf.4 (let ((x (list 'a 'b 'c 'd))) (values (and (remf x 'c) t) (loop for ptr on x by #'cddr count (not (eqt (car ptr) 'a))))) t 0) (deftest remf.order.1 (let ((i 0) x y (p (make-array 1 :initial-element (copy-list '(a b c d e f))))) (values (notnot (remf (aref p (progn (setf x (incf i)) 0)) (progn (setf y (incf i)) 'c))) (aref p 0) i x y)) t (a b e f) 2 1 2) gcl/ansi-tests/cons-test-19.lsp000066400000000000000000000423711242227143400166130ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 11:53:33 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 19 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; intersection (deftest intersection.1 (intersection nil nil) nil) (deftest intersection.2 (intersection (loop for i from 1 to 100 collect i) nil) nil) (deftest intersection.3 (intersection nil (loop for i from 1 to 100 collect i)) nil) (deftest intersection.4 (let* ((x (copy-list '(a 1 c 7 b 4 3 z))) (xcopy (make-scaffold-copy x)) (y (copy-list '(3 y c q z a 18))) (ycopy (make-scaffold-copy y)) (result (intersection x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (+ (loop for e in x count (and (member e y) (not (member e result)))) (loop for e in result count (or (not (member e x)) (not (member e y)))) (loop for hd on result count (and (consp hd) (member (car hd) (cdr hd))))))) 0) (deftest intersection.5 (let* ((x (copy-list '(a a a))) (xcopy (make-scaffold-copy x)) (y (copy-list '(a a a b b b))) (ycopy (make-scaffold-copy y)) (result (intersection x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (member 'a result) (not (member 'b result)))) t) (deftest intersection.6 (intersection (list 1000000000000 'a 'b 'c) (list (1+ 999999999999) 'd 'e 'f)) (1000000000000)) (deftest intersection.7 (intersection (list 'a 10 'b 17) (list 'c 'd 4 'e 'f 10 1 13 'z)) (10)) (deftest intersection.8 (intersection (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e)) nil) (deftest intersection.9 (intersection (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e) :test #'equal) ("aaa")) ;; Same as 9, but with a symbol function designator for :test (deftest intersection.9-a (intersection (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e) :test 'equal) ("aaa")) (deftest intersection.9-b (intersection (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e) :test-not #'(lambda (p q) (not (equal p q)))) ("aaa")) (deftest intersection.10 (equalt (sort (intersection (loop for i from 0 to 1000 by 3 collect i) (loop for i from 0 to 1000 by 7 collect i)) #'<) (loop for i from 0 to 1000 by 21 collect i)) t) (deftest intersection.11 (equalt (sort (intersection (loop for i from 0 to 999 by 5 collect i) (loop for i from 0 to 999 by 7 collect i) :test #'(lambda (a b) (and (eql a b) (= (mod a 3) 0)))) #'<) (loop for i from 0 to 999 by (* 3 5 7) collect i)) t) (deftest intersection.11-a (equalt (sort (intersection (loop for i from 0 to 999 by 5 collect i) (loop for i from 0 to 999 by 7 collect i) :test-not #'(lambda (a b) (not (and (eql a b) (= (mod a 3) 0))))) #'<) (loop for i from 0 to 999 by (* 3 5 7) collect i)) t) ;; ;; Do large numbers of random intersection tests ;; (deftest intersection.12 (intersection-12-body 100 100) nil) ;; ;; :key argument ;; (deftest intersection.13 (let ((x (copy-list '(0 5 8 13 31 42))) (y (copy-list '(3 5 42 0 7 100 312 33)))) (equalt (sort (copy-list (intersection x y)) #'<) (sort (copy-list (intersection x y :key #'1+)) #'<))) t) ;; Same as 13, but with a symbol function designator for :key (deftest intersection.13-a (let ((x (copy-list '(0 5 8 13 31 42))) (y (copy-list '(3 5 42 0 7 100 312 33)))) (equalt (sort (copy-list (intersection x y)) #'<) (sort (copy-list (intersection x y :key '1+)) #'<))) t) ;; Test that a nil key argument is ignored (deftest intersection.14 (let ((result (intersection (copy-list '(a b c d)) (copy-list '(e c f b g)) :key nil))) (and (member 'b result) (member 'c result) (every #'(lambda (x) (member x '(b c))) result) t)) t) ;; Test that intersection preserves the order of arguments to :test, :test-not (deftest intersection.15 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (intersection list1 list2 :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))))) (4)) (deftest intersection.16 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (intersection list1 list2 :key #'identity :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))))) (4)) (deftest intersection.17 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (intersection list1 list2 :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))))) (4)) (deftest intersection.18 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (intersection list1 list2 :key #'identity :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))))) (4)) ;;; Order of argument evaluation tests (deftest intersection.order.1 (let ((i 0) x y) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd))) i x y)) nil 2 1 2) (deftest intersection.order.2 (let ((i 0) x y) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :test #'eq) i x y)) nil 2 1 2) (deftest intersection.order.3 (let ((i 0) x y z w) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :test (progn (setf z (incf i)) #'eq) :test (progn (setf w (incf i)) (complement #'eq))) i x y z w)) nil 4 1 2 3 4) (deftest intersection.order.4 (let ((i 0) x y z w) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :test (progn (setf z (incf i)) #'eq) :key (progn (setf w (incf i)) #'identity)) i x y z w)) nil 4 1 2 3 4) (deftest intersection.order.5 (let ((i 0) x y z w) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :key (progn (setf z (incf i)) #'identity) :test (progn (setf w (incf i)) #'eq)) i x y z w)) nil 4 1 2 3 4) ;;; Keyword tests (deftest intersection.allow-other-keys.1 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :bad t :allow-other-keys 1)) (4)) (deftest intersection.allow-other-keys.2 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys :foo :also-bad t)) (4)) (deftest intersectionallow-other-keys.3 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys :foo :also-bad t :test #'(lambda (x y) (= x (1+ y))))) nil) (deftest intersection.allow-other-keys.4 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys t)) (4)) (deftest intersection.allow-other-keys.5 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys nil)) (4)) (deftest intersection.allow-other-keys.6 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys t :allow-other-keys nil :bad t)) (4)) (deftest intersection.allow-other-keys.7 (sort (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys t :allow-other-keys nil :test #'(lambda (x y) (eql x (1- y))))) #'<) (3 4)) (deftest intersection.keywords.8 (sort (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :test #'(lambda (x y) (eql x (1- y))) :test #'eql)) #'<) (3 4)) ;;; Error tests (deftest intersection.error.1 (classify-error (intersection)) program-error) (deftest intersection.error.2 (classify-error (intersection nil)) program-error) (deftest intersection.error.3 (classify-error (intersection nil nil :bad t)) program-error) (deftest intersection.error.4 (classify-error (intersection nil nil :key)) program-error) (deftest intersection.error.5 (classify-error (intersection nil nil 1 2)) program-error) (deftest intersection.error.6 (classify-error (intersection nil nil :bad t :allow-other-keys nil)) program-error) (deftest intersection.error.7 (classify-error (intersection '(a b c) '(d e f) :test #'identity)) program-error) (deftest intersection.error.8 (classify-error (intersection '(a b c) '(d e f) :test-not #'identity)) program-error) (deftest intersection.error.9 (classify-error (intersection '(a b c) '(d e f) :key #'cons)) program-error) (deftest intersection.error.10 (classify-error (intersection '(a b c) '(d e f) :key #'car)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nintersection (deftest nintersection.1 (nintersection nil nil) nil) (deftest nintersection.2 (nintersection (loop for i from 1 to 100 collect i) nil) nil) (deftest nintersection.3 (nintersection-with-check nil (loop for i from 1 to 100 collect i)) nil) (deftest nintersection.4 (let* ((x (copy-list '(a 1 c 7 b 4 3 z))) (xc (copy-list x)) (y (copy-list '(3 y c q z a 18))) (result (nintersection-with-check xc y))) (and (not (eqt result 'failed)) (+ (loop for e in x count (and (member e y) (not (member e result)))) (loop for e in result count (or (not (member e x)) (not (member e y)))) (loop for hd on result count (and (consp hd) (member (car hd) (cdr hd))))))) 0) (deftest nintersection.5 (let* ((x (copy-list '(a a a))) (y (copy-list '(a a a b b b))) (result (nintersection-with-check x y))) (and (not (eqt result 'failed)) (member 'a result) (not (member 'b result)))) t) (deftest nintersection.6 (nintersection-with-check (list 1000000000000 'a 'b 'c) (list (1+ 999999999999) 'd 'e 'f)) (1000000000000)) (deftest nintersection.7 (nintersection-with-check (list 'a 10 'b 17) (list 'c 'd 4 'e 'f 10 1 13 'z)) (10)) (deftest nintersection.8 (nintersection-with-check (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e)) nil) (deftest nintersection.9 (nintersection-with-check (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e) :test #'equal) ("aaa")) (deftest nintersection.9-a (nintersection-with-check (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e) :test 'equal) ("aaa")) (deftest nintersection.9-b (nintersection (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e) :test-not #'(lambda (p q) (not (equal p q)))) ("aaa")) (deftest nintersection.10 (equalt (sort (let ((result (nintersection-with-check (loop for i from 0 to 1000 by 3 collect i) (loop for i from 0 to 1000 by 7 collect i)))) (if (eqt result 'failed) () result)) #'<) (loop for i from 0 to 1000 by 21 collect i)) t) (deftest nintersection.11 (equalt (sort (let ((result (nintersection-with-check (loop for i from 0 to 999 by 5 collect i) (loop for i from 0 to 999 by 7 collect i) :test #'(lambda (a b) (and (eql a b) (= (mod a 3) 0)))))) (if (eqt result 'failed) () result)) #'<) (loop for i from 0 to 999 by (* 3 5 7) collect i)) t) (deftest nintersection.12 (nintersection-12-body 100 100) nil) ;; Key argument (deftest nintersection.13 (let ((x '(0 5 8 13 31 42)) (y (copy-list '(3 5 42 0 7 100 312 33)))) (equalt (sort (copy-list (nintersection (copy-list x) y)) #'<) (sort (copy-list (nintersection (copy-list x) y :key #'1+)) #'<))) t) ;; Check that a nil key argument is ignored (deftest nintersection.14 (let ((result (nintersection (copy-list '(a b c d)) (copy-list '(e c f b g)) :key nil))) (and (member 'b result) (member 'c result) (every #'(lambda (x) (member x '(b c))) result) t)) t) ;; Test that nintersection preserves the order of arguments to :test, :test-not (deftest nintersection.15 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (nintersection list1 list2 :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))))) (4)) (deftest nintersection.16 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (nintersection list1 list2 :key #'identity :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))))) (4)) (deftest nintersection.17 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (nintersection list1 list2 :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))))) (4)) (deftest nintersection.18 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (nintersection list1 list2 :key #'identity :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))))) (4)) ;;; Order of argument evaluation tests (deftest nintersection.order.1 (let ((i 0) x y) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd))) i x y)) nil 2 1 2) (deftest nintersection.order.2 (let ((i 0) x y) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :test #'eq) i x y)) nil 2 1 2) (deftest nintersection.order.3 (let ((i 0) x y z w) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :test (progn (setf z (incf i)) #'eq) :test (progn (setf w (incf i)) (complement #'eq))) i x y z w)) nil 4 1 2 3 4) (deftest nintersection.order.4 (let ((i 0) x y z w) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :test (progn (setf z (incf i)) #'eq) :key (progn (setf w (incf i)) #'identity)) i x y z w)) nil 4 1 2 3 4) (deftest nintersection.order.5 (let ((i 0) x y z w) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :key (progn (setf z (incf i)) #'identity) :test (progn (setf w (incf i)) #'eq)) i x y z w)) nil 4 1 2 3 4) ;;; Keyword tests (deftest nintersection.allow-other-keys.1 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :bad t :allow-other-keys 1)) (4)) (deftest nintersection.allow-other-keys.2 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys :foo :also-bad t)) (4)) (deftest nintersection.allow-other-keys.3 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys :foo :also-bad t :test #'(lambda (x y) (= x (1+ y))))) nil) (deftest nintersection.allow-other-keys.4 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys t)) (4)) (deftest nintersection.allow-other-keys.5 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys nil)) (4)) (deftest nintersection.allow-other-keys.6 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys t :allow-other-keys nil :bad t)) (4)) (deftest nintersection.allow-other-keys.7 (sort (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys t :allow-other-keys nil :test #'(lambda (x y) (eql x (1- y))))) #'<) (3 4)) (deftest nintersection.keywords.8 (sort (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :test #'(lambda (x y) (eql x (1- y))) :test #'eql)) #'<) (3 4)) (deftest nintersection.allow-other-keys.9 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys :foo :also-bad t :test #'(lambda (x y) (= x (1+ y))))) nil) (deftest nintersection.error.1 (classify-error (nintersection)) program-error) (deftest nintersection.error.2 (classify-error (nintersection nil)) program-error) (deftest nintersection.error.3 (classify-error (nintersection nil nil :bad t)) program-error) (deftest nintersection.error.4 (classify-error (nintersection nil nil :key)) program-error) (deftest nintersection.error.5 (classify-error (nintersection nil nil 1 2)) program-error) (deftest nintersection.error.6 (classify-error (nintersection nil nil :bad t :allow-other-keys nil)) program-error) (deftest nintersection.error.7 (classify-error (nintersection (list 1 2 3) (list 4 5 6) :test #'identity)) program-error) (deftest nintersection.error.8 (classify-error (nintersection (list 1 2 3) (list 4 5 6) :test-not #'identity)) program-error) (deftest nintersection.error.9 (classify-error (nintersection (list 1 2 3) (list 4 5 6) :key #'cons)) program-error) (deftest nintersection.error.10 (classify-error (nintersection (list 1 2 3) (list 4 5 6) :key #'car)) type-error) gcl/ansi-tests/cons-test-20.lsp000066400000000000000000000225021242227143400165750ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 22:11:27 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 20 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; union (deftest union.1 (union nil nil) nil) (deftest union.2 (union-with-check (list 'a) nil) (a)) (deftest union.3 (union-with-check (list 'a) (list 'a)) (a)) (deftest union-4 (union-with-check (list 1) (list 1)) (1)) (deftest union.5 (let ((x (list 'a 'b))) (union-with-check (list x) (list x))) ((a b))) (deftest union.6 (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y))) (check-union x y result))) t) (deftest union.6-a (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test #'eq))) (check-union x y result))) t) (deftest union.7 (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test #'eql))) (check-union x y result))) t) (deftest union.8 (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test #'equal))) (check-union x y result))) t) (deftest union.9 (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test-not (complement #'eql)))) (check-union x y result))) t) (deftest union.10 (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test-not (complement #'equal)))) (check-union x y result))) t) (deftest union.11 (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test-not (complement #'eq)))) (check-union x y result))) t) (deftest union.12 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y))) (check-union x y result))) t) (deftest union.13 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y :test #'equal))) (check-union x y result))) t) (deftest union.14 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y :test #'eql))) (check-union x y result))) t) (deftest union.15 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y :test-not (complement #'equal)))) (check-union x y result))) t) (deftest union.16 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y :test-not (complement #'eql)))) (check-union x y result))) t) (deftest union.17 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+))) (check-union x y result))) t) (deftest union.18 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+ :test #'equal))) (check-union x y result))) t) (deftest union.19 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+ :test #'eql))) (check-union x y result))) t) (deftest union.20 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+ :test-not (complement #'equal)))) (check-union x y result))) t) (deftest union.21 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+ :test-not (complement #'equal)))) (check-union x y result))) t) (deftest union.22 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y nil))) (check-union x y result))) t) (deftest union.23 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y '1+))) (check-union x y result))) t) ;; Do large numbers of random units (deftest union.24 (do-random-unions 100 100 200) nil) (deftest union.25 (let ((x (shuffle '(1 4 6 10 45 101))) (y (copy-list '(102 5 2 11 44 6)))) (let ((result (union-with-check x y :test #'(lambda (a b) (<= (abs (- a b)) 1))))) (and (not (eqt result 'failed)) (sort (sublis '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) (copy-list result)) #'<)))) (1 4 6 10 44 101)) ;;; Check that union uses eql, not equal or eq (deftest union.26 (let ((x 1000) (y 1000)) (loop while (not (typep x 'bignum)) do (progn (setf x (* x x)) (setf y (* y y)))) (notnot-mv (or (eqt x y) ;; if bignums are eq, the test is worthless (eql (length (union-with-check (list x) (list x))) 1)))) t) (deftest union.27 (union-with-check (list (copy-seq "aa")) (list (copy-seq "aa"))) ("aa" "aa")) ;; Check that union does not reverse the arguments to :test, :test-not (deftest union.28 (block fail (sort (union-with-check (list 1 2 3) (list 4 5 6) :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))) #'<)) (1 2 3 4 5 6)) (deftest union.29 (block fail (sort (union-with-check-and-key (list 1 2 3) (list 4 5 6) #'identity :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))) #'<)) (1 2 3 4 5 6)) (deftest union.30 (block fail (sort (union-with-check (list 1 2 3) (list 4 5 6) :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))) #'<)) (1 2 3 4 5 6)) (deftest union.31 (block fail (sort (union-with-check-and-key (list 1 2 3) (list 4 5 6) #'identity :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))) #'<)) (1 2 3 4 5 6)) ;;; Order of evaluation tests (deftest union.order.1 (let ((i 0) x y) (values (sort (union (progn (setf x (incf i)) (copy-list '(1 3 5))) (progn (setf y (incf i)) (copy-list '(2 5 8)))) #'<) i x y)) (1 2 3 5 8) 2 1 2) (deftest union.order.2 (let ((i 0) x y z w) (values (sort (union (progn (setf x (incf i)) (copy-list '(1 3 5))) (progn (setf y (incf i)) (copy-list '(2 5 8))) :test (progn (setf z (incf i)) #'eql) :key (progn (setf w (incf i)) #'identity)) #'<) i x y z w)) (1 2 3 5 8) 4 1 2 3 4) (deftest union.order.3 (let ((i 0) x y z w) (values (sort (union (progn (setf x (incf i)) (copy-list '(1 3 5))) (progn (setf y (incf i)) (copy-list '(2 5 8))) :key (progn (setf z (incf i)) #'identity) :test (progn (setf w (incf i)) #'eql)) #'<) i x y z w)) (1 2 3 5 8) 4 1 2 3 4) ;;; Keyword tests (deftest union.allow-other-keys.1 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :bad t :allow-other-keys "yes") #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.2 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t :also-bad t) #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.3 (sort (union (list 1 2 3) (list 1 2 3) :allow-other-keys t :also-bad t :test #'(lambda (x y) (= x (+ y 100)))) #'<) (1 1 2 2 3 3)) (deftest union.allow-other-keys.4 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t) #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.5 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys nil) #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.6 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t :allow-other-keys nil) #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.7 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t :allow-other-keys nil '#:x 1) #'<) (1 2 5 7 9 10 11 20)) (deftest union.keywords.9 (sort (union (list 1 2 3) (list 1 2 3) :test #'(lambda (x y) (= x (+ y 100))) :test #'eql) #'<) (1 1 2 2 3 3)) ;;; Error tests (deftest union.error.1 (classify-error (union)) program-error) (deftest union.error.2 (classify-error (union nil)) program-error) (deftest union.error.3 (classify-error (union nil nil :bad t)) program-error) (deftest union.error.4 (classify-error (union nil nil :key)) program-error) (deftest union.error.5 (classify-error (union nil nil 1 2)) program-error) (deftest union.error.6 (classify-error (union nil nil :bad t :allow-other-keys nil)) program-error) (deftest union.error.7 (classify-error (union (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest union.error.8 (classify-error (union (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest union.error.9 (classify-error (union (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest union.error.10 (classify-error (union (list 1 2) (list 3 4) :key #'car)) type-error) gcl/ansi-tests/cons-test-21.lsp000066400000000000000000000216041242227143400166000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 22:11:27 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 21 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nunion (deftest nunion.1 (nunion nil nil) nil) (deftest nunion.2 (nunion-with-copy (list 'a) nil) (a)) (deftest nunion.3 (nunion-with-copy (list 'a) (list 'a)) (a)) (deftest nunion.4 (nunion-with-copy (list 1) (list 1)) (1)) (deftest nunion.5 (let ((x (list 'a 'b))) (nunion-with-copy (list x) (list x))) ((a b))) (deftest nunion.6 (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y))) (check-union x y result))) t) (deftest nunion.6-a (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test #'eq))) (check-union x y result))) t) (deftest nunion.7 (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test #'eql))) (check-union x y result))) t) (deftest nunion.8 (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test #'equal))) (check-union x y result))) t) (deftest nunion.9 (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test-not (complement #'eql)))) (check-union x y result))) t) (deftest nunion.10 (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test-not (complement #'equal)))) (check-union x y result))) t) (deftest nunion.11 (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test-not (complement #'eq)))) (check-union x y result))) t) (deftest nunion.12 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y))) (check-union x y result))) t) (deftest nunion.13 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y :test #'equal))) (check-union x y result))) t) (deftest nunion.14 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y :test #'eql))) (check-union x y result))) t) (deftest nunion.15 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y :test-not (complement #'equal)))) (check-union x y result))) t) (deftest nunion.16 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y :test-not (complement #'eql)))) (check-union x y result))) t) (deftest nunion.17 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+))) (check-union x y result))) t) (deftest nunion.18 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+ :test #'equal))) (check-union x y result))) t) (deftest nunion.19 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+ :test #'eql))) (check-union x y result))) t) (deftest nunion.20 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+ :test-not (complement #'equal)))) (check-union x y result))) t) (deftest nunion.21 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+ :test-not (complement #'equal)))) (check-union x y result))) t) (deftest nunion.22 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y nil))) (check-union x y result))) t) (deftest nunion.23 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y '1+))) (check-union x y result))) t) ;; Do large numbers of random nunions (deftest nunion.24 (do-random-nunions 100 100 200) nil) (deftest nunion.25 (let ((x (shuffle '(1 4 6 10 45 101))) (y '(102 5 2 11 44 6))) (let ((result (nunion-with-copy x y :test #'(lambda (a b) (<= (abs (- a b)) 1))))) (sort (sublis '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) (copy-list result)) #'<))) (1 4 6 10 44 101)) ;; Check that nunion uses eql, not equal or eq (deftest nunion.26 (let ((x 1000) (y 1000)) (loop while (not (typep x 'bignum)) do (progn (setf x (* x x)) (setf y (* y y)))) (notnot-mv (or (eqt x y) ;; if bignums are eq, the test is worthless (eql (length (nunion-with-copy (list x) (list x))) 1)))) t) (deftest nunion.27 (nunion-with-copy (list (copy-seq "aa")) (list (copy-seq "aa"))) ("aa" "aa")) ;; Check that nunion does not reverse the arguments to :test, :test-not (deftest nunion.28 (block fail (sort (nunion-with-copy '(1 2 3) '(4 5 6) :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))) #'<)) (1 2 3 4 5 6)) (deftest nunion.29 (block fail (sort (nunion-with-copy-and-key '(1 2 3) '(4 5 6) #'identity :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))) #'<)) (1 2 3 4 5 6)) (deftest nunion.30 (block fail (sort (nunion-with-copy '(1 2 3) '(4 5 6) :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))) #'<)) (1 2 3 4 5 6)) (deftest nunion.31 (block fail (sort (nunion-with-copy-and-key '(1 2 3) '(4 5 6) #'identity :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))) #'<)) (1 2 3 4 5 6)) ;;; Order of evaluation tests (deftest nunion.order.1 (let ((i 0) x y) (values (sort (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) (progn (setf y (incf i)) (copy-list '(2 5 8)))) #'<) i x y)) (1 2 3 5 8) 2 1 2) (deftest nunion.order.2 (let ((i 0) x y z w) (values (sort (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) (progn (setf y (incf i)) (copy-list '(2 5 8))) :test (progn (setf z (incf i)) #'eql) :key (progn (setf w (incf i)) #'identity)) #'<) i x y z w)) (1 2 3 5 8) 4 1 2 3 4) (deftest nunion.order.3 (let ((i 0) x y z w) (values (sort (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) (progn (setf y (incf i)) (copy-list '(2 5 8))) :key (progn (setf z (incf i)) #'identity) :test (progn (setf w (incf i)) #'eql)) #'<) i x y z w)) (1 2 3 5 8) 4 1 2 3 4) ;;; Keyword tests (deftest nunion.allow-other-keys.1 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :bad t :allow-other-keys "yes") #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.2 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t :also-bad t) #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.3 (sort (nunion (list 1 2 3) (list 1 2 3) :allow-other-keys t :also-bad t :test #'(lambda (x y) (= x (+ y 100)))) #'<) (1 1 2 2 3 3)) (deftest nunion.allow-other-keys.4 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t) #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.5 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys nil) #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.6 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t :allow-other-keys nil) #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.7 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t :allow-other-keys nil '#:x 1) #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.keywords.9 (sort (nunion (list 1 2 3) (list 1 2 3) :test #'(lambda (x y) (= x (+ y 100))) :test #'eql) #'<) (1 1 2 2 3 3)) ;;; Error tests (deftest nunion.error.1 (classify-error (nunion)) program-error) (deftest nunion.error.2 (classify-error (nunion nil)) program-error) (deftest nunion.error.3 (classify-error (nunion nil nil :bad t)) program-error) (deftest nunion.error.4 (classify-error (nunion nil nil :key)) program-error) (deftest nunion.error.5 (classify-error (nunion nil nil 1 2)) program-error) (deftest nunion.error.6 (classify-error (nunion nil nil :bad t :allow-other-keys nil)) program-error) (deftest nunion.error.7 (classify-error (nunion (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest nunion.error.8 (classify-error (nunion (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest nunion.error.9 (classify-error (nunion (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest nunion.error.10 (classify-error (nunion (list 1 2) (list 3 4) :key #'car)) type-error) gcl/ansi-tests/cons-test-22.lsp000066400000000000000000000326111242227143400166010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Mar 30 22:10:34 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 22 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; set-difference (deftest set-difference.1 (set-difference nil nil) nil) (deftest set-difference.2 (let ((result (set-difference-with-check '(a b c) nil))) (check-set-difference '(a b c) nil result)) t) (deftest set-difference.3 (let ((result (set-difference-with-check '(a b c d e f) '(f b d)))) (check-set-difference '(a b c d e f) '(f b d) result)) t) (deftest set-difference.4 (sort (copy-list (set-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) '(10 101 4 74 2 1391 7 17831))) #'<) (1 3 5 6 8)) (deftest set-difference.5 (set-difference-with-check nil '(a b c d e f g h)) nil) (deftest set-difference.6 (set-difference-with-check '(a b c d e) '(d a b e) :key nil) (c)) (deftest set-difference.7 (set-difference-with-check '(a b c d e) '(d a b e) :test #'eq) (c)) (deftest set-difference.8 (set-difference-with-check '(a b c d e) '(d a b e) :test #'eql) (c)) (deftest set-difference.9 (set-difference-with-check '(a b c d e) '(d a b e) :test #'equal) (c)) (deftest set-difference.10 (set-difference-with-check '(a b c d e) '(d a b e) :test 'eq) (c)) (deftest set-difference.11 (set-difference-with-check '(a b c d e) '(d a b e) :test 'eql) (c)) (deftest set-difference.12 (set-difference-with-check '(a b c d e) '(d a b e) :test 'equal) (c)) (deftest set-difference.13 (do-random-set-differences 100 100) nil) (deftest set-difference.14 (set-difference-with-check '((a . 1) (b . 2) (c . 3)) '((a . 1) (c . 3)) :key 'car) ((b . 2))) (deftest set-difference.15 (set-difference-with-check '((a . 1) (b . 2) (c . 3)) '((a . 1) (c . 3)) :key #'car) ((b . 2))) ;; ;; Verify that the :test argument is called with the arguments ;; in the correct order ;; (deftest set-difference.16 (block fail (sort (copy-list (set-difference-with-check '(1 2 3 4) '(e f g h) :test #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (eqt x y)))) #'<)) (1 2 3 4)) (deftest set-difference.17 (block fail (sort (copy-list (set-difference-with-check '(1 2 3 4) '(e f g h) :key #'identity :test #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (eqt x y)))) #'<)) (1 2 3 4)) (deftest set-difference.18 (block fail (sort (copy-list (set-difference-with-check '(1 2 3 4) '(e f g h) :test-not #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (not (eqt x y))))) #'<)) (1 2 3 4)) (deftest set-difference.19 (block fail (sort (copy-list (set-difference-with-check '(1 2 3 4) '(e f g h) :test-not #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (not (eqt x y))))) #'<)) (1 2 3 4)) ;;; Order of argument evaluation tests (deftest set-difference.order.1 (let ((i 0) x y) (values (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 2 3 4))) i x y)) (1) 2 1 2) (deftest set-difference.order.2 (let ((i 0) x y z) (values (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 2 3 4)) :test (progn (setf z (incf i)) #'(lambda (x y) (= x (1- y))))) i x y z)) (4) 3 1 2 3) (deftest set-difference.order.3 (let ((i 0) x y z w) (values (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 2 3 4)) :test (progn (setf z (incf i)) #'(lambda (x y) (= x (1- y)))) :key (progn (setf w (incf i)) nil)) i x y z w)) (4) 4 1 2 3 4) ;;; Keyword tests (deftest set-difference.allow-other-keys.1 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :bad t :allow-other-keys t)) #'<) (1 5)) (deftest set-difference.allow-other-keys.2 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :bad t)) #'<) (1 5)) (deftest set-difference.allow-other-keys.3 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y))))) #'<) (4 5)) (deftest set-difference.allow-other-keys.4 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t)) #'<) (1 5)) (deftest set-difference.allow-other-keys.5 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys nil)) #'<) (1 5)) (deftest set-difference.allow-other-keys.6 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :allow-other-keys nil)) #'<) (1 5)) (deftest set-difference.allow-other-keys.7 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :allow-other-keys nil '#:x 1)) #'<) (1 5)) (deftest set-difference.keywords.8 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :test #'eql :test (complement #'eql))) #'<) (1 5)) (deftest set-difference.keywords.9 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :test (complement #'eql) :test #'eql)) #'<) nil) ;;; Error tests (deftest set-difference.error.1 (classify-error (set-difference)) program-error) (deftest set-difference.error.2 (classify-error (set-difference nil)) program-error) (deftest set-difference.error.3 (classify-error (set-difference nil nil :bad t)) program-error) (deftest set-difference.error.4 (classify-error (set-difference nil nil :key)) program-error) (deftest set-difference.error.5 (classify-error (set-difference nil nil 1 2)) program-error) (deftest set-difference.error.6 (classify-error (set-difference nil nil :bad t :allow-other-keys nil)) program-error) (deftest set-difference.error.7 (classify-error (set-difference (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest set-difference.error.8 (classify-error (set-difference (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest set-difference.error.9 (classify-error (set-difference (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest set-difference.error.10 (classify-error (set-difference (list 1 2) (list 3 4) :key #'car)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nset-difference (deftest nset-difference.1 (nset-difference nil nil) nil) (deftest nset-difference.2 (let ((result (nset-difference-with-check '(a b c) nil))) (check-nset-difference '(a b c) nil result)) t) (deftest nset-difference.3 (let ((result (nset-difference-with-check '(a b c d e f) '(f b d)))) (check-nset-difference '(a b c d e f) '(f b d) result)) t) (deftest nset-difference.4 (sort (copy-list (nset-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) '(10 101 4 74 2 1391 7 17831))) #'<) (1 3 5 6 8)) (deftest nset-difference.5 (nset-difference-with-check nil '(a b c d e f g h)) nil) (deftest nset-difference.6 (nset-difference-with-check '(a b c d e) '(d a b e) :key nil) (c)) (deftest nset-difference.7 (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eq) (c)) (deftest nset-difference.8 (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eql) (c)) (deftest nset-difference.9 (nset-difference-with-check '(a b c d e) '(d a b e) :test #'equal) (c)) (deftest nset-difference.10 (nset-difference-with-check '(a b c d e) '(d a b e) :test 'eq) (c)) (deftest nset-difference.11 (nset-difference-with-check '(a b c d e) '(d a b e) :test 'eql) (c)) (deftest nset-difference.12 (nset-difference-with-check '(a b c d e) '(d a b e) :test 'equal) (c)) (deftest nset-difference.13 (do-random-nset-differences 100 100) nil) (deftest nset-difference.14 (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) '((a . 1) (c . 3)) :key 'car) ((b . 2))) (deftest nset-difference.15 (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) '((a . 1) (c . 3)) :key #'car) ((b . 2))) ;; ;; Verify that the :test argument is called with the arguments ;; in the correct order ;; (deftest nset-difference.16 (block fail (sort (copy-list (nset-difference-with-check '(1 2 3 4) '(e f g h) :test #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (eqt x y)))) #'<)) (1 2 3 4)) (deftest nset-difference.17 (block fail (sort (copy-list (nset-difference-with-check '(1 2 3 4) '(e f g h) :key #'identity :test #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (eqt x y)))) #'<)) (1 2 3 4)) (deftest nset-difference.18 (block fail (sort (copy-list (nset-difference-with-check '(1 2 3 4) '(e f g h) :test-not #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (not (eqt x y))))) #'<)) (1 2 3 4)) (deftest nset-difference.19 (block fail (sort (copy-list (nset-difference-with-check '(1 2 3 4) '(e f g h) :test-not #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (not (eqt x y))))) #'<)) (1 2 3 4)) ;;; Order of argument evaluation tests (deftest nset-difference.order.1 (let ((i 0) x y) (values (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 2 3 4))) i x y)) (1) 2 1 2) (deftest nset-difference.order.2 (let ((i 0) x y z) (values (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 2 3 4)) :test (progn (setf z (incf i)) #'(lambda (x y) (= x (1- y))))) i x y z)) (4) 3 1 2 3) (deftest nset-difference.order.3 (let ((i 0) x y z w) (values (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 2 3 4)) :test (progn (setf z (incf i)) #'(lambda (x y) (= x (1- y)))) :key (progn (setf w (incf i)) nil)) i x y z w)) (4) 4 1 2 3 4) ;;; Keyword tests (deftest nset-difference.allow-other-keys.1 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :bad t :allow-other-keys t)) #'<) (1 5)) (deftest nset-difference.allow-other-keys.2 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :bad t)) #'<) (1 5)) (deftest nset-difference.allow-other-keys.3 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y))))) #'<) (4 5)) (deftest nset-difference.allow-other-keys.4 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t)) #'<) (1 5)) (deftest nset-difference.allow-other-keys.5 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys nil)) #'<) (1 5)) (deftest nset-difference.allow-other-keys.6 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :allow-other-keys nil)) #'<) (1 5)) (deftest nset-difference.allow-other-keys.7 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :allow-other-keys nil '#:x 1)) #'<) (1 5)) (deftest nset-difference.keywords.8 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :test #'eql :test (complement #'eql))) #'<) (1 5)) (deftest nset-difference.keywords.9 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :test (complement #'eql) :test #'eql)) #'<) nil) ;;; Error tests (deftest nset-difference.error.1 (classify-error (nset-difference)) program-error) (deftest nset-difference.error.2 (classify-error (nset-difference nil)) program-error) (deftest nset-difference.error.3 (classify-error (nset-difference nil nil :bad t)) program-error) (deftest nset-difference.error.4 (classify-error (nset-difference nil nil :key)) program-error) (deftest nset-difference.error.5 (classify-error (nset-difference nil nil 1 2)) program-error) (deftest nset-difference.error.6 (classify-error (nset-difference nil nil :bad t :allow-other-keys nil)) program-error) (deftest nset-difference.error.7 (classify-error (nset-difference (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest nset-difference.error.8 (classify-error (nset-difference (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest nset-difference.error.9 (classify-error (nset-difference (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest nset-difference.error.10 (classify-error (nset-difference (list 1 2) (list 3 4) :key #'car)) type-error) gcl/ansi-tests/cons-test-23.lsp000066400000000000000000000400661242227143400166050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Apr 1 21:49:43 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 23 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; set-exclusive-or (deftest set-exclusive-or.1 (set-exclusive-or nil nil) nil) (deftest set-exclusive-or.2 (let ((result (set-exclusive-or-with-check '(a b c) nil))) (check-set-exclusive-or '(a b c) nil result)) t) (deftest set-exclusive-or.3 (let ((result (set-exclusive-or-with-check '(a b c d e f) '(f b d)))) (check-set-exclusive-or '(a b c d e f) '(f b d) result)) t) (deftest set-exclusive-or.4 (sort (copy-list (set-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) '(10 101 4 74 2 1391 7 17831))) #'<) (1 3 5 6 8 10 74 101 1391 17831)) (deftest set-exclusive-or.5 (check-set-exclusive-or nil '(a b c d e f g h) (set-exclusive-or-with-check nil '(a b c d e f g h))) t) (deftest set-exclusive-or.6 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :key nil) (c)) (deftest set-exclusive-or.7 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) (c)) (deftest set-exclusive-or.7-a (set-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) (c)) (deftest set-exclusive-or.8 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) (c)) (deftest set-exclusive-or.8-a (set-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) (c)) (deftest set-exclusive-or.8-b (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test-not (complement #'eql)) (c)) (deftest set-exclusive-or.9 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) (c)) (deftest set-exclusive-or.10 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test 'eq) (c)) (deftest set-exclusive-or.11 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test 'eql) (c)) (deftest set-exclusive-or.12 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test 'equal) (c)) (deftest set-exclusive-or.13 (do-random-set-exclusive-ors 100 100) nil) (deftest set-exclusive-or.14 (set-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) '((a . 10) (c . 3)) :key 'car) ((b . 2))) (deftest set-exclusive-or.15 (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) '((a . 1) (c . 3313)) :key #'car) ((b . 2))) (deftest set-exclusive-or.16 (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) '((a . 1) (c . 3313)) :key #'car :test-not (complement #'eql)) ((b . 2))) ;; ;; Check that set-exclusive-or does not invert ;; the order of the arguments to the test function ;; (deftest set-exclusive-or.17 (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (set-exclusive-or-with-check list1 list2 :test #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed))))))) t) (deftest set-exclusive-or.17-a (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (set-exclusive-or-with-check list1 list2 :key #'identity :test #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed))))))) t) (deftest set-exclusive-or.18 (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (set-exclusive-or-with-check list1 list2 :test-not #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed)) t))))) t) (deftest set-exclusive-or.18-a (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (set-exclusive-or-with-check list1 list2 :key #'identity :test-not #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed)) t))))) t) ;;; Order of argument evaluation tests (deftest set-exclusive-or.order.1 (let ((i 0) x y) (values (sort (set-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10))) #'<) i x y)) (2 4 6 10) 2 1 2) (deftest set-exclusive-or.order.2 (let ((i 0) x y z) (values (sort (set-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :test (progn (setf z (incf i)) #'eql)) #'<) i x y z)) (2 4 6 10) 3 1 2 3) (deftest set-exclusive-or.order.3 (let ((i 0) x y z w) (values (sort (set-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :test (progn (setf z (incf i)) #'eql) :key (progn (setf w (incf i)) nil)) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) (deftest set-exclusive-or.order.4 (let ((i 0) x y z w) (values (sort (set-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :key (progn (setf z (incf i)) nil) :test (progn (setf w (incf i)) #'eql)) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) (deftest set-exclusive-or.order.5 (let ((i 0) x y z w) (values (sort (set-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :key (progn (setf z (incf i)) nil) :key (progn (setf w (incf i)) (complement #'eql))) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) ;;; Keyword tests (deftest set-exclusive.allow-other-keys.1 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :bad t :allow-other-keys t) #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.2 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :bad t) #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.3 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y)))) #'<) (1 6)) (deftest set-exclusive.allow-other-keys.4 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t) #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.5 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys nil) #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.6 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :allow-other-keys nil) #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.7 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :allow-other-keys nil '#:x 1) #'<) (1 2 5 6)) (deftest set-exclusive.keywords.8 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :test #'eql :test #'/=) #'<) (1 2 5 6)) (deftest set-exclusive.keywords.9 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :test #'/= :test #'eql) #'<) nil) (deftest set-exclusive-or.error.1 (classify-error (set-exclusive-or)) program-error) (deftest set-exclusive-or.error.2 (classify-error (set-exclusive-or nil)) program-error) (deftest set-exclusive-or.error.3 (classify-error (set-exclusive-or nil nil :bad t)) program-error) (deftest set-exclusive-or.error.4 (classify-error (set-exclusive-or nil nil :key)) program-error) (deftest set-exclusive-or.error.5 (classify-error (set-exclusive-or nil nil 1 2)) program-error) (deftest set-exclusive-or.error.6 (classify-error (set-exclusive-or nil nil :bad t :allow-other-keys nil)) program-error) (deftest set-exclusive-or.error.7 (classify-error (set-exclusive-or (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest set-exclusive-or.error.8 (classify-error (set-exclusive-or (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest set-exclusive-or.error.9 (classify-error (set-exclusive-or (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest set-exclusive-or.error.10 (classify-error (set-exclusive-or (list 1 2) (list 3 4) :key #'car)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nset-exclusive-or (deftest nset-exclusive-or.1 (nset-exclusive-or nil nil) nil) (deftest nset-exclusive-or.2 (let ((result (nset-exclusive-or-with-check '(a b c) nil))) (check-set-exclusive-or '(a b c) nil result)) t) (deftest nset-exclusive-or.3 (let ((result (nset-exclusive-or-with-check '(a b c d e f) '(f b d)))) (check-set-exclusive-or '(a b c d e f) '(f b d) result)) t) (deftest nset-exclusive-or.4 (sort (copy-list (nset-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) '(10 101 4 74 2 1391 7 17831))) #'<) (1 3 5 6 8 10 74 101 1391 17831)) (deftest nset-exclusive-or.5 (check-set-exclusive-or nil '(a b c d e f g h) (nset-exclusive-or-with-check nil '(a b c d e f g h))) t) (deftest nset-exclusive-or.6 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :key nil) (c)) (deftest nset-exclusive-or.7 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) (c)) (deftest nset-exclusive-or.7-a (nset-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) (c)) (deftest nset-exclusive-or.8 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) (c)) (deftest nset-exclusive-or.8-a (nset-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) (c)) (deftest nset-exclusive-or.8-b (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test-not (complement #'eql)) (c)) (deftest nset-exclusive-or.9 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) (c)) (deftest nset-exclusive-or.10 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test 'eq) (c)) (deftest nset-exclusive-or.11 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test 'eql) (c)) (deftest nset-exclusive-or.12 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test 'equal) (c)) (deftest nset-exclusive-or.13 (do-random-nset-exclusive-ors 100 100) nil) (deftest nset-exclusive-or.14 (nset-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) '((a . 10) (c . 3)) :key 'car) ((b . 2))) (deftest nset-exclusive-or.15 (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) '((a . 1) (c . 3313)) :key #'car) ((b . 2))) (deftest nset-exclusive-or.16 (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) '((a . 1) (c . 3313)) :key #'car :test-not (complement #'eql)) ((b . 2))) ;; ;; Check that nset-exclusive-or does not invert ;; the order of the arguments to the test function ;; (deftest nset-exclusive-or.17 (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (nset-exclusive-or-with-check list1 list2 :test #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed))))))) t) (deftest nset-exclusive-or.17-a (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (nset-exclusive-or-with-check list1 list2 :key #'identity :test #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed))))))) t) (deftest nset-exclusive-or.18 (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (nset-exclusive-or-with-check list1 list2 :test-not #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed)) t))))) t) (deftest nset-exclusive-or.18-a (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (nset-exclusive-or-with-check list1 list2 :key #'identity :test-not #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed)) t))))) t) ;;; Order of argument evaluation tests (deftest nset-exclusive-or.order.1 (let ((i 0) x y) (values (sort (nset-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10))) #'<) i x y)) (2 4 6 10) 2 1 2) (deftest nset-exclusive-or.order.2 (let ((i 0) x y z) (values (sort (nset-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :test (progn (setf z (incf i)) #'eql)) #'<) i x y z)) (2 4 6 10) 3 1 2 3) (deftest nset-exclusive-or.order.3 (let ((i 0) x y z w) (values (sort (nset-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :test (progn (setf z (incf i)) #'eql) :key (progn (setf w (incf i)) nil)) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) (deftest nset-exclusive-or.order.4 (let ((i 0) x y z w) (values (sort (nset-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :key (progn (setf z (incf i)) nil) :test (progn (setf w (incf i)) #'eql)) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) (deftest nset-exclusive-or.order.5 (let ((i 0) x y z w) (values (sort (nset-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :key (progn (setf z (incf i)) nil) :key (progn (setf w (incf i)) (complement #'eql))) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) ;;; Keyword tests (deftest nset-exclusive.allow-other-keys.1 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :bad t :allow-other-keys t) #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.2 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :bad t) #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.3 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y)))) #'<) (1 6)) (deftest nset-exclusive.allow-other-keys.4 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t) #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.5 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys nil) #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.6 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :allow-other-keys nil) #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.7 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :allow-other-keys nil '#:x 1) #'<) (1 2 5 6)) (deftest nset-exclusive.keywords.8 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :test #'eql :test #'/=) #'<) (1 2 5 6)) (deftest nset-exclusive.keywords.9 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :test #'/= :test #'eql) #'<) nil) ;;; Error tests (deftest nset-exclusive-or.error.1 (classify-error (nset-exclusive-or)) program-error) (deftest nset-exclusive-or.error.2 (classify-error (nset-exclusive-or nil)) program-error) (deftest nset-exclusive-or.error.3 (classify-error (nset-exclusive-or nil nil :bad t)) program-error) (deftest nset-exclusive-or.error.4 (classify-error (nset-exclusive-or nil nil :key)) program-error) (deftest nset-exclusive-or.error.5 (classify-error (nset-exclusive-or nil nil 1 2)) program-error) (deftest nset-exclusive-or.error.6 (classify-error (nset-exclusive-or nil nil :bad t :allow-other-keys nil)) program-error) (deftest nset-exclusive-or.error.7 (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest nset-exclusive-or.error.8 (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest nset-exclusive-or.error.9 (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest nset-exclusive-or.error.10 (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'car)) type-error) gcl/ansi-tests/cons-test-24.lsp000066400000000000000000000131461242227143400166050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Apr 1 22:10:54 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 24 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; subsetp (defvar cons-test-24-var '(78 "z" (8 9))) (deftest subsetp.1 (subsetp-with-check (copy-tree '(78)) cons-test-24-var) t) (deftest subsetp.2 (subsetp-with-check (copy-tree '((8 9))) cons-test-24-var) nil) (deftest subsetp.3 (subsetp-with-check (copy-tree '((8 9))) cons-test-24-var :test 'equal) t) (deftest subsetp.4 (subsetp-with-check (list 78 (copy-seq "Z")) cons-test-24-var :test #'equalp) t) (deftest subsetp.5 (subsetp-with-check (list 1) (list 0 2 3 4) :key #'(lambda (i) (floor (/ i 2)))) t) (deftest subsetp.6 (subsetp-with-check (list 1 6) (list 0 2 3 4) :key #'(lambda (i) (floor (/ i 2)))) nil) (deftest subsetp.7 (subsetp-with-check (list '(a . 10) '(b . 20) '(c . 30)) (list '(z . c) '(a . y) '(b . 100) '(e . f) '(c . foo)) :key #'car) t) (deftest subsetp.8 (subsetp-with-check (copy-tree '((a . 10) (b . 20) (c . 30))) (copy-tree '((z . c) (a . y) (b . 100) (e . f) (c . foo))) :key 'car) t) (deftest subsetp.9 (subsetp-with-check (list 'a 'b 'c) (copy-tree (list '(z . c) '(a . y) '(b . 100) '(e . f) '(c . foo))) :test #'(lambda (e1 e2) (eqt e1 (car e2)))) t) (deftest subsetp.10 (subsetp-with-check (list 'a 'b 'c) (copy-tree (list '(z . c) '(a . y) '(b . 100) '(e . f) '(c . foo))) :test #'(lambda (e1 e2) (eqt e1 (car e2))) :key nil) t) (deftest subsetp.11 (subsetp-with-check (list 'a 'b 'c) (copy-tree (list '(z . c) '(a . y) '(b . 100) '(e . f) '(c . foo))) :test-not #'(lambda (e1 e2) (not (eqt e1 (car e2))))) t) ;; Check that it maintains order of arguments (deftest subsetp.12 (block fail (subsetp-with-check (list 1 2 3) (list 4 5 6) :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) t))) t) (deftest subsetp.13 (block fail (subsetp-with-check (list 1 2 3) (list 4 5 6) :key #'identity :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) t))) t) (deftest subsetp.14 (block fail (subsetp-with-check (list 1 2 3) (list 4 5 6) :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) nil))) t) (deftest subsetp.15 (block fail (subsetp-with-check (list 1 2 3) (list 4 5 6) :key #'identity :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) nil))) t) ;;; Order of argument evaluation tests (deftest subsetp.order.1 (let ((i 0) x y) (values (notnot (subsetp (progn (setf x (incf i)) '(a b c)) (progn (setf y (incf i)) '(a b c d)))) i x y)) t 2 1 2) (deftest subsetp.order.2 (let ((i 0) x y z w) (values (notnot (subsetp (progn (setf x (incf i)) '(a b c)) (progn (setf y (incf i)) '(a b c d)) :test (progn (setf z (incf i)) #'eql) :key (progn (setf w (incf i)) nil))) i x y z w)) t 4 1 2 3 4) (deftest subsetp.order.3 (let ((i 0) x y z w) (values (notnot (subsetp (progn (setf x (incf i)) '(a b c)) (progn (setf y (incf i)) '(a b c d)) :key (progn (setf z (incf i)) nil) :test (progn (setf w (incf i)) #'eql))) i x y z w)) t 4 1 2 3 4) ;;; Keyword tests (deftest subsetp.allow-other-keys.1 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :bad t :allow-other-keys 67)) t) (deftest subsetp.allow-other-keys.2 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys #'cons :bad t)) t) (deftest subsetp.allow-other-keys.3 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4) :allow-other-keys (make-hash-table) :bad t :test #'(lambda (x y) (= (1+ x) y)))) nil) (deftest subsetp.allow-other-keys.4 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys t)) t) (deftest subsetp.allow-other-keys.5 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys nil)) t) (deftest subsetp.allow-other-keys.6 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys t :bad1 t :allow-other-keys nil :bad2 t)) t) (deftest subsetp.keywords.7 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4) :test #'(lambda (x y) (= (1+ x) y)) :test #'eql)) nil) (deftest subsetp.keywords.8 (notnot-mv (subsetp '(1 2 3 4 10) '(0 1 2 3 4) :key nil :key #'(lambda (x) (mod x 2)))) nil) ;;; Error tests (deftest subsetp.error.1 (classify-error (subsetp)) program-error) (deftest subsetp.error.2 (classify-error (subsetp nil)) program-error) (deftest subsetp.error.3 (classify-error (subsetp nil nil :bad t)) program-error) (deftest subsetp.error.4 (classify-error (subsetp nil nil :key)) program-error) (deftest subsetp.error.5 (classify-error (subsetp nil nil 1 2)) program-error) (deftest subsetp.error.6 (classify-error (subsetp nil nil :bad t :allow-other-keys nil)) program-error) (deftest subsetp.error.7 (classify-error (subsetp (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest subsetp.error.8 (classify-error (subsetp (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest subsetp.error.9 (classify-error (subsetp (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest subsetp.error.10 (classify-error (subsetp (list 1 2) (list 3 4) :key #'car)) type-error)gcl/ansi-tests/cons-test-25.lsp000066400000000000000000000026351242227143400166070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 5 22:26:59 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 25 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; setting of C*R accessors (loop for fn in '(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) do (let ((level (- (length (symbol-name fn)) 2))) (eval `(deftest ,(intern (concatenate 'string (symbol-name fn) "-SET-ALT") :cl-test) (let ((x (create-c*r-test ,level))) (and (setf (,fn x) 'a) (eql (,fn x) 'a) (setf (,fn x) 'none) (equal x (create-c*r-test ,level)) )) t)))) (loop for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) (fifth 5) (sixth 6) (seventh 7) (eighth 8) (ninth 9) (tenth 10)) do (eval `(deftest ,(intern (concatenate 'string (symbol-name fn) "-SET-ALT") :cl-test) (let ((x (make-list 20 :initial-element nil))) (and (setf (,fn x) 'a) (loop for i from 1 to 20 do (when (and (not (eql i ,len)) (nth (1- i) x)) (return nil)) finally (return t)) (eql (,fn x) 'a) (nth ,(1- len) x))) a))) gcl/ansi-tests/constantly.lsp000066400000000000000000000015061242227143400166360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 6 19:47:16 2002 ;;;; Contains: Tests for CONSTANTLY (in-package :cl-test) (deftest constantly.1 (let ((fn (cl:constantly 10)) (x nil)) (loop for i from 0 to (min 256 (1- call-arguments-limit)) always (prog1 (eql (apply fn x) 10) (push 'a x)))) t) (deftest constantly.2 (notnot-mv (cl:constantly 1)) t) (deftest constantly.3 (let ((i 0)) (let ((fn (cl:constantly (progn (incf i) 'a)))) (values i (mapcar fn '(1 2 3 4)) i))) 1 (a a a a) 1) (deftest constantly.error.1 (classify-error (cl:constantly)) program-error) ;;; The next test fails in CMUCL, which has non-conformantly extended ;;; the syntax of constantly. (deftest constantly.error.2 (classify-error (cl:constantly 1 1)) program-error) gcl/ansi-tests/constantp.lsp000066400000000000000000000026331242227143400164530ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 19:12:17 2003 ;;;; Contains: Tests for CONSTANTP ;;; See also defconstant.lsp (in-package :cl-test) (deftest constantp.error.1 (classify-error (constantp)) program-error) (deftest constantp.error.2 (classify-error (constantp nil nil nil)) program-error) (deftest constantp.1 (loop for e in *universe* when (and (not (symbolp e)) (not (consp e)) (not (constantp e))) collect e) nil) (deftest constantp.2 (notnot-mv (constantp t)) t) (deftest constantp.3 (notnot-mv (constantp nil)) t) (deftest constantp.4 (notnot-mv (constantp :foo)) t) (deftest constantp.5 (constantp (gensym)) nil) (defconstant constantp-test-symbol 1) (defmacro constantp-macro (form &environment env) (notnot-mv (constantp form env))) (deftest constantp.6 (constantp-macro constantp-test-symbol) t) (deftest constantp.7 (constantp '(incf x)) nil) (deftest constantp.8 (notnot-mv (constantp 1 nil)) t) (deftest constantp.9 (notnot-mv (constantp ''(((foo))))) t) (deftest constantp.10 (notnot-mv (constantp 'pi)) t) (deftest constantp.order.1 (let ((i 0)) (values (notnot (constantp (progn (incf i) 1))) i)) t 1) (deftest constantp.order.2 (let ((i 0) x y) (values (notnot (constantp (progn (setf x (incf i)) 1) (progn (setf y (incf i)) nil))) i x y)) t 2 1 2) gcl/ansi-tests/copy-seq.lsp000066400000000000000000000076321242227143400162060ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 2 21:38:08 2002 ;;;; Contains: Tests for COPY-SEQ (in-package :cl-test) ;;; This function is extensively used elsewhere, but is tested again ;;; here for completeness. (deftest copy-seq.1 (copy-seq nil) nil) (deftest copy-seq.2 (let* ((s1 '(a b c)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (equalt s1 s2))) t) (deftest copy-seq.3 (let* ((s1 #(a b c)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) s2)) #(a b c)) (deftest copy-seq.4 (let* ((s1 (make-array '(4) :initial-contents '(a b c d) :adjustable t)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-vector-p s2) s2)) #(a b c d)) (deftest copy-seq.5 (let* ((s1 (make-array '(4) :initial-contents '(a b c d) :fill-pointer 3)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-vector-p s2) s2)) #(a b c)) (deftest copy-seq.6 (let* ((a1 (make-array '(6) :initial-contents '(a b c d e f))) (a2 (make-array '(4) :displaced-to a1 :displaced-index-offset 1)) (s2 (check-values (copy-seq a2)))) (and (not (eql a2 s2)) (simple-vector-p s2) s2)) #(b c d e)) (deftest copy-seq.7 (let* ((s1 (make-array '(4) :element-type 'base-char :initial-contents '(#\a #\b #\c #\d) :adjustable t)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-string-p s2) s2)) "abcd") (deftest copy-seq.8 (let* ((s1 (make-array '(4) :element-type 'base-char :initial-contents '(#\a #\b #\c #\d) :fill-pointer 3)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-string-p s2) s2)) "abc") (deftest copy-seq.9 (let* ((a1 (make-array '(6) :initial-contents '(#\a #\b #\c #\d #\e #\f) :element-type 'base-char)) (a2 (make-array '(4) :displaced-to a1 :element-type 'base-char :displaced-index-offset 1)) (s2 (check-values (copy-seq a2)))) (and (not (eql a2 s2)) (simple-string-p s2) s2)) "bcde") (deftest copy-seq.10 (let*((s1 "abcd") (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) s2)) "abcd") (deftest copy-seq.11 (let* ((s1 #*0010110) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-bit-vector-p s2) s2)) #*0010110) (deftest copy-seq.12 (let* ((s1 (make-array '(4) :initial-contents '(0 0 1 0) :element-type 'bit :adjustable t)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-bit-vector-p s2) s2)) #*0010) (deftest copy-seq.13 (let* ((s1 (make-array '(4) :initial-contents '(0 0 1 0) :element-type 'bit :fill-pointer 3)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-bit-vector-p s2) s2)) #*001) (deftest copy-seq.14 (let* ((a1 (make-array '(6) :initial-contents '(0 0 1 0 1 1) :element-type 'bit)) (a2 (make-array '(4) :displaced-to a1 :displaced-index-offset 1 :element-type 'bit)) (s2 (check-values (copy-seq a2)))) (and (not (eql a2 s2)) (simple-bit-vector-p s2) s2)) #*0101) (deftest copy-seq.15 (copy-seq "") "") (deftest copy-seq.16 (copy-seq #*) #*) (deftest copy-seq.17 (copy-seq #()) #()) (deftest copy-seq.18 (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j))) (y (check-values (copy-seq x)))) (equal-array x y)) t) (deftest copy-seq.order.1 (let ((i 0)) (values (copy-seq (progn (incf i) "abc")) i)) "abc" 1) ;;; Error tests (deftest copy-seq.error.1 (classify-error (copy-seq 10)) type-error) (deftest copy-seq.error.2 (classify-error (copy-seq 'a)) type-error) (deftest copy-seq.error.3 (classify-error (copy-seq 13.21)) type-error) (deftest copy-seq.error.4 (classify-error (copy-seq)) program-error) (deftest copy-seq.error.5 (classify-error (copy-seq "abc" 2 nil)) program-error) (deftest copy-seq.error.6 (classify-error (locally (copy-seq 10) t)) type-error) gcl/ansi-tests/count-if-not.lsp000066400000000000000000000325241242227143400167660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 20 22:42:35 2002 ;;;; Contains: Tests for COUNT-IF-NOT (in-package :cl-test) (deftest count-if-not-list.1 (count-if-not #'identity '(a b nil c d nil e)) 2) (deftest count-if-not-list.2 (count-if-not #'not '(a b nil c d nil e)) 5) (deftest count-if-not-list.3 (count-if-not #'(lambda (x) (break)) nil) 0) (deftest count-if-not-list.4 (count-if-not #'identity '(a b nil c d nil e) :key #'identity) 2) (deftest count-if-not-list.5 (count-if-not 'identity '(a b nil c d nil e) :key #'identity) 2) (deftest count-if-not-list.6 (count-if-not #'identity '(a b nil c d nil e) :key 'identity) 2) (deftest count-if-not-list.8 (count-if-not #'identity '(a b nil c d nil e) :key 'not) 5) (deftest count-if-not-list.9 (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1)) 5) (deftest count-if-not-list.10 (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1) :key #'1+) 4) (deftest count-if-not-list.11 (let ((c 0)) (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1) :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-not-list.12 (let ((c 0)) (count-if-not #'oddp '(0 1 2 3 4 4 1 7 10 1) :from-end t :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-not-list.13 (count-if-not #'(lambda (x) (not (eqt x 'a))) '(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-not-list.14 (count-if-not #'(lambda (x) (not (eqt x 'a))) '(a b c d a e f a e f f a a) :end 7) 2) (deftest count-if-not-list.15 (count-if-not #'(lambda (x) (not (eqt x 'a))) '(a b c d a e f a e f f a a) :end 7 :start 2) 1) (deftest count-if-not-list.16 (count-if-not #'(lambda (x) (not (eqt x 'a))) '(a b c d a e f a e f f a a) :end 7 :start 2 :from-end t) 1) ;;; tests on vectors (deftest count-if-not-vector.1 (count-if-not #'identity #(a b nil c d nil e)) 2) (deftest count-if-not-vector.2 (count-if-not #'not #(a b nil c d nil e)) 5) (deftest count-if-not-vector.3 (count-if-not #'(lambda (x) (break)) #()) 0) (deftest count-if-not-vector.4 (count-if-not #'not #(a b nil c d nil e) :key #'identity) 5) (deftest count-if-not-vector.5 (count-if-not 'not #(a b nil c d nil e) :key #'identity) 5) (deftest count-if-not-vector.6 (count-if-not #'not #(a b nil c d nil e) :key 'identity) 5) (deftest count-if-not-vector.8 (count-if-not #'not #(a b nil c d nil e) :key 'not) 2) (deftest count-if-not-vector.9 (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1)) 5) (deftest count-if-not-vector.10 (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1) :key #'1+) 4) (deftest count-if-not-vector.11 (let ((c 0)) (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1) :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-not-vector.12 (let ((c 0)) (count-if-not #'oddp #(0 1 2 3 4 4 1 7 10 1) :from-end t :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-not-vector.13 (count-if-not #'(lambda (x) (not (eqt x 'a))) #(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-not-vector.14 (count-if-not #'(lambda (x) (not (eqt x 'a))) #(a b c d a e f a e f f a a) :end 7) 2) (deftest count-if-not-vector.15 (count-if-not #'(lambda (x) (not (eqt x 'a))) #(a b c d a e f a e f f a a) :end 7 :start 2) 1) (deftest count-if-not-vector.16 (count-if-not #'(lambda (x) (not (eqt x 'a))) #(a b c d a e f a e f f a a) :end 7 :start 2 :from-end t) 1) ;;; Non-simple vectors (deftest count-if-not-nonsimple-vector.1 (count-if-not #'identity (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t)) 2) (deftest count-if-not-nonsimple-vector.2 (count-if-not #'not (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t)) 5) (deftest count-if-not-nonsimple-vector.3 (count-if-not #'(lambda (x) (break)) (make-array 0 :fill-pointer t :adjustable t)) 0) (deftest count-if-not-nonsimple-vector.4 (count-if-not #'not (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key #'identity) 5) (deftest count-if-not-nonsimple-vector.5 (count-if-not 'not (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key #'identity) 5) (deftest count-if-not-nonsimple-vector.6 (count-if-not #'not (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key 'identity) 5) (deftest count-if-not-nonsimple-vector.8 (count-if-not #'not (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key 'not) 2) (deftest count-if-not-nonsimple-vector.9 (count-if-not #'oddp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) :fill-pointer t :adjustable t)) 5) (deftest count-if-not-nonsimple-vector.10 (count-if-not #'oddp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) :fill-pointer t :adjustable t) :key #'1+) 4) (deftest count-if-not-nonsimple-vector.11 (let ((c 0)) (count-if-not #'oddp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) :fill-pointer t :adjustable t) :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-not-nonsimple-vector.12 (let ((c 0)) (count-if-not #'oddp (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) :fill-pointer t :adjustable t) :from-end t :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-not-nonsimple-vector.13 (count-if-not #'(lambda (x) (not (eqt x 'a))) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :start 2) 4) (deftest count-if-not-nonsimple-vector.14 (count-if-not #'(lambda (x) (not (eqt x 'a))) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7) 2) (deftest count-if-not-nonsimple-vector.15 (count-if-not #'(lambda (x) (not (eqt x 'a))) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7 :start 2) 1) (deftest count-if-not-nonsimple-vector.16 (count-if-not #'(lambda (x) (not (eqt x 'a))) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7 :start 2 :from-end t) 1) (deftest count-if-not-nonsimple-vector.17 (flet ((%a (c) (not (eqt c 'a))) (%f (c) (not (eqt c 'f)))) (let ((a (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer 9))) (values (count-if-not #'%a a) (count-if-not #'%a a :from-end t) (count-if-not #'%f a) (count-if-not #'%f a :from-end t) ))) 3 3 1 1) ;;; tests on bit-vectors (deftest count-if-not-bit-vector.1 (count-if-not #'oddp #*001011101101) 5) (deftest count-if-not-bit-vector.2 (count-if-not #'identity #*001011101101) 0) (deftest count-if-not-bit-vector.3 (count-if-not #'(lambda (x) (break)) #*) 0) (deftest count-if-not-bit-vector.4 (count-if-not #'identity #*001011101101 :key #'zerop) 7) (deftest count-if-not-bit-vector.5 (count-if-not 'not #*001011101101 :key #'zerop) 5) (deftest count-if-not-bit-vector.6 (count-if-not #'not #*001011101101 :key 'zerop) 5) (deftest count-if-not-bit-vector.8 (count-if-not #'identity #*001011101101 :key 'oddp) 5) (deftest count-if-not-bit-vector.10 (count-if-not #'oddp #*001011101101 :key #'1+) 7) (deftest count-if-not-bit-vector.11 (let ((c 0)) (count-if-not #'oddp #*001011101101 :key #'(lambda (x) (+ x (incf c))))) 7) (deftest count-if-not-bit-vector.12 (let ((c 0)) (count-if-not #'oddp #*001011101101 :from-end t :key #'(lambda (x) (+ x (incf c))))) 5) (deftest count-if-not-bit-vector.13 (count-if-not #'zerop #*0111011011100 :start 2) 7) (deftest count-if-not-bit-vector.14 (count-if-not #'zerop #*0111011011100 :end 7) 5) (deftest count-if-not-bit-vector.15 (count-if-not #'zerop #*0111011011100 :end 7 :start 2) 4) (deftest count-if-not-bit-vector.16 (count-if-not #'zerop #*0111011011100 :end 7 :start 2 :from-end t) 4) (deftest count-if-not-bit-vector.17 (let ((a (make-array '(10) :initial-contents '(0 0 0 1 1 1 0 1 0 0) :fill-pointer 5 :element-type 'bit))) (and (bit-vector-p a) (values (count-if-not #'zerop a) (count-if-not #'oddp a) (count-if-not #'zerop a :from-end t) (count-if-not #'oddp a :from-end t)))) 2 3 2 3) ;;; tests on strings (deftest count-if-not-string.1 (count-if-not #'(lambda (x) (eql x #\0)) "001011101101") 7) (deftest count-if-not-string.2 (count-if-not #'identity "001011101101") 0) (deftest count-if-not-string.3 (count-if-not #'(lambda (x) (break)) "") 0) (deftest count-if-not-string.4 (count-if-not #'identity "001011101101" :key #'(lambda (x) (eql x #\0))) 7) (deftest count-if-not-string.5 (count-if-not 'identity "001011101101" :key #'(lambda (x) (eql x #\0))) 7) (deftest count-if-not-string.6 (count-if-not #'(lambda (x) (eql x #\0)) "001011101101" :key 'identity) 7) (deftest count-if-not-string.8 (count-if-not #'identity "001011101101" :key #'(lambda (x) (eql x #\1))) 5) (deftest count-if-not-string.11 (let ((c 0)) (count-if-not #'oddp "001011101101" :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) 7) (deftest count-if-not-string.12 (let ((c 0)) (count-if-not #'oddp "001011101101" :from-end t :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) 5) (deftest count-if-not-string.13 (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :start 2) 7) (deftest count-if-not-string.14 (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7) 5) (deftest count-if-not-string.15 (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2) 4) (deftest count-if-not-string.16 (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2 :from-end t) 4) (deftest count-if-not-string.17 (flet ((%zerop (c) (eql c #\0)) (%onep (c) (eql c #\1))) (let ((a (make-array '(10) :initial-contents "0001110100" :fill-pointer 5 :element-type 'character))) (and (stringp a) (values (count-if-not #'%zerop a) (count-if-not #'%onep a) (count-if-not #'%zerop a :from-end t) (count-if-not #'%onep a :from-end t))))) 2 3 2 3) ;;; Argument order tests (deftest count-if-not.order.1 (let ((i 0) c1 c2 c3 c4 c5 c6) (values (count-if-not (progn (setf c1 (incf i)) #'null) (progn (setf c2 (incf i)) '(a nil b c nil d e)) :start (progn (setf c3 (incf i)) 0) :end (progn (setf c4 (incf i)) 3) :key (progn (setf c5 (incf i)) #'not) :from-end (progn (setf c6 (incf i)) nil) ) i c1 c2 c3 c4 c5 c6)) 1 6 1 2 3 4 5 6) (deftest count-if-not.order.2 (let ((i 0) c1 c2 c3 c4 c5 c6) (values (count-if-not (progn (setf c1 (incf i)) #'null) (progn (setf c2 (incf i)) '(a nil b c nil d e)) :from-end (progn (setf c3 (incf i)) nil) :key (progn (setf c4 (incf i)) #'not) :end (progn (setf c5 (incf i)) 3) :start (progn (setf c6 (incf i)) 0) ) i c1 c2 c3 c4 c5 c6)) 1 6 1 2 3 4 5 6) ;;; Keyword tests (deftest count-if-not.keywords.1 (count-if-not #'oddp '(1 2 3 4 5) :bad t :allow-other-keys t) 2) (deftest count-if-not.keywords.2 (count-if-not #'oddp '(1 2 3 4 5) :allow-other-keys #p"*" :also-bad t) 2) ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest count-if-not.keywords.3 (count-if-not #'oddp '(1 2 3 4 5) :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest count-if-not.keywords.4 (count-if-not #'oddp '(1 2 3 4 5) :key #'identity :key #'1+) 2) (deftest count-if-not.allow-other-keys.5 (count-if-not #'null '(nil a b c nil) :allow-other-keys nil) 3) ;;; Error tests (deftest count-if-not.error.1 (classify-error (count-if-not #'identity 1)) type-error) (deftest count-if-not.error.2 (classify-error (count-if-not #'identity 'a)) type-error) (deftest count-if-not.error.3 (classify-error (count-if-not #'identity #\a)) type-error) (deftest count-if-not.error.4 (classify-error (count-if-not)) program-error) (deftest count-if-not.error.5 (classify-error (count-if-not #'null)) program-error) (deftest count-if-not.error.6 (classify-error (count-if-not #'null nil :bad t)) program-error) (deftest count-if-not.error.7 (classify-error (count-if-not #'null nil :bad t :allow-other-keys nil)) program-error) (deftest count-if-not.error.8 (classify-error (count-if-not #'null nil :key)) program-error) (deftest count-if-not.error.9 (classify-error (count-if-not #'null nil 3 3)) program-error) ;;; Only leftmost :allow-other-keys argument matters (deftest count-if-not.error.10 (classify-error (count-if-not #'null nil :bad t :allow-other-keys nil :allow-other-keys t)) program-error) (deftest count-if-not.error.11 (classify-error (locally (count-if-not #'identity 1) t)) type-error) (deftest count-if-not.error.12 (classify-error (count-if-not #'cons '(a b c))) program-error) (deftest count-if-not.error.13 (classify-error (count-if-not #'car '(a b c))) type-error) (deftest count-if-not.error.14 (classify-error (count-if-not #'identity '(a b c) :key #'cdr)) type-error) (deftest count-if-not.error.15 (classify-error (count-if-not #'identity '(a b c) :key #'cons)) program-error) gcl/ansi-tests/count-if.lsp000066400000000000000000000313031242227143400161620ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 20 08:01:30 2002 ;;;; Contains: Tests for COUNT-IF (in-package :cl-test) (deftest count-if-list.1 (count-if #'identity '(a b nil c d nil e)) 5) (deftest count-if-list.2 (count-if #'not '(a b nil c d nil e)) 2) (deftest count-if-list.3 (count-if #'(lambda (x) (break)) nil) 0) (deftest count-if-list.4 (count-if #'identity '(a b nil c d nil e) :key #'identity) 5) (deftest count-if-list.5 (count-if 'identity '(a b nil c d nil e) :key #'identity) 5) (deftest count-if-list.6 (count-if #'identity '(a b nil c d nil e) :key 'identity) 5) (deftest count-if-list.8 (count-if #'identity '(a b nil c d nil e) :key 'not) 2) (deftest count-if-list.9 (count-if #'evenp '(1 2 3 4 4 1 8 10 1)) 5) (deftest count-if-list.10 (count-if #'evenp '(1 2 3 4 4 1 8 10 1) :key #'1+) 4) (deftest count-if-list.11 (let ((c 0)) (count-if #'evenp '(1 2 3 4 4 1 8 10 1) :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-list.12 (let ((c 0)) (count-if #'evenp '(0 1 2 3 4 4 1 7 10 1) :from-end t :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-list.13 (count-if #'(lambda (x) (eqt x 'a)) '(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-list.14 (count-if #'(lambda (x) (eqt x 'a)) '(a b c d a e f a e f f a a) :end 7) 2) (deftest count-if-list.15 (count-if #'(lambda (x) (eqt x 'a)) '(a b c d a e f a e f f a a) :end 7 :start 2) 1) (deftest count-if-list.16 (count-if #'(lambda (x) (eqt x 'a)) '(a b c d a e f a e f f a a) :end 7 :start 2 :from-end t) 1) ;;; tests on vectors (deftest count-if-vector.1 (count-if #'identity #(a b nil c d nil e)) 5) (deftest count-if-vector.2 (count-if #'not #(a b nil c d nil e)) 2) (deftest count-if-vector.3 (count-if #'(lambda (x) (break)) #()) 0) (deftest count-if-vector.4 (count-if #'identity #(a b nil c d nil e) :key #'identity) 5) (deftest count-if-vector.5 (count-if 'identity #(a b nil c d nil e) :key #'identity) 5) (deftest count-if-vector.6 (count-if #'identity #(a b nil c d nil e) :key 'identity) 5) (deftest count-if-vector.8 (count-if #'identity #(a b nil c d nil e) :key 'not) 2) (deftest count-if-vector.9 (count-if #'evenp #(1 2 3 4 4 1 8 10 1)) 5) (deftest count-if-vector.10 (count-if #'evenp #(1 2 3 4 4 1 8 10 1) :key #'1+) 4) (deftest count-if-vector.11 (let ((c 0)) (count-if #'evenp #(1 2 3 4 4 1 8 10 1) :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-vector.12 (let ((c 0)) (count-if #'evenp #(0 1 2 3 4 4 1 7 10 1) :from-end t :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-vector.13 (count-if #'(lambda (x) (eqt x 'a)) #(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-vector.14 (count-if #'(lambda (x) (eqt x 'a)) #(a b c d a e f a e f f a a) :end 7) 2) (deftest count-if-vector.15 (count-if #'(lambda (x) (eqt x 'a)) #(a b c d a e f a e f f a a) :end 7 :start 2) 1) (deftest count-if-vector.16 (count-if #'(lambda (x) (eqt x 'a)) #(a b c d a e f a e f f a a) :end 7 :start 2 :from-end t) 1) ;;; Non-simple vectors (deftest count-if-nonsimple-vector.1 (count-if #'identity (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t)) 5) (deftest count-if-nonsimple-vector.2 (count-if #'not (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t)) 2) (deftest count-if-nonsimple-vector.3 (count-if #'(lambda (x) (break)) (make-array 0 :fill-pointer t :adjustable t)) 0) (deftest count-if-nonsimple-vector.4 (count-if #'identity (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key #'identity) 5) (deftest count-if-nonsimple-vector.5 (count-if 'identity (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key #'identity) 5) (deftest count-if-nonsimple-vector.6 (count-if #'identity (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key 'identity) 5) (deftest count-if-nonsimple-vector.8 (count-if #'identity (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key 'not) 2) (deftest count-if-nonsimple-vector.9 (count-if #'evenp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) :fill-pointer t :adjustable t)) 5) (deftest count-if-nonsimple-vector.10 (count-if #'evenp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) :fill-pointer t :adjustable t) :key #'1+) 4) (deftest count-if-nonsimple-vector.11 (let ((c 0)) (count-if #'evenp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) :fill-pointer t :adjustable t) :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-nonsimple-vector.12 (let ((c 0)) (count-if #'evenp (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) :fill-pointer t :adjustable t) :from-end t :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-nonsimple-vector.13 (count-if #'(lambda (x) (eqt x 'a)) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :start 2) 4) (deftest count-if-nonsimple-vector.14 (count-if #'(lambda (x) (eqt x 'a)) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7) 2) (deftest count-if-nonsimple-vector.15 (count-if #'(lambda (x) (eqt x 'a)) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7 :start 2) 1) (deftest count-if-nonsimple-vector.16 (count-if #'(lambda (x) (eqt x 'a)) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7 :start 2 :from-end t) 1) (deftest count-if-nonsimple-vector.17 (flet ((%f (x) (eqt x 'a))) (let ((s (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer 6))) (values (count-if #'%f s) (count-if #'%f s :end nil) (count-if #'%f s :end 4) (count-if #'%f s :start 1) (count-if #'%f s :start 1 :end 4) (count-if #'%f s :start 1 :end 4 :from-end t)))) 2 2 1 1 0 0) ;;; tests on bit-vectors (deftest count-if-bit-vector.1 (count-if #'evenp #*001011101101) 5) (deftest count-if-bit-vector.2 (count-if #'identity #*001011101101) 12) (deftest count-if-bit-vector.3 (count-if #'(lambda (x) (break)) #*) 0) (deftest count-if-bit-vector.4 (count-if #'identity #*001011101101 :key #'zerop) 5) (deftest count-if-bit-vector.5 (count-if 'identity #*001011101101 :key #'zerop) 5) (deftest count-if-bit-vector.6 (count-if #'identity #*001011101101 :key 'zerop) 5) (deftest count-if-bit-vector.8 (count-if #'identity #*001011101101 :key 'oddp) 7) (deftest count-if-bit-vector.10 (count-if #'evenp #*001011101101 :key #'1+) 7) (deftest count-if-bit-vector.11 (let ((c 0)) (count-if #'evenp #*001011101101 :key #'(lambda (x) (+ x (incf c))))) 7) (deftest count-if-bit-vector.12 (let ((c 0)) (count-if #'evenp #*001011101101 :from-end t :key #'(lambda (x) (+ x (incf c))))) 5) (deftest count-if-bit-vector.13 (count-if #'zerop #*0111011011100 :start 2) 4) (deftest count-if-bit-vector.14 (count-if #'zerop #*0111011011100 :end 7) 2) (deftest count-if-bit-vector.15 (count-if #'zerop #*0111011011100 :end 7 :start 2) 1) (deftest count-if-bit-vector.16 (count-if #'zerop #*0111011011100 :end 7 :start 2 :from-end t) 1) (deftest count-if-bit-vector.17 (let ((s (make-array '(10) :initial-contents '(0 0 1 0 1 0 0 1 1 0) :element-type 'bit :fill-pointer 6))) (values (count-if #'zerop s) (count-if #'zerop s :end nil) (count-if #'zerop s :end 4) (count-if #'zerop s :start 5) (count-if #'zerop s :start 1 :end 4))) 4 4 3 1 2) ;;; tests on strings (deftest count-if-string.1 (count-if #'(lambda (x) (eql x #\0)) "001011101101") 5) (deftest count-if-string.2 (count-if #'identity "001011101101") 12) (deftest count-if-string.3 (count-if #'(lambda (x) (break)) "") 0) (deftest count-if-string.4 (count-if #'identity "001011101101" :key #'(lambda (x) (eql x #\0))) 5) (deftest count-if-string.5 (count-if 'identity "001011101101" :key #'(lambda (x) (eql x #\0))) 5) (deftest count-if-string.6 (count-if #'(lambda (x) (eql x #\0)) "001011101101" :key 'identity) 5) (deftest count-if-string.8 (count-if #'identity "001011101101" :key #'(lambda (x) (eql x #\1))) 7) (deftest count-if-string.11 (let ((c 0)) (count-if #'evenp "001011101101" :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) 7) (deftest count-if-string.12 (let ((c 0)) (count-if #'evenp "001011101101" :from-end t :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) 5) (deftest count-if-string.13 (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :start 2) 4) (deftest count-if-string.14 (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7) 2) (deftest count-if-string.15 (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2) 1) (deftest count-if-string.16 (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2 :from-end t) 1) (deftest count-if-string.17 (let ((s (make-array '(10) :initial-contents "00a0aa0a0a" :element-type 'character :fill-pointer 6))) (values (count-if #'digit-char-p s) (count-if #'digit-char-p s :end nil) (count-if #'digit-char-p s :start 1) (count-if #'digit-char-p s :end 2) (count-if #'digit-char-p s :start 1 :end 2))) 3 3 2 2 1) ;;; Argument order tests (deftest count-if.order.1 (let ((i 0) c1 c2 c3 c4 c5 c6) (values (count-if (progn (setf c1 (incf i)) #'null) (progn (setf c2 (incf i)) '(a nil b c nil d e)) :start (progn (setf c3 (incf i)) 0) :end (progn (setf c4 (incf i)) 3) :key (progn (setf c5 (incf i)) #'identity) :from-end (progn (setf c6 (incf i)) nil) ) i c1 c2 c3 c4 c5 c6)) 1 6 1 2 3 4 5 6) (deftest count-if.order.2 (let ((i 0) c1 c2 c3 c4 c5 c6) (values (count-if (progn (setf c1 (incf i)) #'null) (progn (setf c2 (incf i)) '(a nil b c nil d e)) :from-end (progn (setf c3 (incf i)) nil) :key (progn (setf c4 (incf i)) #'identity) :end (progn (setf c5 (incf i)) 3) :start (progn (setf c6 (incf i)) 0) ) i c1 c2 c3 c4 c5 c6)) 1 6 1 2 3 4 5 6) ;;; Keyword tests (deftest count-if.allow-other-keys.1 (count-if #'evenp '(1 2 3 4 5) :bad t :allow-other-keys t) 2) (deftest count-if.allow-other-keys.2 (count-if #'evenp '(1 2 3 4 5) :allow-other-keys #p"*" :also-bad t) 2) ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest count-if.allow-other-keys.3 (count-if #'evenp '(1 2 3 4 5) :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest count-if.keywords.4 (count-if #'evenp '(1 2 3 4 5) :key #'identity :key #'1+) 2) (deftest count-if.allow-other-keys.5 (count-if #'evenp '(1 2 3 4 5) :allow-other-keys nil) 2) ;;; Error tests (deftest count-if.error.1 (classify-error (count-if #'identity 1)) type-error) (deftest count-if.error.2 (classify-error (count-if #'identity 'a)) type-error) (deftest count-if.error.3 (classify-error (count-if #'identity #\a)) type-error) (deftest count-if.error.4 (classify-error (count-if)) program-error) (deftest count-if.error.5 (classify-error (count-if #'null)) program-error) (deftest count-if.error.6 (classify-error (count-if #'null nil :bad t)) program-error) (deftest count-if.error.7 (classify-error (count-if #'null nil :bad t :allow-other-keys nil)) program-error) (deftest count-if.error.8 (classify-error (count-if #'null nil :key)) program-error) (deftest count-if.error.9 (classify-error (count-if #'null nil 3 3)) program-error) ;;; Only leftmost :allow-other-keys argument matters (deftest count-if.error.10 (classify-error (count-if #'null nil :bad t :allow-other-keys nil :allow-other-keys t)) program-error) (deftest count-if.error.11 (classify-error (locally (count-if #'identity 1) t)) type-error) (deftest count-if.error.12 (classify-error (count-if #'cons '(a b c))) program-error) (deftest count-if.error.13 (classify-error (count-if #'car '(a b c))) type-error) (deftest count-if.error.14 (classify-error (count-if #'identity '(a b c) :key #'cdr)) type-error) (deftest count-if.error.15 (classify-error (count-if #'identity '(a b c) :key #'cons)) program-error) gcl/ansi-tests/count.lsp000066400000000000000000000314351242227143400155740ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 19 07:31:55 2002 ;;;; Contains: Tests for COUNT (in-package :cl-test) (deftest count-list.1 (count 'a '(a b c d e a e f)) 2) (deftest count-list.2 (count 'a '(a b c d e a e f) :test #'eql) 2) (deftest count-list.3 (count 'a '(a b c d e a e f) :test 'eql) 2) (deftest count-list.4 (count 1 '(1 2 2 3 2 1 2 2 5 4) :key #'1-) 5) (deftest count-list.5 (count 1 '(1 2 2 3 2 1 2 2 5 4) :key '1-) 5) (deftest count-list.6 (count 1 '(1 2 2 3 2 1 2 2 5 4) :key #'1- :test #'equal) 5) (deftest count-list.7 (count 1 '(2 1 1 2 3 1 4 1 7 6 1 8) :from-end t) 5) (deftest count-list.8 (let ((c 0)) (count 1 '(1 2 3 1 4 1 7 6 1 8) :key #'(lambda (x) ;; (format t "~%~A ~A" x c) (prog1 (- x c) (incf c))))) 4) (deftest count-list.9 (let ((c 0)) (count 1 '(1 2 3 7 4 5 7 6 2 8) :from-end t :key #'(lambda (x) ;; (format t "~%~A ~A" x c) (prog1 (- x c) (incf c))))) 3) (deftest count-list.10 (count 1 '(1 1 1 1 1 2 1 1) :start 3) 4) (deftest count-list.11 (count 1 '(1 1 1 1 1 2 1 1) :end 6) 5) (deftest count-list.12 (count 1 '(1 1 1 1 1 2 1 1) :start 2 :end 7) 4) (deftest count-list.13 (count 1 '(1 1 1 1 1 2 1 1) :start 3 :end nil) 4) (deftest count-list.14 (count 1 '(1 1 1 1 1 2 1 1) :end nil) 7) (deftest count-list.15 (count 1 '(1 1 1 1 1 2 1 1) :test-not #'eql) 1) (deftest count-list.16 (count 1 '(1 1 1 3 1 2 1 1) :start 2 :end 7 :test #'(lambda (x y) (declare (ignore x y)) t)) 5) ;;; On vectors (deftest count-vector.1 (count 'a #(a b c d e a e f)) 2) (deftest count-vector.2 (count 'a #(a b c d e a e f) :test #'eql) 2) (deftest count-vector.3 (count 'a #(a b c d e a e f) :test 'eql) 2) (deftest count-vector.4 (count 1 #(1 2 2 3 2 1 2 2 5 4) :key #'1-) 5) (deftest count-vector.5 (count 1 #(1 2 2 3 2 1 2 2 5 4) :key '1-) 5) (deftest count-vector.6 (count 1 #(1 2 2 3 2 1 2 2 5 4) :key #'1- :test #'equal) 5) (deftest count-vector.7 (count 1 #(2 1 1 2 3 1 4 1 7 6 1 8) :from-end t) 5) (deftest count-vector.8 (let ((c 0)) (count 1 #(1 2 3 1 4 1 7 6 1 8) :key #'(lambda (x) ;; (format t "~%~A ~A" x c) (prog1 (- x c) (incf c))))) 4) (deftest count-vector.9 (let ((c 0)) (count 1 #(1 2 3 7 4 5 7 6 2 8) :from-end t :key #'(lambda (x) ;; (format t "~%~A ~A" x c) (prog1 (- x c) (incf c))))) 3) (deftest count-vector.10 (count 1 #(1 1 1 1 1 2 1 1) :start 3) 4) (deftest count-vector.11 (count 1 #(1 1 1 1 1 2 1 1) :end 6) 5) (deftest count-vector.12 (count 1 #(1 1 1 1 1 2 1 1) :start 2 :end 7) 4) (deftest count-vector.13 (count 1 #(1 1 1 1 1 2 1 1) :start 3 :end nil) 4) (deftest count-vector.14 (count 1 #(1 1 1 1 1 2 1 1) :end nil) 7) (deftest count-vector.15 (count 1 #(1 1 1 1 1 2 1 1) :test-not #'eql) 1) (deftest count-vector16 (count 1 #(1 1 1 3 1 2 1 1) :start 2 :end 7 :test #'(lambda (x y) (declare (ignore x y)) t)) 5) ;;; Non-simple vectors (deftest count-filled-vector.1 (count 'a (make-array 8 :initial-contents '(a b c d e a e f) :fill-pointer t)) 2) (deftest count-filled-vector.2 (count 'a (make-array 8 :initial-contents '(a b c d e a e f) :fill-pointer t) :test #'eql) 2) (deftest count-filled-vector.3 (count 'a (make-array 8 :initial-contents '(a b c d e a e f) :fill-pointer t) :test 'eql) 2) (deftest count-filled-vector.4 (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) :fill-pointer t) :key #'1-) 5) (deftest count-filled-vector.5 (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) :fill-pointer t) :key '1-) 5) (deftest count-filled-vector.6 (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) :fill-pointer t) :key #'1- :test #'equal) 5) (deftest count-filled-vector.7 (count 1 (make-array 12 :initial-contents '(2 1 1 2 3 1 4 1 7 6 1 8) :fill-pointer t) :from-end t) 5) (deftest count-filled-vector.8 (let ((c 0)) (count 1 (make-array 10 :initial-contents '(1 2 3 1 4 1 7 6 1 8) :fill-pointer t) :key #'(lambda (x) ;; (format t "~%~A ~A" x c) (prog1 (- x c) (incf c))))) 4) (deftest count-filled-vector.9 (let ((c 0)) (count 1 (make-array 10 :initial-contents '(1 2 3 7 4 5 7 6 2 8) :fill-pointer t) :from-end t :key #'(lambda (x) ;; (format t "~%~A ~A" x c) (prog1 (- x c) (incf c))))) 3) (deftest count-filled-vector.10 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) :fill-pointer t) :start 3) 4) (deftest count-filled-vector.11 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) :fill-pointer t) :end 6) 5) (deftest count-filled-vector.12 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) :fill-pointer t) :start 2 :end 7) 4) (deftest count-filled-vector.13 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) :fill-pointer t) :start 3 :end nil) 4) (deftest count-filled-vector.14 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) :fill-pointer t) :end nil) 7) (deftest count-filled-vector.15 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) :fill-pointer t) :test-not #'eql) 1) (deftest count-filled-vector.16 (count 1 (make-array 8 :initial-contents '(1 1 1 3 1 2 1 1) :fill-pointer t) :start 2 :end 7 :test #'(lambda (x y) (declare (ignore x y)) t)) 5) (deftest count-filled-vector.17 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) :fill-pointer 6)) 6) (deftest count-filled-vector.18 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) :fill-pointer 6) :start 2) 4) (deftest count-filled-vector.19 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) :fill-pointer 6) :from-end 'foo) 6) (deftest count-filled-vector.20 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) :fill-pointer 6) :start 2 :from-end 'yes) 4) ;;; Tests on bit vectors (deftest count-bit-vector.1 (count 1 #*00101100011011000) 7) (deftest count-bit-vector.2 (count 1 #*00101100011011000 :test #'eql) 7) (deftest count-bit-vector.3 (count 1 #*00101100011011000 :test 'eql) 7) (deftest count-bit-vector.4 (count 1 #*00101100011011000 :key #'1+) 10) (deftest count-bit-vector.5 (count 0 #*00101100011011000 :key '1-) 7) (deftest count-bit-vector.6 (count 0 #*00101100011011000 :key #'1- :test #'equal) 7) (deftest count-bit-vector.7 (count 1 #*00101100011011000 :from-end t) 7) (deftest count-bit-vector.8 (let ((c 1)) (count 0 #*0000110101001 :key #'(lambda (x) (setf c (- c)) (+ c x)))) 2) (deftest count-bit-vector.9 (let ((c 1)) (count 0 #*0000011010101 :from-end t :key #'(lambda (x) (setf c (- c)) (+ c x)))) 4) (deftest count-bit-vector.10 (count 1 #*11000110110 :start 3) 4) (deftest count-bit-vector.11 (count 1 '#*110111110111 :end 6) 5) (deftest count-bit-vector.12 (count 1 #*11111011 :start 2 :end 7) 4) (deftest count-bit-vector.13 (count 1 #*11111011 :start 3 :end nil) 4) (deftest count-bit-vector.14 (count 1 #*11111011 :end nil) 7) (deftest count-bit-vector.15 (count 1 #*11111011 :test-not #'eql) 1) (deftest count-bit-vector.16 (count 1 #*11101101 :start 2 :end 7 :test #'(lambda (x y) (declare (ignore x y)) t)) 5) (deftest count-bit-vector.17 (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) :element-type 'bit :fill-pointer 5)) 4) (deftest count-bit-vector.18 (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) :element-type 'bit :fill-pointer 5) :start 1) 3) (deftest count-bit-vector.19 (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) :element-type 'bit :fill-pointer 5) :end nil) 4) (deftest count-bit-vector.20 (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) :element-type 'bit :fill-pointer 6) :end 4) 3) ;;; Tests on strings (deftest count-string.1 (count #\1 "00101100011011000") 7) (deftest count-string.2 (count #\1 "00101100011011000" :test #'eql) 7) (deftest count-string.3 (count #\1 "00101100011011000" :test 'eql) 7) (deftest count-string.4 (count #\1 "00101100011011000" :key #'(lambda (x) (if (eql x #\0) #\1 #\2))) 10) (deftest count-string.5 (count #\1 "00101100011011000" :key 'identity) 7) (deftest count-string.6 (count #\1 "00101100011011000" :key #'identity :test #'equal) 7) (deftest count-string.7 (count #\1 "00101100011011000" :from-end t) 7) (deftest count-string.8 (let ((c nil)) (count #\0 "0000110101001" :key #'(lambda (x) (setf c (not c)) (and c x)))) 5) (deftest count-string.9 (let ((c nil)) (count #\0 "0000011010101" :from-end t :key #'(lambda (x) (setf c (not c)) (and c x)))) 3) (deftest count-string.10 (count #\1 "11000110110" :start 3) 4) (deftest count-string.11 (count #\1 '"110111110111" :end 6) 5) (deftest count-string.12 (count #\1 "11111011" :start 2 :end 7) 4) (deftest count-string.13 (count #\1 "11111011" :start 3 :end nil) 4) (deftest count-string.14 (count #\1 "11111011" :end nil) 7) (deftest count-string.15 (count #\1 "11111011" :test-not #'eql) 1) (deftest count-string.16 (count #\1 "11101101" :start 2 :end 7 :test #'(lambda (x y) (declare (ignore x y)) t)) 5) (deftest count-string.17 (count #\a (make-array 10 :initial-contents "abaaacaaaa" :fill-pointer 7 :element-type 'character)) 5) (deftest count-string.18 (count #\a (make-array 10 :initial-contents "abaaacaaaa" :fill-pointer 7 :element-type 'character) :start 1) 4) (deftest count-string.19 (count #\a (make-array 10 :initial-contents "abaaacaaaa" :fill-pointer 7 :element-type 'character) :end nil) 5) (deftest count-string.20 (count #\a (make-array 10 :initial-contents "abaaacaaaa" :fill-pointer 7 :element-type 'character) :start 2 :end 5) 3) ;;; Argument order tests (deftest count.order.1 (let ((i 0) c1 c2 c3 c4 c5 c6 c7) (values (count (progn (setf c1 (incf i)) nil) (progn (setf c2 (incf i)) '(a nil b c nil d e)) :start (progn (setf c3 (incf i)) 0) :end (progn (setf c4 (incf i)) 3) :key (progn (setf c5 (incf i)) #'identity) :from-end (progn (setf c6 (incf i)) nil) :test (progn (setf c7 (incf i)) #'eql) ) i c1 c2 c3 c4 c5 c6 c7)) 1 7 1 2 3 4 5 6 7) (deftest count.order.2 (let ((i 0) c1 c2 c3 c4 c5 c6 c7) (values (count (progn (setf c1 (incf i)) nil) (progn (setf c2 (incf i)) '(a nil b c nil d e)) :test (progn (setf c3 (incf i)) #'eql) :from-end (progn (setf c4 (incf i)) nil) :key (progn (setf c5 (incf i)) #'identity) :end (progn (setf c6 (incf i)) 3) :start (progn (setf c7 (incf i)) 0) ) i c1 c2 c3 c4 c5 c6 c7)) 1 7 1 2 3 4 5 6 7) ;;; Keyword tests (deftest count.allow-other-keys.1 (count 'a '(b a d a c) :bad t :allow-other-keys t) 2) (deftest count.allow-other-keys.2 (count 'a '(b a d a c) :allow-other-keys #p"*" :also-bad t) 2) ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest count.allow-other-keys.3 (count 'a '(b a d a c) :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest count.keywords.4 (count 2 '(1 2 3 2 5) :key #'identity :key #'1+) 2) (deftest count.allow-other-keys.5 (count 'a '(a b c a) :allow-other-keys nil) 2) ;;; Error tests (deftest count.error.1 (classify-error (count 'a 1)) type-error) (deftest count.error.2 (classify-error (count 'a 'a)) type-error) (deftest count.error.3 (classify-error (count 'a #\a)) type-error) (deftest count.error.4 (classify-error (count)) program-error) (deftest count.error.5 (classify-error (count nil)) program-error) (deftest count.error.6 (classify-error (count nil nil :bad t)) program-error) (deftest count.error.7 (classify-error (count nil nil :bad t :allow-other-keys nil)) program-error) (deftest count.error.8 (classify-error (count nil nil :key)) program-error) (deftest count.error.9 (classify-error (count nil nil 3 3)) program-error) ;;; Only leftmost :allow-other-keys argument matters (deftest count.error.10 (classify-error (count 'a nil :bad t :allow-other-keys nil :allow-other-keys t)) program-error) (deftest count.error.11 (classify-error (locally (count 'a 1) t)) type-error) (deftest count.error.12 (classify-error (count 'b '(a b c) :test #'identity)) program-error) (deftest count.error.13 (classify-error (count 'b '(a b c) :key #'car)) type-error) (deftest count.error.14 (classify-error (count 'b '(a b c) :test-not #'identity)) program-error) (deftest count.error.15 (classify-error (count 'b '(a b c) :key #'cons)) program-error) gcl/ansi-tests/ctypecase.lsp000066400000000000000000000030441242227143400164170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 23:05:10 2002 ;;;; Contains: Tests of CTYPECASE (in-package :cl-test) (deftest ctypecase.1 (let ((x 1)) (ctypecase x (integer 'a) (t 'b))) a) (deftest ctypecase.2 (classify-error (let ((x 1)) (ctypecase x (symbol 'a)))) type-error) (deftest ctypecase.3 (let ((x 1)) (ctypecase x (symbol 'a) (t 'b))) b) (deftest ctypecase.4 (let ((x 1)) (ctypecase x (t (values))))) (deftest ctypecase.5 (let ((x 1)) (ctypecase x (integer (values)) (t 'a)))) (deftest ctypecase.6 (let ((x 1)) (ctypecase x (bit 'a) (integer 'b))) a) (deftest ctypecase.7 (let ((x 1)) (ctypecase x (t 'a))) a) (deftest ctypecase.8 (let ((x 1)) (ctypecase x (t (values 'a 'b 'c)))) a b c) (deftest ctypecase.9 (let ((x 1)) (ctypecase x (integer (values 'a 'b 'c)) (t nil))) a b c) (deftest ctypecase.10 (let ((x 0) (y 1)) (values (ctypecase y (bit (incf x) 'a) (integer (incf x 2) 'b) (t (incf x 4) 'c)) x)) a 1) (deftest ctypecase.11 (let ((x 1)) (ctypecase x (integer) (t 'a))) nil) (deftest ctypecase.12 (let ((x 1)) (values (handler-bind ((type-error #'(lambda (c) (store-value 'a c)))) (ctypecase x (symbol :good) (float :bad))) x)) :good a) ;;; (deftest ctypecase.error.1 ;;; (classify-error (ctypecase)) ;;; program-error) (deftest ctypecase.13 (ctypecase 'a (number 'bad) (#.(find-class 'symbol nil) 'good)) good) gcl/ansi-tests/data-and-control-flow.lsp000066400000000000000000000016551242227143400205410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 21 22:21:48 2002 ;;;; Contains: Overall tests for section 5 of spec, "Data and Control Flow" (in-package :cl-test) ;;; Functions from section 5 (defparameter *dcf-fns* '(apply fboundp fmakunbound funcall function-lambda-expression functionp compiled-function-p not eq eql equal equalp identity complement constantly every some notevery notany values-list get-setf-expansion)) ;;; Macros from section 5 (defparameter *dcf-macros* '(defun defconstant defparameter defvar destructuring-bind psetq return and cond or when unless case ccase ecase multiple-value-list multiple-value-setq nth-value prog prog* prog1 prog2 define-modify-macro defsetf define-setf-expander setf psetf shiftf rotatef)) (deftest dcf-funs (remove-if #'fboundp *dcf-fns*) nil) (deftest dcf-macros (remove-if #'macro-function *dcf-macros*) nil) gcl/ansi-tests/defconstant.lsp000066400000000000000000000020471242227143400167510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 23:05:39 2002 ;;;; Contains: Tests of DEFCONSTANT (in-package :cl-test) (defconstant test-constant-1 17) (deftest defconstant.1 (symbol-value 'test-constant-1) 17) (deftest defconstant.2 (notnot-mv (constantp 'test-constant-1)) t) (deftest defconstant.3 (documentation 'test-constant-1 'variable) nil) (defconstant test-constant-2 'a "This is the documentation.") (deftest defconstant.4 (documentation 'test-constant-2 'variable) "This is the documentation.") (deftest defconstant.5 (defconstant test-constant-3 0) test-constant-3) ;;; (deftest defconstant.error.1 ;;; (classify-error (defconstant)) ;;; program-error) ;;; ;;; (deftest defconstant.error.2 ;;; (classify-error (defconstant +ignorable-constant-name+)) ;;; program-error) ;;; ;;; (deftest defconstant.error.3 ;;; (classify-error (defconstant +ignorable-constant-name2+ nil ;;; "This is a docstring" ;;; "This is an unnecessary extra argument.")) ;;; program-error) gcl/ansi-tests/define-modify-macro.lsp000066400000000000000000000034621242227143400202610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 11:42:14 2002 ;;;; Contains: Tests of DEFINE-MODIFY-MACRO (in-package :cl-test) (deftest define-modify-macro.1 (values (eval '(define-modify-macro dmm1-appendf (&rest args) append "Append lists onto a list")) (eval '(let ((u '(p q r)) v) (list (setq v u) (dmm1-appendf u '(a b c d)) (dmm1-appendf u ()) (dmm1-appendf u '(e f g)) u v)))) dmm1-appendf ((p q r) (p q r a b c d) (p q r a b c d) (p q r a b c d e f g) (p q r a b c d e f g) (p q r))) (deftest define-modify-macro.2 (values (eval '(define-modify-macro new-incf (&optional (delta 1)) +)) (eval '(let ((i 10)) (list (new-incf i) (new-incf i 100) i)))) new-incf (11 111 111)) (deftest define-modify-macro.3 (values (eval '(define-modify-macro new-incf1 (&optional (delta 1)) +)) (eval '(let ((a (vector 0 0 0 0 0)) (i 1)) (list (new-incf1 (aref a (incf i))) a i)))) new-incf1 (1 #(0 0 1 0 0) 2)) (deftest define-modify-macro.4 (values (eval '(define-modify-macro new-incf2 (&optional (delta 1)) +)) (eval '(let ((a (vector 0 0 0 0 0)) (i 1)) (list (new-incf2 (aref a (incf i)) (incf i)) a i)))) new-incf2 (3 #(0 0 3 0 0) 3)) ;;; (deftest define-modify-macro.error.1 ;;; (classify-error (define-modify-macro)) ;;; program-error) ;;; ;;; (deftest define-modify-macro.error.2 ;;; (classify-error (define-modify-macro dfm-error-1)) ;;; program-error) ;;; ;;; (deftest define-modify-macro.error.3 ;;; (classify-error (define-modify-macro dfm-error-2 ())) ;;; program-error) ;;; ;;; (deftest define-modify-macro.error.4 ;;; (classify-error (define-modify-macro dfm-error-2 () nil "Documentation" ;;; "extra illegal argument")) ;;; program-error) gcl/ansi-tests/defparameter.lsp000066400000000000000000000032701242227143400170770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 23:13:22 2002 ;;;; Contains: Tests of DEFPARAMETER (in-package :cl-test) (defparameter *defparameter-test-var-1* 100) (deftest defparameter.1 *defparameter-test-var-1* 100) (deftest defparameter.2 (documentation '*defparameter-test-var-1* 'variable) nil) ;;; Show that it's declared special. (deftest defparameter.3 (flet ((%f () *defparameter-test-var-1*)) (let ((*defparameter-test-var-1* 29)) (%f))) 29) (deftest defparameter.4 (values (makunbound '*defparameter-test-var-2*) (defparameter *defparameter-test-var-2* 200 "Whatever.") (documentation '*defparameter-test-var-2* 'variable) *defparameter-test-var-2*) *defparameter-test-var-2* *defparameter-test-var-2* "Whatever." 200) (deftest defparameter.5 (values (makunbound '*defparameter-test-var-2*) (defparameter *defparameter-test-var-2* 200 "Whatever.") (documentation '*defparameter-test-var-2* 'variable) *defparameter-test-var-2* (defparameter *defparameter-test-var-2* 300 "And ever.") (documentation '*defparameter-test-var-2* 'variable) *defparameter-test-var-2* ) *defparameter-test-var-2* *defparameter-test-var-2* "Whatever." 200 *defparameter-test-var-2* "And ever." 300) ;;; (deftest defparameter.error.1 ;;; (classify-error (defparameter)) ;;; program-error) ;;; ;;; (deftest defparameter.error.2 ;;; (classify-error (defparameter *ignored-defparameter-name*)) ;;; program-error) ;;; ;;; (deftest defparameter.error.3 ;;; (classify-error (defparameter *ignored-defparameter-name* nil ;;; "documentation" ;;; "illegal extra argument")) ;;; program-error) gcl/ansi-tests/defun.lsp000066400000000000000000000006101242227143400155340ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 16 23:40:32 2003 ;;;; Contains: Tests of DEFUN (in-package :cl-test) ;;; DEFUN is used extensively elsewhere, so I'm just putting error ;;; case tests here #| (deftest defun.error.1 (classify-error (defun)) program-error) (deftest defun.error.2 (classify-error (defun ignored-defun-name)) program-error) |# gcl/ansi-tests/defvar.lsp000066400000000000000000000026131242227143400157070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 23:21:50 2002 ;;;; Contains: Tests for DEFVAR (in-package :cl-test) (defvar *defvar-test-var-1* 100) (deftest defvar.1 *defvar-test-var-1* 100) (deftest defvar.2 (documentation '*defvar-test-var-1* 'variable) nil) ;;; Show that it's declared special. (deftest defvar.3 (flet ((%f () *defvar-test-var-1*)) (let ((*defvar-test-var-1* 29)) (%f))) 29) (deftest defvar.4 (values (makunbound '*defvar-test-var-2*) (defvar *defvar-test-var-2* 200 "Whatever.") (documentation '*defvar-test-var-2* 'variable) *defvar-test-var-2*) *defvar-test-var-2* *defvar-test-var-2* "Whatever." 200) (deftest defvar.5 (let ((x 0)) (values (makunbound '*defvar-test-var-2*) (defvar *defvar-test-var-2* 200 "Whatever.") (documentation '*defvar-test-var-2* 'variable) *defvar-test-var-2* (defvar *defvar-test-var-2* (incf x) "And ever.") (documentation '*defvar-test-var-2* 'variable) *defvar-test-var-2* x )) *defvar-test-var-2* *defvar-test-var-2* "Whatever." 200 *defvar-test-var-2* "And ever." 200 0) ;;; (deftest defvar.error.1 ;;; (classify-error (defvar)) ;;; program-error) ;;; ;;; (deftest defvar.error.2 ;;; (classify-error (defvar *ignored-defvar-name* nil "documentation" ;;; "illegal extra argument")) ;;; program-error) gcl/ansi-tests/destructuring-bind.lsp000066400000000000000000000055241242227143400202600ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 23:25:50 2002 ;;;; Contains: Tests for DESTRUCTURING-BIND (in-package :cl-test) ;;; See the page for this in section 5.3 ;;; Also, see destructuring lambda lists in section 3.4.5 (deftest destructuring-bind.1 (destructuring-bind (x y z) '(a b c) (values x y z)) a b c) (deftest destructuring-bind.2 (destructuring-bind (x y &rest z) '(a b c d) (values x y z)) a b (c d)) (deftest destructuring-bind.3 (destructuring-bind (x y &optional z) '(a b c) (values x y z)) a b c) (deftest destructuring-bind.4 (destructuring-bind (x y &optional z) '(a b) (values x y z)) a b nil) (deftest destructuring-bind.5 (destructuring-bind (x y &optional (z 'w)) '(a b) (values x y z)) a b w) (deftest destructuring-bind.6 (destructuring-bind (x y &optional (z 'w z-p)) '(a b) (values x y z z-p)) a b w nil) (deftest destructuring-bind.7 (destructuring-bind (x y &optional (z 'w z-p)) '(a b c) (values x y z z-p)) a b c t) (deftest destructuring-bind.8 (destructuring-bind (x y &optional z w) '(a b c) (values x y z w)) a b c nil) (deftest destructuring-bind.9 (destructuring-bind ((x y)) '((a b)) (values x y)) a b) (deftest destructuring-bind.10 (destructuring-bind (&whole w (x y)) '((a b)) (values x y w)) a b ((a b))) (deftest destructuring-bind.11 (destructuring-bind ((x . y) . w) '((a b) c) (values x y w)) a (b) (c)) (deftest destructuring-bind.12 (destructuring-bind (x y &body z) '(a b c d) (values x y z)) a b (c d)) (deftest destructuring-bind.13 (destructuring-bind (&whole x y z) '(a b) (values x y z)) (a b) a b) (deftest destructuring-bind.14 (destructuring-bind (w (&whole x y z)) '(1 (a b)) (values w x y z)) 1 (a b) a b) (deftest destructuring-bind.15 (destructuring-bind (&key a b c) '(:a 1) (values a b c)) 1 nil nil) (deftest destructuring-bind.16 (destructuring-bind (&key a b c) '(:b 1) (values a b c)) nil 1 nil) (deftest destructuring-bind.17 (destructuring-bind (&key a b c) '(:c 1) (values a b c)) nil nil 1) (deftest destructuring-bind.18 (destructuring-bind ((&key a b c)) '((:c 1 :b 2)) (values a b c)) nil 2 1) ;;; Error cases #| (deftest destructuring-bind.error.1 (classify-error (destructuring-bind (a b c) nil (list a b c))) program-error) (deftest destructuring-bind.error.2 (classify-error (destructuring-bind ((a b c)) nil (list a b c))) program-error) (deftest destructuring-bind.error.3 (classify-error (destructuring-bind (a b) 'x (list a b))) program-error) (deftest destructuring-bind.error.4 (classify-error (destructuring-bind (a . b) 'x (list a b))) program-error) |# ;;; (deftest destructuring-bind.error.5 ;;; (classify-error (destructuring-bind)) ;;; program-error) ;;; ;;; (deftest destructuring-bind.error.6 ;;; (classify-error (destructuring-bind x)) ;;; program-error) gcl/ansi-tests/ecase.lsp000066400000000000000000000051431242227143400155210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 20:17:30 2002 ;;;; Contains: Tests for ECASE (in-package :cl-test) (deftest ecase.1 (ecase 'b (a 1) (b 2) (c 3)) 2) (deftest ecase.2 (classify-error (ecase 1)) type-error) (deftest ecase.3 (classify-error (ecase 1 (a 1) (b 2) (c 3))) type-error) ;;; It is legal to use T or OTHERWISE as key designators ;;; in ECASE forms. They have no special meaning here. (deftest ecase.4 (classify-error (ecase 1 (t nil))) type-error) (deftest ecase.5 (classify-error (ecase 1 (otherwise nil))) type-error) (deftest ecase.6 (ecase 'b ((a z) 1) ((y b w) 2) ((b c) 3)) 2) (deftest ecase.7 (ecase 'z ((a b c) 1) ((d e) 2) ((f z g) 3)) 3) (deftest ecase.8 (ecase (1+ most-positive-fixnum) (#.(1+ most-positive-fixnum) 'a)) a) (deftest ecase.9 (classify-error (ecase nil (nil 'a))) type-error) (deftest ecase.10 (ecase nil ((nil) 'a)) a) (deftest ecase.11 (ecase 'a (b 0) (a (values 1 2 3)) (c nil)) 1 2 3) (deftest ecase.12 (classify-error (ecase t (a 10))) type-error) (deftest ecase.13 (ecase t ((t) 10) (t 20)) 10) (deftest ecase.14 (let ((x (list 'a 'b))) (eval `(ecase (quote ,x) ((,x) 1) (a 2)))) 1) (deftest ecase.15 (classify-error (ecase 'otherwise ((t) 10))) type-error) (deftest ecase.16 (classify-error (ecase t ((otherwise) 10))) type-error) (deftest ecase.17 (classify-error (ecase 'a (b 0) (c 1) (otherwise 2))) type-error) (deftest ecase.18 (classify-error (ecase 'a (b 0) (c 1) ((otherwise) 2))) type-error) (deftest ecase.19 (classify-error (ecase 'a (b 0) (c 1) ((t) 2))) type-error) (deftest ecase.20 (ecase #\a ((#\b #\c) 10) ((#\d #\e #\A) 20) (() 30) ((#\z #\a #\y) 40)) 40) (deftest ecase.21 (ecase 1 (1 (values)) (2 'a))) (deftest ecase.23 (ecase 1 (1 (values 'a 'b 'c))) a b c) ;;; Show that the key expression is evaluated only once. (deftest ecase.25 (let ((x 0)) (values (ecase (progn (incf x) 'c) (a 1) (b 2) (c 3) (d 4)) x)) 3 1) ;;; Repeated keys are allowed (all but the first are ignored) (deftest ecase.26 (ecase 'b ((a b c) 10) (b 20)) 10) (deftest ecase.27 (ecase 'b (b 20) ((a b c) 10)) 20) (deftest ecase.28 (ecase 'b (b 20) (b 10) (d 0)) 20) ;;; There are implicit progns (deftest ecase.29 (let ((x nil)) (values (ecase 2 (1 (setq x 'a) 'w) (2 (setq x 'b) 'y) (3 (setq x 'c) 'z)) x)) y b) (deftest ecase.31 (ecase (values 'b 'c) (c 0) ((a b) 10) (d 20)) 10) (deftest ecase.32 (ecase 'a (a) (b 'b)) nil) gcl/ansi-tests/elt.lsp000066400000000000000000000176261242227143400152360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 19:38:29 2002 ;;;; Contains: Tests of ELT (in-package :cl-test) (declaim (optimize (safety 3))) ;; elt on lists (deftest elt.1 (classify-error (elt nil 0)) type-error) (deftest elt.1a (classify-error (elt nil -10)) type-error) (deftest elt.1b (classify-error (locally (elt nil 0) t)) type-error) (deftest elt.2 (classify-error (elt nil 1000000)) type-error) (deftest elt.3 (elt '(a b c d e) 0) a) (deftest elt.4 (elt '(a b c d e) 2) c) (deftest elt.5 (elt '(a b c d e) 4) e) (deftest elt.5a (classify-error (elt '(a b c d e) -4)) type-error) (deftest elt.6 (let ((x (make-int-list 1000))) (notnot-mv (every #'(lambda (i) (eql i (elt x i))) x))) t) (deftest elt.7 (let* ((x (list 'a 'b 'c 'd)) (y (setf (elt x 0) 'e))) (list x y)) ((e b c d) e)) (deftest elt.8 (let* ((x (list 'a 'b 'c 'd)) (y (setf (elt x 1) 'e))) (list x y)) ((a e c d) e)) (deftest elt.9 (let* ((x (list 'a 'b 'c 'd)) (y (setf (elt x 3) 'e))) (list x y)) ((a b c e) e)) (deftest elt.10 (classify-error (let ((x (list 'a 'b 'c))) (setf (elt x 4) 'd))) type-error) (deftest elt.11 (let ((x (list 'a 'b 'c 'd 'e))) (let ((y (loop for c on x collect c))) (setf (elt x 2) 'f) (notnot-mv (every #'eq y (loop for c on x collect c))))) t) (deftest elt.12 (let ((x (make-int-list 100000))) (elt x 90000)) 90000) (deftest elt.13 (let ((x (make-int-list 100000))) (setf (elt x 80000) 'foo) (list (elt x 79999) (elt x 80000) (elt x 80001))) (79999 foo 80001)) (deftest elt.14 (classify-error (let ((x (list 'a 'b 'c))) (elt x 10))) type-error) (deftest elt.15 (classify-error (let ((x (list 'a 'b 'c))) (elt x 'a))) type-error) (deftest elt.16 (classify-error (let ((x (list 'a 'b 'c))) (elt x 10.0))) type-error) (deftest elt.17 (classify-error (let ((x (list 'a 'b 'c))) (elt x -1))) type-error) (deftest elt.18 (classify-error (let ((x (list 'a 'b 'c))) (elt x -100000000000000000))) type-error) (deftest elt.19 (classify-error (let ((x (list 'a 'b 'c))) (elt x #\w))) type-error) (deftest elt.order.1 (let ((i 0) x y) (values (elt (progn (setf x (incf i)) '(a b c d e)) (progn (setf y (incf i)) 3)) i x y)) d 2 1 2) (deftest elt.order.2 (let ((i 0) x y z) (let ((a (make-array 1 :initial-element (list 'a 'b 'c 'd 'e)))) (values (setf (elt (aref a (progn (setf x (incf i)) 0)) (progn (setf y (incf i)) 3)) (progn (setf z (incf i)) 'k)) (aref a 0) i x y z))) k (a b c k e) 3 1 2 3) (deftest elt-v.1 (classify-error (elt (make-array '(0)) 0)) type-error) ;; (deftest elt-v.2 (elt (make-array '(1)) 0) nil) ;; actually undefined (deftest elt-v.3 (elt (make-array '(5) :initial-contents '(a b c d e)) 0) a) (deftest elt-v.4 (elt (make-array '(5) :initial-contents '(a b c d e)) 2) c) (deftest elt-v.5 (elt (make-array '(5) :initial-contents '(a b c d e)) 4) e) (deftest elt-v.6 (elt-v-6-body) t) (deftest elt-v.7 (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) (y (setf (elt x 0) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (e b c d e)) (deftest elt-v.8 (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) (y (setf (elt x 1) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (a e c d e)) (deftest elt-v.9 (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) (y (setf (elt x 3) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (a b c e e)) (deftest elt-v.10 (classify-error (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x 4) 'd))) type-error) (deftest elt-v.11 (classify-error (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x -100) 'd))) type-error) (deftest elt-v.12 (let ((x (make-int-array 100000))) (elt x 90000)) 90000) (deftest elt-v.13 (let ((x (make-int-array 100000))) (setf (elt x 80000) 'foo) (list (elt x 79999) (elt x 80000) (elt x 80001))) (79999 foo 80001)) ;;; Adjustable arrays (deftest elt-adj-array.1 (classify-error (elt (make-adj-array '(0)) 0)) type-error) ;;; (deftest elt-adj-array.2 (elt (make-adj-array '(1)) 0) nil) ;; actually undefined (deftest elt-adj-array.3 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 0) a) (deftest elt-adj-array.4 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 2) c) (deftest elt-adj-array.5 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 4) e) (deftest elt-adj-array.6 (elt-adj-array-6-body) t) (deftest elt-adj-array.7 (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) (y (setf (elt x 0) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (e b c d e)) (deftest elt-adj-array.8 (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) (y (setf (elt x 1) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (a e c d e)) (deftest elt-adj-array.9 (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) (y (setf (elt x 3) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (a b c e e)) (deftest elt-adj-array.10 (classify-error (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x 4) 'd))) type-error) (deftest elt-adj-array.11 (classify-error (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x -100) 'd))) type-error) (deftest elt-adj-array.12 (let ((x (make-int-array 100000 #'make-adj-array))) (elt x 90000)) 90000) (deftest elt-adj-array.13 (let ((x (make-int-array 100000 #'make-adj-array))) (setf (elt x 80000) 'foo) (list (elt x 79999) (elt x 80000) (elt x 80001))) (79999 foo 80001)) ;; displaced arrays (deftest elt-displaced-array.1 (classify-error (elt (make-displaced-array '(0) 100) 0)) type-error) (deftest elt-displaced-array.2 (elt (make-displaced-array '(1) 100) 0) 100) (deftest elt-displaced-array.3 (elt (make-displaced-array '(5) 100) 4) 104) ;;; Arrays with fill points (deftest elt-fill-pointer.1 (let ((a (make-array '(5) :initial-contents '(a b c d e) :fill-pointer 3))) (values (elt a 0) (elt a 1) (elt a 2))) a b c) (deftest elt-fill-pointer.2 (let ((a (make-array '(5) :initial-contents '(0 0 1 0 0) :element-type 'bit :fill-pointer 3))) (values (elt a 0) (elt a 1) (elt a 2))) 0 0 1) (deftest elt-fill-pointer.3 (classify-error (let ((a (make-array '(5) :initial-contents '(0 0 1 0 0) :fill-pointer 3))) (elt a 4))) type-error) (deftest elt-fill-pointer.4 (classify-error (let ((a (make-array '(5) :initial-contents '(0 0 1 0 0) :element-type 'bit :fill-pointer 3))) (elt a 4))) type-error) (deftest elt-fill-pointer.5 (let ((a (make-array '(5) :initial-contents '(#\a #\b #\c #\d #\e) :element-type 'character :fill-pointer 3))) (values (elt a 0) (elt a 1) (elt a 2))) #\a #\b #\c) (deftest elt-fill-pointer.6 (classify-error (let ((a (make-array '(5) :initial-contents '(#\a #\b #\c #\d #\e) :element-type 'character :fill-pointer 3))) (elt a 4))) type-error) (deftest elt-fill-pointer.7 (let ((a (make-array '(5) :initial-contents '(#\a #\b #\c #\d #\e) :element-type 'base-char :fill-pointer 3))) (values (elt a 0) (elt a 1) (elt a 2))) #\a #\b #\c) (deftest elt-fill-pointer.8 (classify-error (let ((a (make-array '(5) :initial-contents '(#\a #\b #\c #\d #\e) :element-type 'base-char :fill-pointer 3))) (elt a 4))) type-error) (deftest elt.error.1 (classify-error (elt)) program-error) (deftest elt.error.2 (classify-error (elt nil)) program-error) (deftest elt.error.3 (classify-error (elt nil 0 nil)) program-error) gcl/ansi-tests/eql.lsp000066400000000000000000000026041242227143400152210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 19:36:33 2002 ;;;; Contains: Tests of EQL (in-package :cl-test) ;;; EQLT is defined in ansi-aux.lsp ;;; It calls EQL, returning NIL when the result is false and T when it ;;; is true. (deftest eql.1 (loop for x in *universe* always (check-values (eql x x))) t) (deftest eql.2 (eqlt 2 (1+ 1)) t) (deftest eql.3 (let ((x "abc")) (eql x (copy-seq x))) nil) (deftest eql.4 (eqlt #\a #\a) t) (deftest eql.5 (eqlt 12345678901234567890 12345678901234567890) t) (deftest eql.7 (eql 12.0 12) nil) (deftest eql.8 (eqlt #c(1 -2) #c(1 -2)) t) (deftest eql.9 (let ((x "abc") (y "abc")) (if (eq x y) (eqlt x y) (not (eql x y)))) t) (deftest eql.10 (eql (list 'a) (list 'b)) nil) (deftest eql.11 (eqlt #c(1 -2) (- #c(-1 2))) t) (deftest eql.order.1 (let ((i 0) x y) (values (eql (setf x (incf i)) (setf y (incf i))) i x y)) nil 2 1 2) (deftest eql.error.1 (classify-error (eql)) program-error) (deftest eql.error.2 (classify-error (eql nil)) program-error) (deftest eql.error.3 (classify-error (eql nil nil nil)) program-error) ;;; Error tests for EQ (deftest eq.error.1 (classify-error (eq)) program-error) (deftest eq.error.2 (classify-error (eq nil)) program-error) (deftest eq.error.3 (classify-error (eq nil nil nil)) program-error) gcl/ansi-tests/equal.lsp000066400000000000000000000030711242227143400155460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 21:38:16 2002 ;;;; Contains: Tests for EQUAL (in-package :cl-test) (deftest equal.1 (loop for x in *symbols* always (loop for y in *symbols* always (if (eq x y) (equal x y) (not (equal x y))))) t) (deftest equal.2 (equalt (cons 'a 'b) (cons 'a 'b)) t) (deftest equal.3 (equalt (cons 'a 'c) (cons 'a 'b)) nil) (deftest equal.4 (equalt (vector 1 2 3) (vector 1 2 3)) nil) (deftest equal.5 (loop for c in *characters* always (loop for d in *characters* always (if (eql c d) (equalt c d) (not (equalt c d))))) t) (deftest equal.6 (equalt (make-pathname :name (copy-seq "foo")) (make-pathname :name (copy-seq "foo"))) t) (deftest equal.7 (equalt (make-pathname :name (copy-seq "foo")) (make-pathname :name (copy-seq "bar"))) nil) (deftest equal.8 (equalt (copy-seq "abcd") (copy-seq "abcd")) t) (deftest equal.9 (equalt (copy-seq "abcd") (copy-seq "abc")) nil) (deftest equal.10 (equalt (copy-seq "abcd") (copy-seq "ABCD")) nil) (deftest equal.11 (equalt (copy-seq #*000110) (copy-seq #*000110)) t) (deftest equal.12 (equalt (copy-seq #*000110) (copy-seq #*000111)) nil) (deftest equal.order.1 (let ((i 0) x y) (values (equal (setf x (incf i)) (setf y (incf i))) i x y)) nil 2 1 2) (deftest equal.error.1 (classify-error (equal)) program-error) (deftest equal.error.2 (classify-error (equal nil)) program-error) (deftest equal.error.3 (classify-error (equal nil nil nil)) program-error) gcl/ansi-tests/equalp.lsp000066400000000000000000000016551242227143400157340ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 22:14:42 2002 ;;;; Contains: Tests for EQUALP (in-package :cl-test) (deftest equalp.1 (loop for c across +base-chars+ always (loop for d across +base-chars+ always (if (char-equal c d) (equalpt c d) (not (equalpt c d))))) t) (deftest equalp.2 (loop for i from 1 to 100 always (loop for j from 1 to 100 always (if (eqlt i j) (equalpt i j) (not (equalpt i j))))) t) (deftest equalp.3 (equalpt "abc" "ABC") t) (deftest equalp.4 (equalpt "abc" "abd") nil) (deftest equalp.order.1 (let ((i 0) x y) (values (equalp (setf x (incf i)) (setf y (incf i))) i x y)) nil 2 1 2) (deftest equalp.error.1 (classify-error (equalp)) program-error) (deftest equalp.error.2 (classify-error (equalp nil)) program-error) (deftest equalp.error.3 (classify-error (equalp nil nil nil)) program-error) gcl/ansi-tests/error.lsp000066400000000000000000000026221242227143400155710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 28 21:37:43 2003 ;;;; Contains: Tests of ERROR (in-package :cl-test) (deftest error.1 (let ((fmt "Error")) (handler-case (error fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest error.2 (let* ((fmt "Error") (cnd (make-condition 'simple-error :format-control fmt))) (handler-case (error cnd) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest error.3 (let ((fmt "Error")) (handler-case (error 'simple-error :format-control fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest error.4 (let ((fmt "Error: ~A")) (handler-case (error fmt 10) (simple-error (c) (frob-simple-error c fmt 10)))) t) (deftest error.5 (let ((fmt (formatter "Error"))) (handler-case (error fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest error.6 (handler-case (error 'simple-condition) (error (c) :wrong) (simple-condition (c) :right)) :right) (deftest error.7 (handler-case (error 'simple-warning) (error (c) :wrong) (simple-warning (c) :right) (condition (c) :wrong2)) :right) (deftest error.8 (let ((fmt "Boo!")) (handler-case (error 'simple-warning :format-control fmt) (simple-warning (c) (frob-simple-warning c fmt)))) t) ;;; Tests for other conditions will in their own files. gcl/ansi-tests/etypecase.lsp000066400000000000000000000020741242227143400164230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 23:02:23 2002 ;;;; Contains: Tests of ETYPECASE (in-package :cl-test) (deftest etypecase.1 (etypecase 1 (integer 'a) (t 'b)) a) (deftest etypecase.2 (classify-error (etypecase 1 (symbol 'a))) type-error) (deftest etypecase.3 (etypecase 1 (symbol 'a) (t 'b)) b) (deftest etypecase.4 (etypecase 1 (t (values)))) (deftest etypecase.5 (etypecase 1 (integer (values)) (t 'a))) (deftest etypecase.6 (etypecase 1 (bit 'a) (integer 'b)) a) (deftest etypecase.7 (etypecase 1 (t 'a)) a) (deftest etypecase.8 (etypecase 1 (t (values 'a 'b 'c))) a b c) (deftest etypecase.9 (etypecase 1 (integer (values 'a 'b 'c)) (t nil)) a b c) (deftest etypecase.10 (let ((x 0)) (values (etypecase 1 (bit (incf x) 'a) (integer (incf x 2) 'b) (t (incf x 4) 'c)) x)) a 1) (deftest etypecase.11 (etypecase 1 (integer) (t 'a)) nil) (deftest etypecase.12 (etypecase 'a (number 'bad) (#.(find-class 'symbol nil) 'good)) good) gcl/ansi-tests/eval-and-compile.lsp000066400000000000000000000011411242227143400175500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 21 22:52:19 2002 ;;;; Contains: Overall tests for section 3, 'Evaluation and Compilation' (in-package :cl-test) (defparameter *eval-and-compile-fns* '(compile eval macroexpand macroexpand-1 proclaim special-operator-p constantp)) (deftest eval-and-compile-fns (remove-if #'fboundp *eval-and-compile-fns*) nil) (defparameter *eval-and-compile-macros* '(lambda define-compiler-macro defmacro define-symbol-macro declaim)) (deftest eval-and-compile-macros (remove-if #'macro-function *eval-and-compile-macros*) nil) gcl/ansi-tests/eval.lsp000066400000000000000000000014441242227143400153700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 21 10:43:15 2002 ;;;; Contains: Tests of EVAL (in-package :cl-test) (deftest eval.1 (eval 1) 1) (deftest eval.2 (loop for x being the symbols of "KEYWORD" always (eq (eval x) x)) t) (deftest eval.3 (let ((s "abcd")) (eqlt (eval s) s)) t) (deftest eval.4 (eval '(car '(a . b))) a) (deftest eval.5 (eval '(let ((x 0)) x)) 0) (deftest eval.6 (funcall #'eval 1) 1) (deftest eval.order.1 (let ((i 0)) (values (eval (progn (incf i) 10)) i)) 10 1) ;;; Error cases (deftest eval.error.1 (classify-error (eval)) program-error) (deftest eval.error.2 (classify-error (eval nil nil)) program-error) (deftest eval.error.3 (classify-error (eval (list (gensym)))) undefined-function) gcl/ansi-tests/every.lsp000066400000000000000000000055371242227143400156020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 23:25:58 2002 ;;;; Contains: Tests of EVERY (in-package :cl-test) (deftest every.1 (notnot-mv (every #'identity nil)) t) (deftest every.2 (notnot-mv (every #'identity #())) t) (deftest every.3 (let ((count 0)) (values (every #'(lambda (x) (incf count) (< x 10)) '(1 2 4 13 5 1)) count)) nil 4) (deftest every.4 (notnot-mv (every #'= '(1 2 3 4) '(1 2 3 4 5))) t) (deftest every.5 (notnot-mv (every #'= '(1 2 3 4 5) '(1 2 3 4))) t) (deftest every.6 (every #'= '(1 2 3 4 5) '(1 2 3 4 6)) nil) (deftest every.7 (notnot-mv (every #'(lambda (x y) (or x y)) '(nil t t nil t) #(t nil t t nil nil))) t) (deftest every.8 (let ((x '(1)) (args nil)) (loop for i from 1 below (1- (min 100 call-arguments-limit)) do (push x args) always (apply #'every #'= args))) t) (deftest every.9 (notnot-mv (every #'zerop #*000000000000)) t) (deftest every.10 (notnot-mv (every #'zerop #*)) t) (deftest every.11 (every #'zerop #*0000010000) nil) (deftest every.12 (notnot-mv (every #'(lambda (x) (eql x #\a)) "aaaaaaaa")) t) (deftest every.13 (notnot-mv (every #'(lambda (x) (eql x #\a)) "")) t) (deftest every.14 (every #'(lambda (x) (eql x #\a)) "aaaaaabaaaa") nil) (deftest every.15 (every 'null '(nil nil t nil)) nil) (deftest every.16 (notnot-mv (every 'null '(nil nil nil nil))) t) (deftest every.order.1 (let ((i 0) x y) (values (every (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '(nil nil a nil))) i x y)) nil 2 1 2) (deftest every.order.2 (let ((i 0) x y z) (values (every (progn (setf x (incf i)) #'equal) (progn (setf y (incf i)) '(nil nil a nil)) (progn (setf z (incf i)) '(nil nil a b))) i x y z)) nil 3 1 2 3) ;;; Error cases (deftest every.error.1 (classify-error (every 1 '(a b c))) type-error) (deftest every.error.2 (classify-error (every #\a '(a b c))) type-error) (deftest every.error.3 (classify-error (every #() '(a b c))) type-error) (deftest every.error.4 (classify-error (every #'null 'a)) type-error) (deftest every.error.5 (classify-error (every #'null 100)) type-error) (deftest every.error.6 (classify-error (every #'null 'a)) type-error) (deftest every.error.7 (classify-error (every #'eq () 'a)) type-error) ` (deftest every.error.8 (classify-error (every)) program-error) (deftest every.error.9 (classify-error (every #'null)) program-error) (deftest every.error.10 (classify-error (locally (every 1 '(a b c)) t)) type-error) (deftest every.error.11 (classify-error (every #'cons '(a b c))) program-error) (deftest every.error.12 (classify-error (every #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) (deftest every.error.13 (classify-error (every #'car '(a b c))) type-error) gcl/ansi-tests/fboundp.lsp000066400000000000000000000024511242227143400160750ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 7 22:37:22 2002 ;;;; Contains: Tests of FBOUNDP (in-package :cl-test) (deftest fboundp.1 (not-mv (fboundp 'car)) nil) (deftest fboundp.2 (not-mv (fboundp 'cdr)) nil) (deftest fboundp.3 (not-mv (fboundp 'defun)) ; a macro nil) (deftest fboundp.4 ;; fresh symbols are not fbound (let ((g (gensym))) (fboundp g)) nil) (defun fboundp-5-fn (x) x) (deftest fboundp.5 (not-mv (fboundp 'fboundp-5-fn)) nil) (eval-when (eval compile) (ignore-errors (defun (setf fboundp-6-accessor) (y x) (setf (car x) y)))) (deftest fboundp.6 (not-mv (fboundp '(setf fboundp-6-accessor))) nil) (deftest fboundp.7 (let ((g (gensym))) (fboundp (list 'setf g))) nil) (deftest fboundp.order.1 (let ((i 0)) (values (notnot (fboundp (progn (incf i) 'car))) i)) t 1) (deftest fboundp.error.1 (classify-error (fboundp 1)) type-error) (deftest fboundp.error.2 (classify-error (fboundp #\a)) type-error) (deftest fboundp.error.3 (classify-error (fboundp '(foo))) type-error) (deftest fboundp.error.4 (classify-error (fboundp)) program-error) (deftest fboundp.error.5 (classify-error (fboundp 'cons nil)) program-error) (deftest fboundp.error.6 (classify-error (locally (fboundp 1) t)) type-error) gcl/ansi-tests/fdefinition.lsp000066400000000000000000000030571242227143400167410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 15:27:51 2003 ;;;; Contains: Tests for FDEFINITION (in-package :cl-test) ;;; Error cases (deftest fdefinition.error.1 (classify-error (fdefinition)) program-error) (deftest fdefinition.error.2 (classify-error (fdefinition 'cons nil)) program-error) (deftest fdefinition.error.3 (classify-error (fdefinition (gensym))) undefined-function) (deftest fdefinition.error.4 (classify-error (fdefinition 10)) type-error) (deftest fdefinition.error.5 (classify-error (fdefinition (list 'setf (gensym)))) undefined-function) (deftest fdefinition.error.6 (classify-error (locally (fdefinition 10) t)) type-error) ;;; Non-error cases (deftest fdefinition.1 (let ((fun (fdefinition 'cons))) (funcall fun 'a 'b)) (a . b)) (deftest fdefinition.2 (progn (fdefinition 'cond) :good) :good) (deftest fdefinition.3 (progn (fdefinition 'setq) :good) :good) (deftest fdefinition.4 (let ((sym (gensym))) (values (fboundp sym) (progn (setf (fdefinition sym) (fdefinition 'cons)) (funcall (symbol-function sym) 'a 'b)) (notnot (fboundp sym)))) nil (a . b) t) (deftest fdefinition.5 (let* ((sym (gensym)) (fname (list 'setf sym))) (values (fboundp fname) (progn (setf (fdefinition fname) (fdefinition 'cons)) (eval `(setf (,sym 'a) 'b))) (notnot (fboundp fname)))) nil (b . a) t) (deftest fdefinition.order.1 (let ((i 0)) (fdefinition (progn (incf i) 'setq)) i) 1) gcl/ansi-tests/features.lsp000066400000000000000000000007711242227143400162610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Dec 2 07:44:40 2002 ;;;; Contains: Tests of *FEATURES* (in-package :cl-test) (deftest features.1 (let ((f *features*)) (or (not (member :draft-ansi-cl f)) (not (intersection '(:draft-ansi-cl-2 :ansi-cl) f)))) t) (deftest features.2 (let ((f *features*)) (or (not (intersection '(:x3j13 :draft-ansi-cl :ansi-cl) f)) (notnot (member :common-lisp f)))) t) (deftest features.3 (not (member :cltl2 *features*)) t) gcl/ansi-tests/fill-pointer.lsp000066400000000000000000000036231242227143400170460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 22:14:23 2003 ;;;; Contains: Tests of FILL-POINTER (in-package :cl-test) ;;; More tests are in make-array.lsp (deftest fill-pointer.1 (fill-pointer (make-array '(10) :fill-pointer 5)) 5) (deftest fill-pointer.2 (fill-pointer (make-array '(10) :fill-pointer t)) 10) (deftest fill-pointer.3 (let ((a (make-array '(10) :fill-pointer 5 :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) (values (fill-pointer a) (setf (fill-pointer a) 6) a)) 5 6 #(1 2 3 4 5 6)) (deftest fill-pointer.order.1 (let ((i 0) (a (make-array '(10) :fill-pointer 5))) (values (fill-pointer (progn (incf i) a)) i)) 5 1) (deftest fill-pointer.order.2 (let ((i 0) x y (a (make-array '(10) :fill-pointer 5 :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) (values i (setf (fill-pointer (progn (setf x (incf i)) a)) (progn (setf y (incf i)) 6)) a i x y)) 0 6 #(1 2 3 4 5 6) 2 1 2) ;;; Error tests (deftest fill-pointer.error.1 (classify-error (fill-pointer)) program-error) (deftest fill-pointer.error.2 (classify-error (fill-pointer (make-array '(10) :fill-pointer 4) nil)) program-error) (deftest fill-pointer.error.3 (classify-error (fill-pointer (make-array '(10) :fill-pointer nil))) type-error) (deftest fill-pointer.error.4 (classify-error (fill-pointer #0aNIL)) type-error) (deftest fill-pointer.error.5 (classify-error (fill-pointer #2a((a b c)(d e f)))) type-error) (deftest fill-pointer.error.6 (let (why) (loop for e in *mini-universe* when (and (or (not (typep e 'vector)) (not (array-has-fill-pointer-p e))) (not (eql (setq why (classify-error** `(fill-pointer ',e))) 'type-error))) collect (list e why))) nil) (deftest fill-pointer.error.7 (classify-error (locally (fill-pointer #2a((a b c)(d e f))) t)) type-error) gcl/ansi-tests/fill-strings.lsp000066400000000000000000000011701242227143400170520ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 17 08:04:27 2002 ;;;; Contains: Test cases for FILL on strings (in-package :cl-test) (deftest array-string-fill.1 (array-string-fill-test-fn "abcde" #\Z) t "ZZZZZ") (deftest array-string-fill.2 (array-string-fill-test-fn "abcde" #\Z :start 2) t "abZZZ") (deftest array-string-fill.3 (array-string-fill-test-fn "abcde" #\Z :end 3) t "ZZZde") (deftest array-string-fill.4 (array-string-fill-test-fn "abcde" #\Z :start 1 :end 4) t "aZZZe") (deftest array-string-fill.5 (array-string-fill-test-fn "abcde" #\Z :start 2 :end 3) t "abZde") gcl/ansi-tests/fill.lsp000066400000000000000000000305451242227143400153730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 19:44:45 2002 ;;;; Contains: Tests on FILL (in-package :cl-test) (deftest fill.error.1 (classify-error (fill 'a 'b)) type-error) (deftest fill.error.2 (classify-error (fill)) program-error) (deftest fill.error.3 (classify-error (fill (list 'a 'b))) program-error) (deftest fill.error.4 (classify-error (fill (list 'a 'b) 'c :bad t)) program-error) (deftest fill.error.5 (classify-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil)) program-error) (deftest fill.error.6 (classify-error (fill (list 'a 'b) 'c :start)) program-error) (deftest fill.error.7 (classify-error (fill (list 'a 'b) 'c :end)) program-error) (deftest fill.error.8 (classify-error (fill (list 'a 'b) 'c 1 2)) program-error) (deftest fill.error.10 (classify-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil :allow-other-keys t)) program-error) (deftest fill.error.11 (classify-error (locally (fill 'a 'b) t)) type-error) ;;; Fill on arrays (deftest array-fill-1 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x))) (values (eqt a b) (map 'list #'identity a))) t (x x x x x)) (deftest array-fill-2 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :start 2))) (values (eqt a b) (map 'list #'identity a))) t (a b x x x)) (deftest array-fill-3 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :end 2))) (values (eqt a b) (map 'list #'identity a))) t (x x c d e)) (deftest array-fill-4 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :start 1 :end 3))) (values (eqt a b) (map 'list #'identity a))) t (a x x d e)) (deftest array-fill-5 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :start 1 :end nil))) (values (eqt a b) (map 'list #'identity a))) t (a x x x x)) (deftest array-fill-6 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :end nil))) (values (eqt a b) (map 'list #'identity a))) t (x x x x x)) (deftest array-fill-7 (classify-error (let* ((a (make-array '(5)))) (fill a 'x :start -1))) type-error) (deftest array-fill-8 (classify-error (let* ((a (make-array '(5)))) (fill a 'x :start 'a))) type-error) (deftest array-fill-9 (classify-error (let* ((a (make-array '(5)))) (fill a 'x :end -1))) type-error) (deftest array-fill-10 (classify-error (let* ((a (make-array '(5)))) (fill a 'x :end 'a))) type-error) ;;; fill on arrays of fixnums (deftest array-fixnum-fill-1 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 6))) (values (eqt a b) (map 'list #'identity a))) t (6 6 6 6 6)) (deftest array-fixnum-fill-2 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 6 :start 2))) (values (eqt a b) (map 'list #'identity a))) t (1 2 6 6 6)) (deftest array-fixnum-fill-3 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 7 :end 2))) (values (eqt a b) (map 'list #'identity a))) t (7 7 3 4 5)) (deftest array-fixnum-fill-4 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 8 :start 1 :end 3))) (values (eqt a b) (map 'list #'identity a))) t (1 8 8 4 5)) (deftest array-fixnum-fill-5 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 0 :start 1 :end nil))) (values (eqt a b) (map 'list #'identity a))) t (1 0 0 0 0)) (deftest array-fixnum-fill-6 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a -1 :end nil))) (values (eqt a b) (map 'list #'identity a))) t (-1 -1 -1 -1 -1)) (deftest array-fixnum-fill-7 (classify-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a 10 :start -1))) type-error) (deftest array-fixnum-fill-8 (classify-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a 100 :start 'a))) type-error) (deftest array-fixnum-fill-9 (classify-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a -5 :end -1))) type-error) (deftest array-fixnum-fill-10 (classify-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a 17 :end 'a))) type-error) ;;; fill on arrays of unsigned eight bit bytes (deftest array-unsigned-byte8-fill-1 (array-unsigned-byte-fill-test-fn 8 6) t (6 6 6 6 6)) (deftest array-unsigned-byte8-fill-2 (array-unsigned-byte-fill-test-fn 8 6 :start 2) t (1 2 6 6 6)) (deftest array-unsigned-byte8-fill-3 (array-unsigned-byte-fill-test-fn 8 7 :end 2) t (7 7 3 4 5)) (deftest array-unsigned-byte8-fill-4 (array-unsigned-byte-fill-test-fn 8 8 :start 1 :end 3) t (1 8 8 4 5)) (deftest array-unsigned-byte8-fill-5 (array-unsigned-byte-fill-test-fn 8 9 :start 1 :end nil) t (1 9 9 9 9)) (deftest array-unsigned-byte8-fill-6 (array-unsigned-byte-fill-test-fn 8 0 :end nil) t (0 0 0 0 0)) (deftest array-unsigned-byte8-fill-7 (classify-error (array-unsigned-byte-fill-test-fn 8 0 :start -1)) type-error) (deftest array-unsigned-byte8-fill-8 (classify-error (array-unsigned-byte-fill-test-fn 8 100 :start 'a)) type-error) (deftest array-unsigned-byte8-fill-9 (classify-error (array-unsigned-byte-fill-test-fn 8 19 :end -1)) type-error) (deftest array-unsigned-byte8-fill-10 (classify-error (array-unsigned-byte-fill-test-fn 8 17 :end 'a)) type-error) ;;; Tests on arrays with fill pointers (deftest array-fill-pointer-fill.1 (let ((s1 (make-array '(10) :fill-pointer 5 :initial-element nil))) (fill s1 'a) (loop for i from 0 to 9 collect (aref s1 i))) (a a a a a nil nil nil nil nil)) (deftest array-fill-pointer-fill.2 (let ((s1 (make-array '(10) :fill-pointer 5 :initial-element nil))) (fill s1 'a :end nil) (loop for i from 0 to 9 collect (aref s1 i))) (a a a a a nil nil nil nil nil)) ;;; Tests on strings (deftest fill.string.1 (let* ((s1 (copy-seq "abcde")) (s2 (fill s1 #\z))) (values (eqt s1 s2) s2)) t "zzzzz") (deftest fill.string.2 (let* ((s1 (copy-seq "abcde")) (s2 (fill s1 #\z :start 0 :end 1))) (values (eqt s1 s2) s2)) t "zbcde") (deftest fill.string.3 (let* ((s1 (copy-seq "abcde")) (s2 (fill s1 #\z :end 2))) (values (eqt s1 s2) s2)) t "zzcde") (deftest fill.string.4 (let* ((s1 (copy-seq "abcde")) (s2 (fill s1 #\z :end nil))) (values (eqt s1 s2) s2)) t "zzzzz") (deftest fill.string.5 (let* ((s1 "aaaaaaaa") (len (length s1))) (loop for start from 0 to (1- len) always (loop for end from (1+ start) to len always (let* ((s2 (copy-seq s1)) (s3 (fill s2 #\z :start start :end end))) (and (eqt s2 s3) (string= s3 (substitute-if #\z (constantly t) s1 :start start :end end)) t))))) t) (deftest fill.string.6 (let* ((s1 "aaaaaaaa") (len (length s1))) (loop for start from 0 to (1- len) always (let* ((s2 (copy-seq s1)) (s3 (fill s2 #\z :start start))) (and (eqt s2 s3) (string= s3 (substitute-if #\z (constantly t) s1 :start start)) t)))) t) (deftest fill.string.7 (let* ((s1 "aaaaaaaa") (len (length s1))) (loop for start from 0 to (1- len) always (let* ((s2 (copy-seq s1)) (s3 (fill s2 #\z :end nil :start start))) (and (eqt s2 s3) (string= s3 (substitute-if #\z (constantly t) s1 :end nil :start start)) t)))) t) (deftest fill.string.8 (let* ((s1 "aaaaaaaa") (len (length s1))) (loop for end from 1 to len always (let* ((s2 (copy-seq s1)) (s3 (fill s2 #\z :end end))) (and (eqt s2 s3) (string= s3 (substitute-if #\z (constantly t) s1 :end end)) t)))) t) (deftest fill.string.9 (let* ((s1 (make-array '(8) :element-type 'character :initial-element #\z :fill-pointer 4)) (s2 (fill s1 #\a))) (and (eqt s1 s2) (coerce (loop for i from 0 to 7 collect (aref s2 i)) 'string))) "aaaazzzz") (deftest fill.string.10 (let* ((s1 (make-array '(8) :element-type 'base-char :initial-element #\z :fill-pointer 4)) (s2 (fill s1 #\a))) (and (eqt s1 s2) (coerce (loop for i from 0 to 7 collect (aref s2 i)) 'base-string))) "aaaazzzz") ;;; Tests for bit vectors (deftest fill.bit-vector.1 (let* ((s1 (copy-seq #*01100)) (s2 (fill s1 0))) (values (eqt s1 s2) s2)) t #*00000) (deftest fill.bit-vector.2 (let* ((s1 (copy-seq #*00100)) (s2 (fill s1 1 :start 0 :end 1))) (values (eqt s1 s2) s2)) t #*10100) (deftest fill.bit-vector.3 (let* ((s1 (copy-seq #*00010)) (s2 (fill s1 1 :end 2))) (values (eqt s1 s2) s2)) t #*11010) (deftest fill.bit-vector.4 (let* ((s1 (copy-seq #*00111)) (s2 (fill s1 0 :end nil))) (values (eqt s1 s2) s2)) t #*00000) (deftest fill.bit-vector.5 (let* ((s1 #*00000000) (len (length s1))) (loop for start from 0 to (1- len) always (loop for end from (1+ start) to len always (let* ((s2 (copy-seq s1)) (s3 (fill s2 1 :start start :end end))) (and (eqt s2 s3) (equalp s3 (substitute-if 1 (constantly t) s1 :start start :end end)) t))))) t) (deftest fill.bit-vector.6 (let* ((s1 #*11111111) (len (length s1))) (loop for start from 0 to (1- len) always (let* ((s2 (copy-seq s1)) (s3 (fill s2 0 :start start))) (and (eqt s2 s3) (equalp s3 (substitute-if 0 (constantly t) s1 :start start)) t)))) t) (deftest fill.bit-vector.7 (let* ((s1 #*00000000) (len (length s1))) (loop for start from 0 to (1- len) always (let* ((s2 (copy-seq s1)) (s3 (fill s2 1 :end nil :start start))) (and (eqt s2 s3) (equalp s3 (substitute-if 1 (constantly t) s1 :end nil :start start)) t)))) t) (deftest fill.bit-vector.8 (let* ((s1 #*11111111) (len (length s1))) (loop for end from 1 to len always (let* ((s2 (copy-seq s1)) (s3 (fill s2 0 :end end))) (and (eqt s2 s3) (equalp s3 (substitute-if 0 (constantly t) s1 :end end)) t)))) t) (deftest fill.bit-vector.9 (let* ((s1 (make-array '(8) :element-type 'bit :initial-element 0 :fill-pointer 4)) (s2 (fill s1 1))) (and (eqt s1 s2) (coerce (loop for i from 0 to 7 collect (aref s2 i)) 'bit-vector))) #*11110000) ;;; Test of :allow-other-keys (deftest fill.allow-other-keys.1 (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys t) (a a a a a)) (deftest fill.allow-other-keys.2 (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys nil) (a a a a a)) (deftest fill.allow-other-keys.3 (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys t :bad t) (a a a a a)) (deftest fill.allow-other-keys.4 (fill (list 'a 'b 'c 'd 'e) 'a :bad t :allow-other-keys t) (a a a a a)) (deftest fill.allow-other-keys.5 (fill (list 'a 'b 'c 'd 'e) 'a 'bad t :allow-other-keys t) (a a a a a)) (deftest fill.allow-other-keys.6 (fill (list 'a 'b 'c 'd 'e) 'a :bad t :allow-other-keys t :allow-other-keys nil) (a a a a a)) (deftest fill.allow-other-keys.7 (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys t :allow-other-keys nil :bad t) (a a a a a)) ;;; Tests of evaluation order (deftest fill.order.1 (let ((i 0) x y (a (copy-seq #(a a a a)))) (values (fill (progn (setf x (incf i)) a) (progn (setf y (incf i)) 'z)) i x y)) #(z z z z) 2 1 2) (deftest fill.order.2 (let ((i 0) x y z w (a (copy-seq #(a a a a)))) (values (fill (progn (setf x (incf i)) a) (progn (setf y (incf i)) 'z) :start (progn (setf z (incf i)) 1) :end (progn (setf w (incf i)) 3)) i x y z w)) #(a z z a) 4 1 2 3 4) (deftest fill.order.3 (let ((i 0) x y z w (a (copy-seq #(a a a a)))) (values (fill (progn (setf x (incf i)) a) (progn (setf y (incf i)) 'z) :end (progn (setf z (incf i)) 3) :start (progn (setf w (incf i)) 1)) i x y z w)) #(a z z a) 4 1 2 3 4) (deftest fill.order.4 (let ((i 0) x y z p q r s w (a (copy-seq #(a a a a)))) (values (fill (progn (setf x (incf i)) a) (progn (setf y (incf i)) 'z) :end (progn (setf z (incf i)) 3) :end (progn (setf p (incf i)) 1) :end (progn (setf q (incf i)) 1) :end (progn (setf r (incf i)) 1) :start (progn (setf s (incf i)) 1) :start (progn (setf w (incf i)) 0)) i x y z p q r s w)) #(a z z a) 8 1 2 3 4 5 6 7 8) gcl/ansi-tests/find-if-not.lsp000066400000000000000000000346521242227143400165620ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 28 20:53:24 2002 ;;;; Contains: Tests for FIND-IF-NOT (in-package :cl-test) (deftest find-if-not-list.1 (find-if-not #'identity ()) nil) (deftest find-if-not-list.2 (find-if-not #'null '(a)) a) (deftest find-if-not-list.2a (find-if-not 'null '(a)) a) (deftest find-if-not-list.3 (find-if-not #'oddp '(1 2 4 8 3 1 6 7)) 2) (deftest find-if-not-list.4 (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :from-end t) 6) (deftest find-if-not-list.5 (loop for i from 0 to 7 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i)) (2 2 4 8 6 6 6 nil)) (deftest find-if-not-list.6 (loop for i from 0 to 7 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil)) (2 2 4 8 6 6 6 nil)) (deftest find-if-not-list.7 (loop for i from 0 to 7 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-not-list.8 (loop for i from 0 to 7 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-not-list.9 (loop for i from 0 to 8 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i)) (nil nil 2 2 2 2 2 2 2)) (deftest find-if-not-list.10 (loop for i from 0 to 8 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i :from-end t)) (nil nil 2 4 8 8 8 6 6)) (deftest find-if-not-list.11 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-not-list.12 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i :from-end t))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-not-list.13 (loop for i from 0 to 6 collect (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :start i)) (1 11 11 45 45 71 nil)) (deftest find-if-not-list.14 (loop for i from 0 to 6 collect (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) (71 71 71 71 71 71 nil)) (deftest find-if-not-list.15 (loop for i from 0 to 7 collect (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :end i)) (nil 1 1 1 1 1 1 1)) (deftest find-if-not-list.16 (loop for i from 0 to 7 collect (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) (nil 1 1 11 11 45 71 71)) (deftest find-if-not-list.17 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-not-list.18 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i :from-end t :key #'1+))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) ;;; tests for vectors (deftest find-if-not-vector.1 (find-if-not #'identity #()) nil) (deftest find-if-not-vector.2 (find-if-not #'not #(a)) a) (deftest find-if-not-vector.2a (find-if-not 'null #(a)) a) (deftest find-if-not-vector.3 (find-if-not #'oddp #(1 2 4 8 3 1 6 7)) 2) (deftest find-if-not-vector.4 (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :from-end t) 6) (deftest find-if-not-vector.5 (loop for i from 0 to 7 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i)) (2 2 4 8 6 6 6 nil)) (deftest find-if-not-vector.6 (loop for i from 0 to 7 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil)) (2 2 4 8 6 6 6 nil)) (deftest find-if-not-vector.7 (loop for i from 0 to 7 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-not-vector.8 (loop for i from 0 to 7 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-not-vector.9 (loop for i from 0 to 8 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i)) (nil nil 2 2 2 2 2 2 2)) (deftest find-if-not-vector.10 (loop for i from 0 to 8 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i :from-end t)) (nil nil 2 4 8 8 8 6 6)) (deftest find-if-not-vector.11 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-not-vector.12 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i :from-end t))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-not-vector.13 (loop for i from 0 to 6 collect (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :start i)) (1 11 11 45 45 71 nil)) (deftest find-if-not-vector.14 (loop for i from 0 to 6 collect (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) (71 71 71 71 71 71 nil)) (deftest find-if-not-vector.15 (loop for i from 0 to 7 collect (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :end i)) (nil 1 1 1 1 1 1 1)) (deftest find-if-not-vector.16 (loop for i from 0 to 7 collect (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) (nil 1 1 11 11 45 71 71)) (deftest find-if-not-vector.17 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-not-vector.18 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i :from-end t :key #'1+))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) ;;; Tests for bit vectors (deftest find-if-not-bit-vector.1 (find-if-not #'identity #*) nil) (deftest find-if-not-bit-vector.2 (find-if-not #'null #*1) 1) (deftest find-if-not-bit-vector.3 (find-if-not #'not #*0) 0) (deftest find-if-not-bit-vector.4 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if-not #'oddp #*0110110 :start i :end j))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) (deftest find-if-not-bit-vector.5 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if-not #'oddp #*0110110 :start i :end j :from-end t))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) (deftest find-if-not-bit-vector.6 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if-not #'evenp #*0110110 :start i :end j :from-end t :key #'1+))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) (deftest find-if-not-bit-vector.7 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if-not #'evenp #*0110110 :start i :end j :key '1-))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) ;;; Tests for strings (deftest find-if-not-string.1 (find-if-not #'identity "") nil) (deftest find-if-not-string.2 (find-if-not #'null "a") #\a) (deftest find-if-not-string.2a (find-if-not 'null "a") #\a) (deftest find-if-not-string.3 (find-if-not #'odddigitp "12483167") #\2) (deftest find-if-not-string.3a (find-if-not #'oddp "12483167" :key #'(lambda (c) (read-from-string (string c)))) #\2) (deftest find-if-not-string.4 (find-if-not #'odddigitp "12483167" :from-end t) #\6) (deftest find-if-not-string.5 (loop for i from 0 to 7 collect (find-if-not #'odddigitp "12483167" :start i)) (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) (deftest find-if-not-string.6 (loop for i from 0 to 7 collect (find-if-not #'odddigitp "12483167" :start i :end nil)) (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) (deftest find-if-not-string.7 (loop for i from 0 to 7 collect (find-if-not #'odddigitp "12483167" :start i :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) (deftest find-if-not-string.8 (loop for i from 0 to 7 collect (find-if-not #'odddigitp "12483167" :start i :end nil :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) (deftest find-if-not-string.9 (loop for i from 0 to 8 collect (find-if-not #'odddigitp "12483167" :end i)) (nil nil #\2 #\2 #\2 #\2 #\2 #\2 #\2)) (deftest find-if-not-string.10 (loop for i from 0 to 8 collect (find-if-not #'odddigitp "12483167" :end i :from-end t)) (nil nil #\2 #\4 #\8 #\8 #\8 #\6 #\6)) (deftest find-if-not-string.11 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'odddigitp "12483167" :start j :end i))) ((nil #\2 #\2 #\2 #\2 #\2 #\2 #\2) (#\2 #\2 #\2 #\2 #\2 #\2 #\2) (#\4 #\4 #\4 #\4 #\4 #\4) (#\8 #\8 #\8 #\8 #\8) (nil nil #\6 #\6) (nil #\6 #\6) (#\6 #\6) (nil))) (deftest find-if-not-string.12 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'odddigitp "12483167" :start j :end i :from-end t))) ((nil #\2 #\4 #\8 #\8 #\8 #\6 #\6) (#\2 #\4 #\8 #\8 #\8 #\6 #\6) (#\4 #\8 #\8 #\8 #\6 #\6) (#\8 #\8 #\8 #\6 #\6) (nil nil #\6 #\6) (nil #\6 #\6) (#\6 #\6) (nil))) (deftest find-if-not-string.13 (loop for i from 0 to 6 collect (find-if-not #'oddp "1473816" :key (compose #'read-from-string #'string) :start i)) (#\4 #\4 #\8 #\8 #\8 #\6 #\6)) (deftest find-if-not-string.14 (loop for i from 0 to 6 collect (find-if-not #'oddp "1473816" :key (compose #'read-from-string #'string) :start i :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6)) (deftest find-if-not-string.15 (loop for i from 0 to 7 collect (find-if-not #'oddp "1473816" :key (compose #'read-from-string #'string) :end i)) (nil nil #\4 #\4 #\4 #\4 #\4 #\4)) (deftest find-if-not-string.16 (loop for i from 0 to 7 collect (find-if-not #'oddp "1473816" :key (compose #'read-from-string #'string) :end i :from-end t)) (nil nil #\4 #\4 #\4 #\8 #\8 #\6)) (deftest find-if-not-string.17 (loop for j from 0 to 6 collect (loop for i from (1+ j) to 7 collect (find-if-not #'oddp "1473816" :key (compose #'read-from-string #'string) :start j :end i))) ((nil #\4 #\4 #\4 #\4 #\4 #\4) (#\4 #\4 #\4 #\4 #\4 #\4) (nil nil #\8 #\8 #\8) (nil #\8 #\8 #\8) (#\8 #\8 #\8) (nil #\6) (#\6))) (deftest find-if-not-string.18 (loop for j from 0 to 6 collect (loop for i from (1+ j) to 7 collect (find-if-not #'oddp "1473816" :key (compose #'read-from-string #'string) :start j :end i :from-end t))) ((nil #\4 #\4 #\4 #\8 #\8 #\6) (#\4 #\4 #\4 #\8 #\8 #\6) (nil nil #\8 #\8 #\6) (nil #\8 #\8 #\6) (#\8 #\8 #\6) (nil #\6) (#\6))) ;;; Keyword tests (deftest find-if-not.allow-other-keys.1 (find-if-not #'oddp '(1 2 3 4 5) :bad t :allow-other-keys t) 2) (deftest find-if-not.allow-other-keys.2 (find-if-not #'oddp '(1 2 3 4 5) :allow-other-keys t :also-bad t) 2) ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest find-if-not.allow-other-keys.3 (find-if-not #'oddp '(1 2 3 4 5) :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest find-if-not.keywords.4 (find-if-not #'oddp '(1 2 3 4 5) :key #'identity :key #'1+) 2) (deftest find-if-not.allow-other-keys.5 (find-if-not #'null '(nil a b c nil) :allow-other-keys nil) a) ;;; Error tests (deftest find-if-not.error.1 (classify-error (find-if-not #'null 'b)) type-error) (deftest find-if-not.error.2 (classify-error (find-if-not #'identity 10)) type-error) (deftest find-if-not.error.3 (classify-error (find-if-not '1+ 1.4)) type-error) (deftest find-if-not.error.4 (classify-error (find-if-not 'identity '(a b c . d))) type-error) (deftest find-if-not.error.5 (classify-error (find-if-not)) program-error) (deftest find-if-not.error.6 (classify-error (find-if-not #'null)) program-error) (deftest find-if-not.error.7 (classify-error (find-if-not #'null nil :bad t)) program-error) (deftest find-if-not.error.8 (classify-error (find-if-not #'null nil :bad t :allow-other-keys nil)) program-error) (deftest find-if-not.error.9 (classify-error (find-if-not #'null nil 1 1)) program-error) (deftest find-if-not.error.10 (classify-error (find-if-not #'null nil :key)) program-error) (deftest find-if-not.error.11 (classify-error (locally (find-if-not #'null 'b) t)) type-error) (deftest find-if-not.error.12 (classify-error (find-if-not #'cons '(a b c))) program-error) (deftest find-if-not.error.13 (classify-error (find-if-not #'car '(a b c))) type-error) (deftest find-if-not.error.14 (classify-error (find-if-not #'identity '(a b c) :key #'cons)) program-error) (deftest find-if-not.error.15 (classify-error (find-if-not #'identity '(a b c) :key #'car)) type-error) ;;; Order of evaluation tests (deftest find-if-not.order.1 (let ((i 0) x y) (values (find-if-not (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '(nil nil nil a nil nil))) i x y)) a 2 1 2) (deftest find-if-not.order.2 (let ((i 0) a b c d e f g) (values (find-if-not (progn (setf a (incf i)) #'identity) (progn (setf b (incf i)) '(nil nil nil a nil nil)) :start (progn (setf c (incf i)) 1) :end (progn (setf d (incf i)) 4) :from-end (setf e (incf i)) :key (progn (setf f (incf i)) #'null) ) i a b c d e f)) a 6 1 2 3 4 5 6) (deftest find-if-not.order.3 (let ((i 0) a b c d e f g) (values (find-if-not (progn (setf a (incf i)) #'identity) (progn (setf b (incf i)) '(nil nil nil a nil nil)) :key (progn (setf c (incf i)) #'null) :from-end (setf d (incf i)) :end (progn (setf e (incf i)) 4) :start (progn (setf f (incf i)) 1) ) i a b c d e f)) a 6 1 2 3 4 5 6) gcl/ansi-tests/find-if.lsp000066400000000000000000000346731242227143400157670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 28 18:37:52 2002 ;;;; Contains: Tests for FIND-IF (in-package :cl-test) (deftest find-if-list.1 (find-if #'identity ()) nil) (deftest find-if-list.2 (find-if #'identity '(a)) a) (deftest find-if-list.2a (find-if 'identity '(a)) a) (deftest find-if-list.3 (find-if #'evenp '(1 2 4 8 3 1 6 7)) 2) (deftest find-if-list.4 (find-if #'evenp '(1 2 4 8 3 1 6 7) :from-end t) 6) (deftest find-if-list.5 (loop for i from 0 to 7 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i)) (2 2 4 8 6 6 6 nil)) (deftest find-if-list.6 (loop for i from 0 to 7 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil)) (2 2 4 8 6 6 6 nil)) (deftest find-if-list.7 (loop for i from 0 to 7 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-list.8 (loop for i from 0 to 7 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-list.9 (loop for i from 0 to 8 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i)) (nil nil 2 2 2 2 2 2 2)) (deftest find-if-list.10 (loop for i from 0 to 8 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i :from-end t)) (nil nil 2 4 8 8 8 6 6)) (deftest find-if-list.11 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-list.12 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i :from-end t))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-list.13 (loop for i from 0 to 6 collect (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :start i)) (1 11 11 45 45 71 nil)) (deftest find-if-list.14 (loop for i from 0 to 6 collect (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) (71 71 71 71 71 71 nil)) (deftest find-if-list.15 (loop for i from 0 to 7 collect (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :end i)) (nil 1 1 1 1 1 1 1)) (deftest find-if-list.16 (loop for i from 0 to 7 collect (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) (nil 1 1 11 11 45 71 71)) (deftest find-if-list.17 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-list.18 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i :from-end t :key #'1+))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) ;;; tests for vectors (deftest find-if-vector.1 (find-if #'identity #()) nil) (deftest find-if-vector.2 (find-if #'identity #(a)) a) (deftest find-if-vector.2a (find-if 'identity #(a)) a) (deftest find-if-vector.3 (find-if #'evenp #(1 2 4 8 3 1 6 7)) 2) (deftest find-if-vector.4 (find-if #'evenp #(1 2 4 8 3 1 6 7) :from-end t) 6) (deftest find-if-vector.5 (loop for i from 0 to 7 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i)) (2 2 4 8 6 6 6 nil)) (deftest find-if-vector.6 (loop for i from 0 to 7 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil)) (2 2 4 8 6 6 6 nil)) (deftest find-if-vector.7 (loop for i from 0 to 7 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-vector.8 (loop for i from 0 to 7 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-vector.9 (loop for i from 0 to 8 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i)) (nil nil 2 2 2 2 2 2 2)) (deftest find-if-vector.10 (loop for i from 0 to 8 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i :from-end t)) (nil nil 2 4 8 8 8 6 6)) (deftest find-if-vector.11 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-vector.12 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i :from-end t))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-vector.13 (loop for i from 0 to 6 collect (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :start i)) (1 11 11 45 45 71 nil)) (deftest find-if-vector.14 (loop for i from 0 to 6 collect (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) (71 71 71 71 71 71 nil)) (deftest find-if-vector.15 (loop for i from 0 to 7 collect (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :end i)) (nil 1 1 1 1 1 1 1)) (deftest find-if-vector.16 (loop for i from 0 to 7 collect (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) (nil 1 1 11 11 45 71 71)) (deftest find-if-vector.17 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-vector.18 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i :from-end t :key #'1+))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-vector.19 (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 5))) (values (find-if #'evenp a) (find-if #'evenp a :from-end t) (find-if #'oddp a) (find-if #'oddp a :from-end t) )) 2 4 1 5) ;;; Tests for bit vectors (deftest find-if-bit-vector.1 (find-if #'identity #*) nil) (deftest find-if-bit-vector.2 (find-if #'identity #*1) 1) (deftest find-if-bit-vector.3 (find-if #'identity #*0) 0) (deftest find-if-bit-vector.4 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if #'evenp #*0110110 :start i :end j))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) (deftest find-if-bit-vector.5 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if #'evenp #*0110110 :start i :end j :from-end t))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) (deftest find-if-bit-vector.6 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if #'oddp #*0110110 :start i :end j :from-end t :key #'1+))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) (deftest find-if-bit-vector.7 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if #'oddp #*0110110 :start i :end j :key '1-))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) ;;; Tests for strings (deftest find-if-string.1 (find-if #'identity "") nil) (deftest find-if-string.2 (find-if #'identity "a") #\a) (deftest find-if-string.2a (find-if 'identity "a") #\a) (deftest find-if-string.3 (find-if #'evendigitp "12483167") #\2) (deftest find-if-string.3a (find-if #'evenp "12483167" :key #'(lambda (c) (read-from-string (string c)))) #\2) (deftest find-if-string.4 (find-if #'evendigitp "12483167" :from-end t) #\6) (deftest find-if-string.5 (loop for i from 0 to 7 collect (find-if #'evendigitp "12483167" :start i)) (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) (deftest find-if-string.6 (loop for i from 0 to 7 collect (find-if #'evendigitp "12483167" :start i :end nil)) (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) (deftest find-if-string.7 (loop for i from 0 to 7 collect (find-if #'evendigitp "12483167" :start i :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) (deftest find-if-string.8 (loop for i from 0 to 7 collect (find-if #'evendigitp "12483167" :start i :end nil :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) (deftest find-if-string.9 (loop for i from 0 to 8 collect (find-if #'evendigitp "12483167" :end i)) (nil nil #\2 #\2 #\2 #\2 #\2 #\2 #\2)) (deftest find-if-string.10 (loop for i from 0 to 8 collect (find-if #'evendigitp "12483167" :end i :from-end t)) (nil nil #\2 #\4 #\8 #\8 #\8 #\6 #\6)) (deftest find-if-string.11 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'evendigitp "12483167" :start j :end i))) ((nil #\2 #\2 #\2 #\2 #\2 #\2 #\2) (#\2 #\2 #\2 #\2 #\2 #\2 #\2) (#\4 #\4 #\4 #\4 #\4 #\4) (#\8 #\8 #\8 #\8 #\8) (nil nil #\6 #\6) (nil #\6 #\6) (#\6 #\6) (nil))) (deftest find-if-string.12 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'evendigitp "12483167" :start j :end i :from-end t))) ((nil #\2 #\4 #\8 #\8 #\8 #\6 #\6) (#\2 #\4 #\8 #\8 #\8 #\6 #\6) (#\4 #\8 #\8 #\8 #\6 #\6) (#\8 #\8 #\8 #\6 #\6) (nil nil #\6 #\6) (nil #\6 #\6) (#\6 #\6) (nil))) (deftest find-if-string.13 (loop for i from 0 to 6 collect (find-if #'evenp "1473816" :key (compose #'read-from-string #'string) :start i)) (#\4 #\4 #\8 #\8 #\8 #\6 #\6)) (deftest find-if-string.14 (loop for i from 0 to 6 collect (find-if #'evenp "1473816" :key (compose #'read-from-string #'string) :start i :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6)) (deftest find-if-string.15 (loop for i from 0 to 7 collect (find-if #'evenp "1473816" :key (compose #'read-from-string #'string) :end i)) (nil nil #\4 #\4 #\4 #\4 #\4 #\4)) (deftest find-if-string.16 (loop for i from 0 to 7 collect (find-if #'evenp "1473816" :key (compose #'read-from-string #'string) :end i :from-end t)) (nil nil #\4 #\4 #\4 #\8 #\8 #\6)) (deftest find-if-string.17 (loop for j from 0 to 6 collect (loop for i from (1+ j) to 7 collect (find-if #'evenp "1473816" :key (compose #'read-from-string #'string) :start j :end i))) ((nil #\4 #\4 #\4 #\4 #\4 #\4) (#\4 #\4 #\4 #\4 #\4 #\4) (nil nil #\8 #\8 #\8) (nil #\8 #\8 #\8) (#\8 #\8 #\8) (nil #\6) (#\6))) (deftest find-if-string.18 (loop for j from 0 to 6 collect (loop for i from (1+ j) to 7 collect (find-if #'evenp "1473816" :key (compose #'read-from-string #'string) :start j :end i :from-end t))) ((nil #\4 #\4 #\4 #\8 #\8 #\6) (#\4 #\4 #\4 #\8 #\8 #\6) (nil nil #\8 #\8 #\6) (nil #\8 #\8 #\6) (#\8 #\8 #\6) (nil #\6) (#\6))) (deftest find-if-string.19 (let ((a (make-array '(10) :initial-contents "123456789a" :fill-pointer 5 :element-type 'character))) (values (find-if #'evendigitp a) (find-if #'evendigitp a :from-end t) (find-if #'odddigitp a) (find-if #'odddigitp a :from-end t) )) #\2 #\4 #\1 #\5) ;;; Keyword tests (deftest find-if.allow-other-keys.1 (find-if #'evenp '(1 2 3 4 5) :bad t :allow-other-keys t) 2) (deftest find-if.allow-other-keys.2 (find-if #'evenp '(1 2 3 4 5) :allow-other-keys t :also-bad t) 2) ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest find-if.allow-other-keys.3 (find-if #'evenp '(1 2 3 4 5) :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest find-if.keywords.4 (find-if #'evenp '(1 2 3 4 5) :key #'identity :key #'1+) 2) (deftest find-if.allow-other-keys.5 (find-if #'identity '(nil a b c nil) :allow-other-keys nil) a) ;;; Error tests (deftest find-if.error.1 (classify-error (find-if #'null 'b)) type-error) (deftest find-if.error.2 (classify-error (find-if #'identity 10)) type-error) (deftest find-if.error.3 (classify-error (find-if '1+ 1.4)) type-error) (deftest find-if.error.4 (classify-error (find-if 'null '(a b c . d))) type-error) (deftest find-if.error.5 (classify-error (find-if)) program-error) (deftest find-if.error.6 (classify-error (find-if #'null)) program-error) (deftest find-if.error.7 (classify-error (find-if #'null nil :bad t)) program-error) (deftest find-if.error.8 (classify-error (find-if #'null nil :bad t :allow-other-keys nil)) program-error) (deftest find-if.error.9 (classify-error (find-if #'null nil 1 1)) program-error) (deftest find-if.error.10 (classify-error (find-if #'null nil :key)) program-error) (deftest find-if.error.11 (classify-error (locally (find-if #'null 'b) t)) type-error) (deftest find-if.error.12 (classify-error (find-if #'cons '(a b c))) program-error) (deftest find-if.error.13 (classify-error (find-if #'car '(a b c))) type-error) (deftest find-if.error.14 (classify-error (find-if #'identity '(a b c) :key #'cons)) program-error) (deftest find-if.error.15 (classify-error (find-if #'identity '(a b c) :key #'car)) type-error) ;;; Order of evaluation tests (deftest find-if.order.1 (let ((i 0) x y) (values (find-if (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '(nil nil nil a nil nil))) i x y)) a 2 1 2) (deftest find-if.order.2 (let ((i 0) a b c d e f g) (values (find-if (progn (setf a (incf i)) #'null) (progn (setf b (incf i)) '(nil nil nil a nil nil)) :start (progn (setf c (incf i)) 1) :end (progn (setf d (incf i)) 4) :from-end (setf e (incf i)) :key (progn (setf f (incf i)) #'null) ) i a b c d e f)) a 6 1 2 3 4 5 6) (deftest find-if.order.3 (let ((i 0) a b c d e f g) (values (find-if (progn (setf a (incf i)) #'null) (progn (setf b (incf i)) '(nil nil nil a nil nil)) :key (progn (setf c (incf i)) #'null) :from-end (setf d (incf i)) :end (progn (setf e (incf i)) 4) :start (progn (setf f (incf i)) 1) ) i a b c d e f)) a 6 1 2 3 4 5 6) gcl/ansi-tests/find.lsp000066400000000000000000000440661242227143400153700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Aug 23 07:49:49 2002 ;;;; Contains: Tests for FIND (in-package :cl-test) (deftest find-list.1 (find 'c '(a b c d e c a)) c) (deftest find-list.2 (find 'c '(a b c d e c a) :from-end t) c) (deftest find-list.3 (loop for i from 0 to 7 collect (find 'c '(a b c d e c a) :start i)) (c c c c c c nil nil)) (deftest find-list.4 (loop for i from 0 to 7 collect (find 'c '(a b c d e c a) :start i :end nil)) (c c c c c c nil nil)) (deftest find-list.5 (loop for i from 7 downto 0 collect (find 'c '(a b c d e c a) :end i)) (c c c c c nil nil nil)) (deftest find-list.6 (loop for i from 0 to 7 collect (find 'c '(a b c d e c a) :start i :from-end t)) (c c c c c c nil nil)) (deftest find-list.7 (loop for i from 0 to 7 collect (find 'c '(a b c d e c a) :start i :end nil :from-end t)) (c c c c c c nil nil)) (deftest find-list.8 (loop for i from 7 downto 0 collect (find 'c '(a b c d e c a) :end i :from-end t)) (c c c c c nil nil nil)) (deftest find-list.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find 'c '(a b c d e c a) :start i :end j))) ((nil nil c c c c c) (nil c c c c c) (c c c c c) (nil nil c c) (nil c c) (c c) (nil))) (deftest find-list.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find 'c '(a b c d e c a) :start i :end j :from-end t))) ((nil nil c c c c c) (nil c c c c c) (c c c c c) (nil nil c c) (nil c c) (c c) (nil))) (deftest find-list.11 (find 5 '(1 2 3 4 5 6 4 8) :key #'1+) 4) (deftest find-list.12 (find 5 '(1 2 3 4 5 6 4 8) :key '1+) 4) (deftest find-list.13 (find 5 '(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) 4) (deftest find-list.14 (find 'a '(a a b a c e d a f a) :test (complement #'eql)) b) (deftest find-list.15 (find 'a '(a a b a c e d a f a) :test (complement #'eql) :from-end t) f) (deftest find-list.16 (find 'a '(a a b a c e d a f a) :test-not #'eql) b) (deftest find-list.17 (find 'a '(a a b a c e d a f a) :test-not 'eql :from-end t) f) (deftest find-list.18 (find 'a '(a a b a c e d a f a) :test-not 'eql) b) (deftest find-list.19 (find 'a '(a a b a c e d a f a) :test-not #'eql :from-end t) f) (deftest find-list.20 (find 'a '(a a b a c e d a f a) :test-not #'eql) b) (deftest find-list.21 (find 'a '(a a b a c e d a f a) :test #'eql :start 2) a) (deftest find-list.22 (find 'a '(a a b a c e d a f a) :test #'eql :start 2 :end nil) a) (deftest find-list.23 (find 'a '(a a b a c e d a f a) :test-not #'eql :start 0 :end 5) b) (deftest find-list.24 (find 'a '(a a b a c e d a f a) :test-not #'eql :start 0 :end 5 :from-end t) c) (deftest find-list.25 (find "ab" '("a" #(#\b #\a) #(#\a #\b #\c) #(#\a #\b) #(#\d #\e) f) :test #'equalp) #(#\a #\b)) (deftest find-list.26 (find 'a '((c) (b a) (a b c) (a b) (d e) f) :key #'car) (a b c)) (deftest find-list.27 (find 'a '((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car :start 3) (a b)) (deftest find-list.28 (find 'a '((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car :start 2 :from-end t) (a b)) ;;; Tests on vectors (deftest find-vector.1 (find 'c #(a b c d e c a)) c) (deftest find-vector.1a (find 'z #(a b c d e c a)) nil) (deftest find-vector.2 (find 'c #(a b c d e c a) :from-end t) c) (deftest find-vector.2a (find 'z #(a b c d e c a) :from-end t) nil) (deftest find-vector.3 (loop for i from 0 to 7 collect (find 'c #(a b c d e c a) :start i)) (c c c c c c nil nil)) (deftest find-vector.4 (loop for i from 0 to 7 collect (find 'c #(a b c d e c a) :start i :end nil)) (c c c c c c nil nil)) (deftest find-vector.5 (loop for i from 7 downto 0 collect (find 'c #(a b c d e c a) :end i)) (c c c c c nil nil nil)) (deftest find-vector.6 (loop for i from 0 to 7 collect (find 'c #(a b c d e c a) :start i :from-end t)) (c c c c c c nil nil)) (deftest find-vector.7 (loop for i from 0 to 7 collect (find 'c #(a b c d e c a) :start i :end nil :from-end t)) (c c c c c c nil nil)) (deftest find-vector.8 (loop for i from 7 downto 0 collect (find 'c #(a b c d e c a) :end i :from-end t)) (c c c c c nil nil nil)) (deftest find-vector.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find 'c #(a b c d e c a) :start i :end j))) ((nil nil c c c c c) (nil c c c c c) (c c c c c) (nil nil c c) (nil c c) (c c) (nil))) (deftest find-vector.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find 'c #(a b c d e c a) :start i :end j :from-end t))) ((nil nil c c c c c) (nil c c c c c) (c c c c c) (nil nil c c) (nil c c) (c c) (nil))) (deftest find-vector.11 (find 5 #(1 2 3 4 5 6 4 8) :key #'1+) 4) (deftest find-vector.12 (find 5 #(1 2 3 4 5 6 4 8) :key '1+) 4) (deftest find-vector.13 (find 5 #(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) 4) (deftest find-vector.14 (find 'a #(a a b a c e d a f a) :test (complement #'eql)) b) (deftest find-vector.15 (find 'a #(a a b a c e d a f a) :test (complement #'eql) :from-end t) f) (deftest find-vector.16 (find 'a #(a a b a c e d a f a) :test-not #'eql) b) (deftest find-vector.17 (find 'a #(a a b a c e d a f a) :test-not 'eql :from-end t) f) (deftest find-vector.18 (find 'a #(a a b a c e d a f a) :test-not 'eql) b) (deftest find-vector.19 (find 'a #(a a b a c e d a f a) :test-not #'eql :from-end t) f) (deftest find-vector.20 (find 'a #(a a b a c e d a f a) :test-not #'eql) b) (deftest find-vector.21 (find 'a #(a a b a c e d a f a) :test #'eql :start 2) a) (deftest find-vector.22 (find 'a #(a a b a c e d a f a) :test #'eql :start 2 :end nil) a) (deftest find-vector.23 (find 'a #(a a b a c e d a f a) :test-not #'eql :start 0 :end 5) b) (deftest find-vector.24 (find 'a #(a a b a c e d a f a) :test-not #'eql :start 0 :end 5 :from-end t) c) (deftest find-vector.25 (find "ab" #("a" #(#\b #\a) #(#\a #\b #\c) #(#\a #\b) #(#\d #\e) f) :test #'equalp) #(#\a #\b)) (deftest find-vector.26 (find 'a #((c) (b a) (a b c) (a b) (d e) f) :key #'car) (a b c)) (deftest find-vector.27 (find 'a #((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car :start 3) (a b)) (deftest find-vector.28 (find 'a #((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car :start 2 :from-end t) (a b)) (deftest find-vector.29 (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 5))) (loop for i from 1 to 10 collect (find i a))) (1 2 3 4 5 nil nil nil nil nil)) (deftest find-vector.30 (let ((a (make-array '(10) :initial-contents (loop for i from 1 for e in '(1 2 3 4 5 5 4 3 2 1) collect (list e i)) :fill-pointer 5))) (loop for i from 1 to 5 collect (find i a :from-end t :key #'car))) ((1 1) (2 2) (3 3) (4 4) (5 5))) ;;; tests on bit vectors (deftest find-bit-vector.1 (find 1 #*001001010100) 1) (deftest find-bit-vector.1a (find 0 #*001001010100) 0) (deftest find-bit-vector.1b (find 2 #*001001010100) nil) (deftest find-bit-vector.1c (find 'a #*001001010100) nil) (deftest find-bit-vector.1d (find 1 #*000000) nil) (deftest find-bit-vector.2 (find 1 #*001001010100 :from-end t) 1) (deftest find-bit-vector.2a (find 1 #*00000 :from-end t) nil) (deftest find-bit-vector.2b (find 0 #*00000 :from-end t) 0) (deftest find-bit-vector.2c (find 0 #*11111 :from-end t) nil) (deftest find-bit-vector.2d (find 2 #*11111 :from-end t) nil) (deftest find-bit-vector.2e (find 'a #*11111 :from-end t) nil) (deftest find-bit-vector.3 (loop for i from 0 to 7 collect (find 1 #*0010010 :start i)) (1 1 1 1 1 1 nil nil)) (deftest find-bit-vector.4 (loop for i from 0 to 7 collect (find 1 #*0010010 :start i :end nil)) (1 1 1 1 1 1 nil nil)) (deftest find-bit-vector.5 (loop for i from 7 downto 0 collect (find 1 #*0010010 :end i)) (1 1 1 1 1 nil nil nil)) (deftest find-bit-vector.6 (loop for i from 0 to 7 collect (find 1 #*0010010 :start i :from-end t)) (1 1 1 1 1 1 nil nil)) (deftest find-bit-vector.7 (loop for i from 0 to 7 collect (find 0 #*1101101 :start i :end nil :from-end t)) (0 0 0 0 0 0 nil nil)) (deftest find-bit-vector.8 (loop for i from 7 downto 0 collect (find 0 #*1101101 :end i :from-end t)) (0 0 0 0 0 nil nil nil)) (deftest find-bit-vector.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find 1 #*0010010 :start i :end j))) ((nil nil 1 1 1 1 1) (nil 1 1 1 1 1) (1 1 1 1 1) (nil nil 1 1) (nil 1 1) (1 1) (nil))) (deftest find-bit-vector.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find 1 #*0010010 :start i :end j :from-end t))) ((nil nil 1 1 1 1 1) (nil 1 1 1 1 1) (1 1 1 1 1) (nil nil 1 1) (nil 1 1) (1 1) (nil))) (deftest find-bit-vector.11 (find 2 #*00010001010 :key #'1+) 1) (deftest find-bit-vector.12 (find 2 #*00010001010 :key '1+) 1) (deftest find-bit-vector.13 (find 2 #*0010001000 :key #'1+ :from-end t) 1) (deftest find-bit-vector.14 (find 0 #*0010111010 :test (complement #'eql)) 1) (deftest find-bit-vector.15 (find 0 #*0010111010 :test (complement #'eql) :from-end t) 1) (deftest find-bit-vector.16 (find 0 #*0010111010 :test-not #'eql) 1) (deftest find-bit-vector.16a (find 1 #*111111111111 :test-not #'eql) nil) (deftest find-bit-vector.16b (find 0 #*0000000 :test-not #'eql) nil) (deftest find-bit-vector.17 (find 0 #*001011101 :test-not 'eql :from-end t) 1) (deftest find-bit-vector.17a (find 0 #*0000000 :test-not 'eql :from-end t) nil) (deftest find-bit-vector.17b (find 1 #*111111111111 :test-not 'eql :from-end t) nil) (deftest find-bit-vector.18 (find 0 #*00101110 :test-not 'eql) 1) (deftest find-bit-vector.18a (find 0 #*00000000 :test-not 'eql) nil) (deftest find-bit-vector.19 (find 0 #*00101110 :test-not #'eql :from-end t) 1) (deftest find-bit-vector.19a (find 0 #*00000000 :test-not #'eql :from-end t) nil) (deftest find-bit-vector.20 (find 0 #*00101110 :test-not #'eql) 1) (deftest find-bit-vector.21 (find 0 #*00101110 :test #'eql :start 2) 0) (deftest find-bit-vector.21a (find 0 #*00111111 :test #'eql :start 2) nil) (deftest find-bit-vector.21b (find 1 #*00111111 :test #'eql :start 2) 1) (deftest find-bit-vector.22 (find 0 #*00101110 :test #'eql :start 2 :end nil) 0) (deftest find-bit-vector.22a (find 0 #*001111111 :test #'eql :start 2 :end nil) nil) (deftest find-bit-vector.22b (find 1 #*001111111 :test #'eql :start 2 :end nil) 1) (deftest find-bit-vector.23 (find 0 #*00101110 :test-not #'eql :start 0 :end 5) 1) (deftest find-bit-vector.23a (find 0 #*00000111 :test-not #'eql :start 0 :end 5) nil) (deftest find-bit-vector.23b (find 0 #*00001000 :test-not #'eql :start 0 :end 5) 1) (deftest find-bit-vector.24 (find 0 #*00101110 :test-not #'eql :start 0 :end 5 :from-end t) 1) (deftest find-bit-vector.24a (find 0 #*0000001111 :test-not #'eql :start 0 :end 5 :from-end t) nil) (deftest find-bit-vector.24b (find 0 #*0000100 :test-not #'eql :start 0 :end 5 :from-end t) 1) (deftest find-bit-vector.25 (find 2 #*1100001010 :key #'1+ :start 3) 1) (deftest find-bit-vector.26 (find 2 #*11100000 :key #'1+ :start 3) nil) (deftest find-bit-vector.26a (find 2 #*11110000 :key #'1+ :start 3) 1) (deftest find-bit-vector.27 (find 2 #*1100001010 :key #'1+ :start 2 :from-end t) 1) (deftest find-bit-vector.28 (find 2 #*1100000000 :key #'1+ :start 2 :from-end t) nil) (deftest find-bit-vector.29 (let ((a (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) :element-type 'bit :fill-pointer 5))) (values (find 0 a) (find 0 a :from-end t))) nil nil) (deftest find-bit-vector.30 (let ((a (make-array '(10) :initial-contents '(1 1 1 1 0 0 0 0 0 0) :element-type 'bit :fill-pointer 5))) (values (find 0 a) (find 0 a :from-end t))) 0 0) ;;; strings (deftest find-string.1 (find #\c "abcdeca") #\c) (deftest find-string.1a (find #\c "abCa") nil) (deftest find-string.2 (find #\c "abcdeca" :from-end t) #\c) (deftest find-string.2a (find #\c "abCCCa" :from-end t) nil) (deftest find-string.3 (loop for i from 0 to 7 collect (find #\c "abcdeca" :start i)) (#\c #\c #\c #\c #\c #\c nil nil)) (deftest find-string.4 (loop for i from 0 to 7 collect (find #\c "abcdeca" :start i :end nil)) (#\c #\c #\c #\c #\c #\c nil nil)) (deftest find-string.5 (loop for i from 7 downto 0 collect (find #\c "abcdeca" :end i)) (#\c #\c #\c #\c #\c nil nil nil)) (deftest find-string.6 (loop for i from 0 to 7 collect (find #\c "abcdeca" :start i :from-end t)) (#\c #\c #\c #\c #\c #\c nil nil)) (deftest find-string.7 (loop for i from 0 to 7 collect (find #\c "abcdeca" :start i :end nil :from-end t)) (#\c #\c #\c #\c #\c #\c nil nil)) (deftest find-string.8 (loop for i from 7 downto 0 collect (find #\c "abcdeca" :end i :from-end t)) (#\c #\c #\c #\c #\c nil nil nil)) (deftest find-string.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find #\c "abcdeca" :start i :end j))) ((nil nil #\c #\c #\c #\c #\c) (nil #\c #\c #\c #\c #\c) (#\c #\c #\c #\c #\c) (nil nil #\c #\c) (nil #\c #\c) (#\c #\c) (nil))) (deftest find-string.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find #\c "abcdeca" :start i :end j :from-end t))) ((nil nil #\c #\c #\c #\c #\c) (nil #\c #\c #\c #\c #\c) (#\c #\c #\c #\c #\c) (nil nil #\c #\c) (nil #\c #\c) (#\c #\c) (nil))) (deftest find-string.11 (find 5 "12345648" :key #'(lambda (c) (1+ (read-from-string (string c))))) #\4) (deftest find-string.13 (find 5 "12345648" :key #'(lambda (c) (1+ (read-from-string (string c)))) :from-end t) #\4) (deftest find-string.14 (find #\a "aabacedafa" :test (complement #'eql)) #\b) (deftest find-string.15 (find #\a "aabacedafa" :test (complement #'eql) :from-end t) #\f) (deftest find-string.16 (find #\a "aabacedafa" :test-not #'eql) #\b) (deftest find-string.17 (find #\a "aabacedafa" :test-not 'eql :from-end t) #\f) (deftest find-string.18 (find #\a "aabacedafa" :test-not 'eql) #\b) (deftest find-string.19 (find #\a "aabacedafa" :test-not #'eql :from-end t) #\f) (deftest find-string.20 (find #\a "aabacedafa" :test-not #'eql) #\b) (deftest find-string.21 (find #\a "aabAcedafa" :test #'char-equal :start 2) #\A) (deftest find-string.22 (find #\a "aabAcedafa" :test #'char-equal :start 2 :end nil) #\A) (deftest find-string.23 (find #\a "aAbAcedafa" :test-not #'char-equal :start 0 :end 5) #\b) (deftest find-string.24 (find #\a "aabacedafa" :test-not #'char-equal :start 0 :end 5 :from-end t) #\c) (deftest find-string.25 (let ((s (make-array '(10) :initial-contents "abcdefghij" :element-type 'character :fill-pointer 5))) (values (loop for e across "abcdefghij" collect (find e s)) (loop for e across "abcdefghij" collect (find e s :from-end t)))) (#\a #\b #\c #\d #\e nil nil nil nil nil) (#\a #\b #\c #\d #\e nil nil nil nil nil)) ;;; Keyword tests (deftest find.allow-other-keys.1 (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) :bad t :allow-other-keys t) 2) (deftest find.allow-other-keys.2 (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) :allow-other-keys t :also-bad t) 2) ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest find.allow-other-keys.3 (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest find.keywords.4 (find 2 '(1 2 3 4 5) :key #'identity :key #'1+) 2) (deftest find.allow-other-keys.5 (find 'b '(nil a b c nil) :allow-other-keys nil) b) ;;; Error tests (deftest find.error.1 (classify-error (find 'a 'b)) type-error) (deftest find.error.2 (classify-error (find 'a 10)) type-error) (deftest find.error.3 (classify-error (find 'a 1.4)) type-error) (deftest find.error.4 (classify-error (find 'e '(a b c . d))) type-error) (deftest find.error.5 (classify-error (find)) program-error) (deftest find.error.6 (classify-error (find 'a)) program-error) (deftest find.error.7 (classify-error (find 'a nil :bad t)) program-error) (deftest find.error.8 (classify-error (find 'a nil :bad t :allow-other-keys nil)) program-error) (deftest find.error.9 (classify-error (find 'a nil 1 1)) program-error) (deftest find.error.10 (classify-error (find 'a nil :key)) program-error) (deftest find.error.11 (classify-error (locally (find 'a 'b) t)) type-error) (deftest find.error.12 (classify-error (find 'b '(a b c) :test #'identity)) program-error) (deftest find.error.13 (classify-error (find 'b '(a b c) :test-not #'identity)) program-error) (deftest find.error.14 (classify-error (find 'c '(a b c) :key #'cons)) program-error) (deftest find.error.15 (classify-error (find 'c '(a b c) :key #'car)) type-error) ;;; Order of evaluation tests (deftest find.order.1 (let ((i 0) x y) (values (find (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) '(nil nil nil a nil nil))) i x y)) a 2 1 2) (deftest find.order.2 (let ((i 0) a b c d e f g) (values (find (progn (setf a (incf i)) nil) (progn (setf b (incf i)) '(nil nil nil a nil nil)) :start (progn (setf c (incf i)) 1) :end (progn (setf d (incf i)) 4) :from-end (setf e (incf i)) :key (progn (setf f (incf i)) #'null) ) i a b c d e f)) a 6 1 2 3 4 5 6) (deftest find.order.3 (let ((i 0) a b c d e f g) (values (find (progn (setf a (incf i)) nil) (progn (setf b (incf i)) '(nil nil nil a nil nil)) :key (progn (setf c (incf i)) #'null) :from-end (setf d (incf i)) :end (progn (setf e (incf i)) 4) :start (progn (setf f (incf i)) 1) ) i a b c d e f)) a 6 1 2 3 4 5 6) gcl/ansi-tests/flet.lsp000066400000000000000000000257401242227143400154000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Oct 8 22:55:02 2002 ;;;; Contains: Tests of FLET (in-package :cl-test) (deftest flet.1 (flet ((%f () 1)) (%f)) 1) (deftest flet.2 (flet ((%f (x) x)) (%f 2)) 2) (deftest flet.3 (flet ((%f (&rest args) args)) (%f 'a 'b 'c)) (a b c)) ;;; The optional arguments are not in the block defined by ;;; the local function declaration (deftest flet.4 (block %f (flet ((%f (&optional (x (return-from %f 10))) 20)) (%f))) 10) (deftest flet.5 (flet ((%f () (return-from %f 15) 35)) (%f)) 15) ;;; The aux parameters are not in the block defined by ;;; the local function declaration (deftest flet.6 (block %f (flet ((%f (&aux (x (return-from %f 10))) 20)) (%f))) 10) ;;; The function is not visible inside itself (deftest flet.7 (flet ((%f (x) (+ x 5))) (flet ((%f (y) (cond ((eql y 20) 30) (t (%f 20))))) (%f 15))) 25) ;;; Keyword arguments (deftest flet.8 (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f)) nil 0 nil) (deftest flet.9 (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a 1)) 1 0 nil) (deftest flet.10 (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :b 2)) nil 2 t) (deftest flet.11 (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :b 2 :a 3)) 3 2 t) ;;; Unknown keyword parameter should throw a program-error in safe code ;;; (section 3.5.1.4) (deftest flet.12 (classify-error (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4))) program-error) ;;; Odd # of keyword args should throw a program-error in safe code ;;; (section 3.5.1.6) (deftest flet.13 (classify-error (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a))) program-error) ;;; Too few arguments (section 3.5.1.2) (deftest flet.14 (classify-error (flet ((%f (a) a)) (%f))) program-error) ;;; Too many arguments (section 3.5.1.3) (deftest flet.15 (classify-error (flet ((%f (a) a)) (%f 1 2))) program-error) ;;; Invalid keyword argument (section 3.5.1.5) (deftest flet.16 (classify-error (flet ((%f (&key a) a)) (%f '(foo)))) program-error) ;;; Definition of a (setf ...) function (deftest flet.17 (flet (((setf %f) (x y) (setf (car y) x))) (let ((z (list 1 2))) (setf (%f z) 'a) z)) (a 2)) ;;; Body is an implicit progn (deftest flet.18 (flet ((%f (x) (incf x) (+ x x))) (%f 10)) 22) ;;; Can handle at least 50 lambda parameters (deftest flet.19 (flet ((%f (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) (%f 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50)) 1275) ;;; flet works with a large (maximal?) number of arguments (deftest flet.20 (let* ((n (min lambda-parameters-limit 1024)) (vars (loop for i from 1 to n collect (gensym)))) (eval `(eql ,n (flet ((%f ,vars (+ ,@ vars))) (%f ,@(loop for e in vars collect 1)))))) t) ;;; Declarations and documentation strings are ok (deftest flet.21 (flet ((%f (x) (declare (type fixnum x)) "Add one to the fixnum x." (1+ x))) (declare (ftype (function (fixnum) integer) %f)) (%f 10)) 11) (deftest flet.22 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p)) (list x y (not (not y-p)) z (not (not z-p))))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c))) (10 1 nil 2 nil) (20 40 t 2 nil) (a b t c t)) (deftest flet.23 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r) (list x y (not (not y-p)) z (not (not z-p)) r))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f 'g 'h))) (10 1 nil 2 nil nil) (20 40 t 2 nil nil) (a b t c t nil) (d e t f t (g h))) (deftest flet.24 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f :foo 'h) (%f 'd 'e 'f :bar 'i) )) (10 1 nil 2 nil nil nil nil) (20 40 t 2 nil nil nil nil) (a b t c t nil nil nil) (d e t f t (:foo h) h nil) (d e t f t (:bar i) nil i)) (deftest flet.25 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar &allow-other-keys) (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f :foo 'h :whatever nil) (%f 'd 'e 'f :bar 'i :illegal t :foo 'z) )) (10 1 nil 2 nil nil nil nil) (20 40 t 2 nil nil nil nil) (a b t c t nil nil nil) (d e t f t (:foo h :whatever nil) h nil) (d e t f t (:bar i :illegal t :foo z) z i)) (deftest flet.26 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys t) (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys t) )) (10 1 nil 2 nil nil nil nil) (20 40 t 2 nil nil nil nil) (a b t c t nil nil nil) (d e t f t (:foo h :whatever nil :allow-other-keys t) h nil) (d e t f t (:bar i :illegal t :foo z :allow-other-keys t) z i)) ;;; Section 3.4.1.4.1: "The :allow-other-keys argument is permissible ;;; in all situations involving keyword[2] arguments, even when its ;;; associated value is false." (deftest flet.27 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f :foo 'h :allow-other-keys nil) (%f 'd 'e 'f :bar 'i :allow-other-keys nil) )) (10 1 nil 2 nil nil nil nil) (20 40 t 2 nil nil nil nil) (a b t c t nil nil nil) (d e t f t (:foo h :allow-other-keys nil) h nil) (d e t f t (:bar i :allow-other-keys nil) nil i)) (deftest flet.28 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar allow-other-keys) (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys 100) (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys 200) )) (10 1 nil 2 nil nil nil nil nil) (20 40 t 2 nil nil nil nil nil) (a b t c t nil nil nil nil) (d e t f t 100 (:foo h :whatever nil :allow-other-keys 100) h nil) (d e t f t 200 (:bar i :illegal t :foo z :allow-other-keys 200) z i)) (deftest flet.29 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar allow-other-keys &allow-other-keys) (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys nil :blah t) (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys nil :zzz 10) )) (10 1 nil 2 nil nil nil nil nil) (20 40 t 2 nil nil nil nil nil) (a b t c t nil nil nil nil) (d e t f t nil (:foo h :whatever nil :allow-other-keys nil :blah t) h nil) (d e t f t nil (:bar i :illegal t :foo z :allow-other-keys nil :zzz 10) z i)) ;;; Tests of non-keyword keywords (see section 3.4.1.4, paragrph 2). (deftest flet.30 (flet ((%f (&key ((foo bar) nil)) bar)) (values (%f) (%f 'foo 10))) nil 10) (deftest flet.31 (flet ((%f (&key ((:foo bar) nil)) bar)) (values (%f) (%f :foo 10))) nil 10) ;;; Multiple keyword actual parameters (deftest flet.32 (flet ((%f (&key a b c) (list a b c))) (%f :a 10 :b 20 :c 30 :a 40 :b 50 :c 60)) (10 20 30)) ;;; More aux parameters (deftest flet.33 (flet ((%f (x y &aux (a (1+ x)) (b (+ x y a)) (c (list x y a b))) c)) (%f 5 9)) (5 9 6 20)) (deftest flet.34 (flet ((%f (x y &rest r &key foo bar &aux (c (list x y r foo bar))) c)) (values (%f 1 2) (%f 1 2 :foo 'a) (%f 1 2 :bar 'b) (%f 1 2 :foo 'a :bar 'b) (%f 1 2 :bar 'b :foo 'a))) (1 2 nil nil nil) (1 2 (:foo a) a nil) (1 2 (:bar b) nil b) (1 2 (:foo a :bar b) a b) (1 2 (:bar b :foo a) a b)) ;;; Binding of formal parameters that are also special variables (deftest flet.35 (let ((x 'bad)) (declare (special x)) (flet ((%f () x)) (flet ((%g (x) (declare (special x)) (%f))) (%g 'good)))) good) (deftest flet.36 (let ((x 'bad)) (declare (special x)) (flet ((%f () x)) (flet ((%g (&aux (x 'good)) (declare (special x)) (%f))) (%g)))) good) (deftest flet.37 (let ((x 'bad)) (declare (special x)) (flet ((%f () x)) (flet ((%g (&rest x) (declare (special x)) (%f))) (%g 'good)))) (good)) (deftest flet.38 (let ((x 'bad)) (declare (special x)) (flet ((%f () x)) (flet ((%g (&key (x 'good)) (declare (special x)) (%f))) (%g)))) good) (deftest flet.39 (let ((x 'bad)) (declare (special x)) (flet ((%f () x)) (flet ((%g (&key (x 'bad)) (declare (special x)) (%f))) (%g :x 'good)))) good) (deftest flet.40 (let ((x 'good)) (declare (special x)) (flet ((%f () x)) (flet ((%g (&key (x 'bad)) (%f))) (%g :x 'worse)))) good) ;;; Test that [:&]allow-other-keys suppress errors for illegal keywords ;;; or odd numbers of keyword arguments ;;; Note -- These are apparently bad tests! -- PFD ;;;(deftest flet.41 ;;; (classify-error ;;; (flet ((%f (&key (a :good)) a)) ;;; (%f :allow-other-keys t :b))) ;;; :good) ;;; ;;;(deftest flet.42 ;;; (classify-error ;;; (flet ((%f (&key (a :good)) a)) ;;; (%f :allow-other-keys t 10 20))) ;;; :good) ;;; ;;;(deftest flet.43 ;;; (classify-error ;;; (flet ((%f (&key (a :good) &allow-other-keys) a)) ;;; (%f :b))) ;;; :good) ;;; ;;;(deftest flet.44 ;;; (classify-error ;;; (flet ((%f (&key (a :good) &allow-other-keys) a)) ;;; (%f 10 20))) ;;; :good) (deftest flet.45 (flet ((nil () 'a)) (nil)) a) (deftest flet.46 (flet ((t () 'b)) (t)) b) ;;; Keywords can be function names (deftest flet.47 (flet ((:foo () 'bar)) (:foo)) bar) (deftest flet.48 (flet ((:foo () 'bar)) (funcall #':foo)) bar) (deftest flet.49 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (flet ((,s () 'a)) (,s))) unless (eq (eval form) 'a) collect s) nil) (deftest flet.50 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (flet ((,s () 'a)) (declare (ftype (function () symbol) ,s)) (,s))) unless (eq (eval form) 'a) collect s) nil) ;;; Binding SETF functions of certain COMMON-LISP symbols (deftest flet.51 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (flet (((setf ,s) (&rest args) (declare (ignore args)) 'a)) (setf (,s) 10))) unless (eq (eval form) 'a) collect s) nil) gcl/ansi-tests/fmakunbound.lsp000066400000000000000000000026521242227143400167540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Oct 8 00:09:14 2002 ;;;; Contains: Tests for FMAKUNBOUND (in-package :cl-test) (deftest fmakunbound.1 (let ((g (gensym))) (and (not (fboundp g)) (setf (symbol-function g) #'car) (fboundp g) (values (eqt (check-values (fmakunbound g)) g) (fboundp g)))) t nil) (deftest fmakunbound.2 (let ((g (gensym))) (and (not (fboundp g)) (eval `(defun ,g () nil)) (fboundp g) (values (eqt (check-values (fmakunbound g)) g) (fboundp g)))) t nil) (deftest fmakunbound.3 (let ((g (gensym))) (and (not (fboundp g)) (eval `(defmacro ,g () nil)) (fboundp g) (values (eqt (check-values (fmakunbound g)) g) (fboundp g)))) t nil) (deftest fmakunbound.4 (let* ((g (gensym)) (n `(setf ,g))) (and (not (fboundp n)) (eval `(defun ,n () nil)) (fboundp n) (values (equal (check-values (fmakunbound n)) n) (fboundp n)))) t nil) (deftest fmakunbound.error.1 (classify-error (fmakunbound 1)) type-error) (deftest fmakunbound.error.2 (classify-error (fmakunbound #\a)) type-error) (deftest fmakunbound.error.3 (classify-error (fmakunbound '(x))) type-error) (deftest fmakunbound.error.4 (classify-error (fmakunbound)) program-error) (deftest fmakunbound.error.5 (classify-error (fmakunbound (gensym) nil)) program-error) (deftest fmakunbound.error.6 (classify-error (locally (fmakunbound 1) t)) type-error) gcl/ansi-tests/funcall.lsp000066400000000000000000000041361242227143400160660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Oct 9 21:45:07 2002 ;;;; Contains: Tests of FUNCALL (in-package :cl-test) (deftest funcall.1 (let ((fn #'cons)) (funcall fn 'a 'b)) (a . b)) (deftest funcall.2 (funcall (symbol-function 'cons) 'a 'b) (a . b)) (deftest funcall.3 (let ((fn 'cons)) (funcall fn 'a 'b)) (a . b)) (deftest funcall.4 (funcall 'cons 'a 'b) (a . b)) (deftest funcall.5 (let ((fn #'+)) (funcall fn 1 2 3 4)) 10) (deftest funcall.6 (funcall #'(lambda (x y) (cons x y)) 'a 'b) (a . b)) (defun xcons (x y) (cons x y)) (deftest funcall.7 (flet ((xcons (x y) (list y x))) (values (funcall 'xcons 1 2) (funcall #'xcons 1 2))) (1 . 2) (2 1)) (deftest funcall.8 (flet ((foo (x y z) (values x y z))) (funcall #'foo 1 2 3)) 1 2 3) (deftest funcall.9 (flet ((foo () (values))) (funcall #'foo)) ) (deftest funcall.order.1 (let ((i 0) a b) (values (funcall (progn (setf a (incf i)) #'car) (progn (setf b (incf i)) '(x . y))) i a b)) x 2 1 2) (deftest funcall.order.2 (let ((i 0) a b c) (values (funcall (progn (setf a (incf i)) #'cons) (progn (setf b (incf i)) 'x) (progn (setf c (incf i)) 'y)) i a b c)) (x . y) 3 1 2 3) ;;; FUNCALL should throw an UNDEFINED-FUNCTION condition when ;;; called on a symbol with a global definition as a special ;;; operator (deftest funcall.error.1 (classify-error (funcall 'quote 1)) undefined-function) (deftest funcall.error.2 (classify-error (funcall 'progn 1)) undefined-function) ;;; FUNCALL should throw an UNDEFINED-FUNCTION condition when ;;; called on a symbol with a global definition as a macro (deftest funcall.error.3 (classify-error (funcall 'defconstant '(defconstant x 10))) undefined-function) (deftest funcall.error.4 (classify-error (funcall)) program-error) (deftest funcall.error.5 (classify-error (funcall #'cons)) program-error) (deftest funcall.error.6 (classify-error (funcall #'cons 1)) program-error) (deftest funcall.error.7 (classify-error (funcall #'car 'a)) type-error) gcl/ansi-tests/function-lambda-expression.lsp000066400000000000000000000015711242227143400217020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 16:27:12 2003 ;;;; Contains: Tests for FUNCTION-LAMBDA-EXPRESSION (in-package :cl-test) (deftest function-lambda-expression.1 (length (multiple-value-list (function-lambda-expression #'cons))) 3) (deftest function-lambda-expression.2 (let ((x nil)) (flet ((%f () x)) (let ((ret-vals (multiple-value-list (function-lambda-expression #'%f)))) (values (length ret-vals) (notnot (second ret-vals)))))) 3 t) (deftest function-lambda-expression.order.1 (let ((i 0)) (function-lambda-expression (progn (incf i) #'cons)) i) 1) (deftest function-lambda-expression.error.1 (classify-error (function-lambda-expression)) program-error) (deftest function-lambda-expression.error.2 (classify-error (function-lambda-expression #'cons nil)) program-error) gcl/ansi-tests/function.lsp000066400000000000000000000046441242227143400162730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 7 07:34:29 2002 ;;;; Contains: Tests for type FUNCTION and the special form FUNCTION (in-package :cl-test) ;;; ;;; Note! There are significant incompatibilities between CLTL1 and ANSI CL ;;; in the meaning of FUNCTION and FUNCTIONP. ;;; (deftest function.1 (typep nil 'function) nil) ;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL. ;;; In ANSI CL, symbols are no longer of type FUNCTION. (deftest function.2 (typep 'identity 'function) nil) (deftest function.3 (not-mv (typep #'identity 'function)) nil) (deftest function.4 (loop for x in *cl-symbol-names* for s = (find-symbol x "CL") for f = (and (fboundp s) (symbol-function s) (not (special-operator-p s)) (not (macro-function s)) (symbol-function s)) unless (or (null f) (typep f 'function)) collect x) nil) (deftest function.5 (typep '(setf car) 'function) nil) ;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL. ;;; In ANSI CL, lambda forms are no longer of type FUNCTION. (deftest function.6 (typep '(lambda (x) x) 'function) nil) (eval-when (eval compile) (ignore-errors (defun (setf function-7-accessor) (y x) (setf (car x) y) y))) (deftest function.7 (not-mv (typep #'(setf function-7-accessor) 'function)) nil) (deftest function.8 (not-mv (typep #'(lambda (x) x) 'function)) nil) (deftest function.9 (not-mv (typep (compile nil '(lambda (x) x)) 'function)) nil) ;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL. ;;; In ANSI CL, symbols and cons can no longer also be of type FUNCTION. (deftest function.10 (loop for x in *universe* when (and (or (numberp x) (characterp x) (symbolp x) (consp x) (typep x 'array)) (typep x 'function)) collect x) nil) (deftest function.11 (flet ((%f () nil)) (typep '%f 'function)) nil) (deftest function.12 (flet ((%f () nil)) (not-mv (typep #'%f 'function))) nil) (deftest function.13 (labels ((%f () nil)) (not-mv (typep #'%f 'function))) nil) ;;; "If name is a function name, the functional definition of that ;;; name is that established by the innermost lexically enclosing flet, ;;; labels, or macrolet form, if there is one." (page for FUNCTION, sec. 5.3) ;;; ^^^^^^^^ ;;;(deftest function.14 ;;; (macrolet ((%f () nil)) (not-mv (typep #'%f 'function))) ;;; nil) gcl/ansi-tests/functionp.lsp000066400000000000000000000037571242227143400164570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 7 06:39:21 2002 ;;;; Contains: Tests for FUNCTIONP (in-package :cl-test) ;;; ;;; Note! FUNCTIONP and FUNCTION behave differently in ANSI CL than ;;; in CLTL1. In particular, symbols and various lists are no longer ;;; in the class FUNCTION in ANSI CL. ;;; (deftest functionp.1 (functionp nil) nil) ;;; In ANSI CL, symbols can no longer be functions (deftest functionp.2 (functionp 'identity) nil) (deftest functionp.3 (not (functionp #'identity)) nil) (deftest functionp.4 (loop for x in *cl-symbol-names* for s = (find-symbol x "CL") for f = (and (fboundp s) (symbol-function s) (not (special-operator-p s)) (not (macro-function s)) (symbol-function s)) unless (or (null f) (functionp f)) collect x) nil) (deftest functionp.5 (functionp '(setf car)) nil) ;;; In ANSI CL, lambda forms are no longer functions (deftest functionp.6 (functionp '(lambda (x) x)) nil) (eval-when (eval compile) (ignore-errors (defun (setf functionp-7-accessor) (y x) (setf (car x) y) y))) (deftest functionp.7 (not-mv (functionp #'(setf functionp-7-accessor))) nil) (deftest functionp.8 (not-mv (functionp #'(lambda (x) x))) nil) (deftest functionp.9 (not-mv (functionp (compile nil '(lambda (x) x)))) nil) ;;; In ANSI CL, symbols and cons can no longer be functions (deftest functionp.10 (loop for x in *universe* when (and (or (numberp x) (characterp x) (symbolp x) (consp x) (typep x 'array)) (functionp x)) collect x) nil) (deftest functionp.11 (flet ((%f () nil)) (functionp '%f)) nil) (deftest functionp.12 (flet ((%f () nil)) (not-mv (functionp #'%f))) nil) (deftest functionp.order.1 (let ((i 0)) (values (notnot (functionp (progn (incf i) #'cons))) i)) t 1) (deftest functionp.error.1 (classify-error (functionp)) program-error) (deftest functionp.error.2 (classify-error (functionp #'cons nil)) program-error) gcl/ansi-tests/gclload.lsp000066400000000000000000000001351242227143400160420ustar00rootroot00000000000000(load "gclload1.lsp") (load "gclload2.lsp") (in-package :cl-test) (regression-test:do-tests) gcl/ansi-tests/gclload1.lsp000066400000000000000000000016701242227143400161300ustar00rootroot00000000000000(load "compile-and-load.lsp") (load "rt-package.lsp") (compile-and-load "rt.lsp") ;;; (unless (probe-file "rt.o") (compile-file "rt.lsp")) ;;; (load "rt.o") (load "cl-test-package.lsp") (in-package :cl-test) (load "universe.lsp") (compile-and-load "random-aux.lsp") (compile-and-load "ansi-aux.lsp") ;;; (unless (probe-file "ansi-aux.o") (compile-file "ansi-aux.lsp")) ;;; (load "ansi-aux.o") (load "cl-symbol-names.lsp") ;(load "notes.lsp") (setq *compile-verbose* nil *compile-print* nil *load-verbose* nil) #+cmu (setq ext:*gc-verbose* nil) #+gcl (setq compiler:*suppress-compiler-notes* t compiler:*suppress-compiler-warnings* t compiler:*compile-verbose* nil compiler:*compile-print* nil) #+lispworks (setq compiler::*compiler-warnings* nil) #+ecl (setq c:*suppress-compiler-warnings* t c:*suppress-compiler-notes* t) #+clisp (setq custom::*warn-on-floating-point-contagion* nil) gcl/ansi-tests/gclload2.lsp000066400000000000000000000017671242227143400161400ustar00rootroot00000000000000;;; Load test files ;;; Tests of symbols (load "load-symbols.lsp") ;;; Tests of evaluation and compilation (load "load-eval-and-compile.lsp") ;;; Tests of data and control flow (load "load-data-and-control-flow.lsp") ;;; Tests of iteration forms (load "load-iteration.lsp") ;;; Tests of conditions (load "load-conditions.lsp") ;;; Tests of conses (load "load-cons.lsp") ;;; Tests on arrays (load "load-arrays.lsp") ;;; Tests of hash tables (load "hash-table.lsp") (load "make-hash-table.lsp") ; More to come ;;; Tests of packages #-ecl (load "packages.lsp") ;;; Tests of sequences (load "load-sequences.lsp") ;;; Tests of structures (load "load-structures.lsp") ;;; Tests of types and classes (load "load-types-and-class.lsp") ;;; Tests of the reader (load "reader-test.lsp") ;;; Tests of strings (load "load-strings.lsp") ;;; Tests for character functions (compile-and-load "char-aux.lsp") (load "character.lsp") (load "char-compare.lsp") ;;; Tests of system construction (load "features.lsp") gcl/ansi-tests/get-setf-expansion.lsp000066400000000000000000000006201242227143400201540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 17:05:17 2003 ;;;; Contains: Tests for GET-SETF-EXPANSION (in-package :cl-test) (deftest get-setf-expansion.error.1 (classify-error (get-setf-expansion)) program-error) (deftest get-setf-expansion.error.2 (classify-error (get-setf-expansion 'x nil nil)) program-error) ;;; Tests for proper behavior will go here gcl/ansi-tests/handler-bind.lsp000066400000000000000000000060221242227143400167650ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Feb 28 22:07:25 2003 ;;;; Contains: Tests of HANDLER-BIND (in-package :cl-test) (deftest handler-bind.1 (handler-bind ()) nil) (deftest handler-bind.2 (handler-bind () (values))) (deftest handler-bind.3 (handler-bind () (values 1 2 3)) 1 2 3) (deftest handler-bind.4 (let ((x 0)) (values (handler-bind () (incf x) (+ x 10)) x)) 11 1) (deftest handler-bind.5 (block foo (handler-bind ((error #'(lambda (c) (return-from foo 'good)))) (error "an error"))) good) (deftest handler-bind.6 (block foo (handler-bind ((error #'(lambda (c) (return-from foo 'good)))) (handler-bind ((error #'(lambda (c) (error c))) (error #'(lambda (c) (return-from foo 'bad)))) (error "an error")))) good) (defun handler-bind.7-handler-fn (c) (declare (ignore c)) (throw 'foo 'good)) (deftest handler-bind.7 (catch 'foo (handler-bind ((simple-error #'handler-bind.7-handler-fn)) (error "simple error"))) good) (deftest handler-bind.8 (catch 'foo (handler-bind ((simple-error 'handler-bind.7-handler-fn)) (error "simple error"))) good) (deftest handler-bind.9 (catch 'foo (handler-bind ((simple-error #.(symbol-function 'handler-bind.7-handler-fn))) (error "simple error"))) good) (deftest handler-bind.10 (block done (flet ((%foo () (signal "A simple condition")) (%succeed (c) (declare (ignore c)) (return-from done 'good)) (%fail (c) (declare (ignore c)) (return-from done 'bad))) (handler-bind ((error #'%fail) (simple-condition #'%succeed)) (%foo)))) good) (deftest handler-bind.11 (block done (handler-bind ((error #'(lambda (c) c)) (error #'(lambda (c) (declare (ignore c)) (return-from done 'good)))) (error "an error"))) good) (deftest handler-bind.12 (block done (handler-bind ((error #'(lambda (c) (declare (ignore c)) (return-from done 'good)))) (handler-bind ((error #'(lambda (c) c))) (error "an error")))) good) (deftest handler-bind.13 (handler-bind ((error #'(lambda (c) (declare (ignore c)) (throw 'done 'good)))) (catch 'done (error "an error"))) good) (deftest handler-bind.14 (catch 'done (handler-bind ((symbol #'identity) ;; can never succeed (error #'(lambda (c) (declare (ignore c)) (throw 'done 'good)))) (error "an error"))) good) (deftest handler-bind.15 (catch 'done (handler-bind ((t #'(lambda (c) (declare (ignore c)) (throw 'done 'good)))) (error "an error"))) good) (deftest handler-bind.16 (catch 'done (handler-bind (((not error) #'identity) (error #'(lambda (c) (declare (ignore c)) (throw 'done 'good)))) (error "an error"))) good) (deftest handler-bind.17 (catch 'done (handler-bind ((#.(find-class 'error) #'(lambda (c) (declare (ignore c)) (throw 'done 'good)))) (error "an error"))) good) ;;; More handler-bind tests elsewhere gcl/ansi-tests/handler-case.lsp000066400000000000000000000003121242227143400167600ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 1 14:08:07 2003 ;;;; Contains: Tests of HANDLER-CASE (in-package :cl-test) ;;; (deftest handler-case.1 ;;; (handler-case (( gcl/ansi-tests/hash-table.lsp000066400000000000000000000027151242227143400164530ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 21:30:42 2003 ;;;; Contains: Tests of HASH-TABLE and related interface (in-package :cl-test) (deftest hash-table.1 (notnot-mv (find-class 'hash-table)) t) (deftest hash-table.2 (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 #0aNIL #2a((a b)(c d)) #p"foo" "bar" #\a 3/5 #c(1.0 2.0)) when (typep e 'hash-table) collect e) nil) (deftest hash-table.3 (let ((c (find-class 'hash-table))) (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 #0aNIL #2a((a b)(c d)) #p"foo" "bar" #\a 3/5 #c(1.0 2.0)) when (typep e c) collect e)) nil) (deftest hash-table.4 (notnot-mv (typep (make-hash-table) 'hash-table)) t) (deftest hash-table.5 (notnot-mv (typep (make-hash-table) (find-class 'hash-table))) t) ;;; (deftest hash-table-p.1 (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 #0aNIL #2a((a b)(c d)) #p"foo" "bar" #\a 3/5 #c(1.0 2.0)) when (hash-table-p e) collect e) nil) (deftest hash-table-p.2 (loop for e in *universe* for p = (typep e 'hash-table) for q = (hash-table-p e) always (if p q (not q))) t) (deftest hash-table-p.3 (let ((i 0)) (values (hash-table-p (incf i)) i)) nil 1) (deftest hash-table-p.error.1 (classify-error (hash-table-p)) program-error) (deftest hash-table-p.error.2 (classify-error (let ((h (make-hash-table))) (hash-table-p h nil))) program-error) gcl/ansi-tests/identity.lsp000066400000000000000000000012371242227143400162720ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 23:21:11 2002 ;;;; Contains: Tests for IDENTITY (in-package :cl-test) (deftest identity.1 (loop for x in *universe* always (eqlt x (check-values (identity x)))) t) (deftest identity.2 (let ((x (ash 1 100))) (eqlt x (check-values (identity x)))) t) (deftest identity.3 (let ((x 1.00000001)) (eqlt x (check-values (identity x)))) t) (deftest identity.order.1 (let ((i 0)) (values (identity (incf i)) i)) 1 1) (deftest identity.error.1 (classify-error (identity)) program-error) (deftest identity.error.2 (classify-error (identity 'a 'a)) program-error) gcl/ansi-tests/if.lsp000066400000000000000000000010011242227143400150240ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 08:21:29 2002 ;;;; Contains: Tests for IF (in-package :cl-test) (deftest if.1 (if t 1 2) 1) (deftest if.2 (if nil 1 2) 2) (deftest if.3 (if t (values) 'a)) (deftest if.4 (if nil 'a) nil) (deftest if.5 (if t (values 'a 'b 'c) 'd) a b c) (deftest if.6 (if nil 'a (values 'b 'c 'd)) b c d) (deftest if.7 (if nil 'a (values))) (deftest if.order.1 (let ((i 0)) (values (if (= (incf i) 1) 't nil) i)) t 1) gcl/ansi-tests/invoke-debugger.lsp000066400000000000000000000011301242227143400175060ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Feb 28 21:59:57 2003 ;;;; Contains: Tests of INVOKE-DEBUGGER (in-package :cl-test) ;;; We can't test actual entry into the debugger, but we can test ;;; that the function in *debugger-hook* is properly called. (deftest invoke-debugger.1 (block done (let (fn (cnd (make-condition 'simple-error))) (setq fn #'(lambda (c hook) (return-from done (and (null *debugger-hook*) (eqt hook fn) (eqt cnd c) 'good)))) (let ((*debugger-hook* fn)) (invoke-debugger cnd))) 'bad) good) gcl/ansi-tests/iteration.lsp000066400000000000000000000203761242227143400164440ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 21 22:58:00 2002 ;;;; Contains: Tests for iteration forms other than LOOP (in-package :cl-test) ;;; Confirm that most macros exist (defparameter *iteration-macros* '(do do* dotimes dolist loop)) (deftest iteration-macros (remove-if #'macro-function *iteration-macros*) nil) ;;; Tests of DO (deftest do.1 (do ((i 0 (1+ i))) ((>= i 10) i)) 10) (deftest do.2 (do ((i 0 (1+ j)) (j 0 (1+ i))) ((>= i 10) (+ i j))) 20) (deftest do.3 (let ((x nil)) (do ((i 0 (1+ i))) ((>= i 10) x) (push i x))) (9 8 7 6 5 4 3 2 1 0)) (deftest do.4 (let ((x nil)) (do ((i 0 (1+ i))) ((>= i 10) x) (declare (fixnum i)) (push i x))) (9 8 7 6 5 4 3 2 1 0)) (deftest do.5 (do ((i 0 (1+ i))) (nil) (when (> i 10) (return i))) 11) ;;; Zero iterations (deftest do.6 (do ((i 0 (+ i 10))) ((> i -1) i) (return 'bad)) 0) ;;; Tests of go tags (deftest do.7 (let ((x nil)) (do ((i 0 (1+ i))) ((>= i 10) x) (go around) small (push 'a x) (go done) big (push 'b x) (go done) around (if (> i 4) (go big) (go small)) done)) (b b b b b a a a a a)) ;;; No increment form (deftest do.8 (do ((i 0 (1+ i)) (x nil)) ((>= i 10) x) (push 'a x)) (a a a a a a a a a a)) ;;; No do locals (deftest do.9 (let ((i 0)) (do () ((>= i 10) i) (incf i))) 10) ;;; Return of no values (deftest do.10 (do ((i 0 (1+ i))) ((> i 10) (values)))) ;;; Return of two values (deftest do.11 (do ((i 0 (1+ i))) ((> i 10) (values i (1+ i)))) 11 12) ;;; The results* list is an implicit progn (deftest do.12 (do ((i 0 (1+ i))) ((> i 10) (incf i) (incf i) i)) 13) (deftest do.13 (do ((i 0 (1+ i))) ((> i 10))) nil) ;; Special var (deftest do.14 (let ((x 0)) (flet ((%f () (locally (declare (special i)) (incf x i)))) (do ((i 0 (1+ i))) ((>= i 10) x) (declare (special i)) (%f)))) 45) ;;; Confirm that the variables in succesive iterations are ;;; identical (deftest do.15 (mapcar #'funcall (let ((x nil)) (do ((i 0 (1+ i))) ((= i 5) x) (push #'(lambda () i) x)))) (5 5 5 5 5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Tests of DO* (deftest do*.1 (do* ((i 0 (1+ i))) ((>= i 10) i)) 10) (deftest do*.2 (do* ((i 0 (1+ j)) (j 0 (1+ i))) ((>= i 10) (+ i j))) 23) (deftest do*.3 (let ((x nil)) (do* ((i 0 (1+ i))) ((>= i 10) x) (push i x))) (9 8 7 6 5 4 3 2 1 0)) (deftest do*.4 (let ((x nil)) (do* ((i 0 (1+ i))) ((>= i 10) x) (declare (fixnum i)) (push i x))) (9 8 7 6 5 4 3 2 1 0)) (deftest do*.5 (do* ((i 0 (1+ i))) (nil) (when (> i 10) (return i))) 11) ;;; Zero iterations (deftest do*.6 (do* ((i 0 (+ i 10))) ((> i -1) i) (return 'bad)) 0) ;;; Tests of go tags (deftest do*.7 (let ((x nil)) (do* ((i 0 (1+ i))) ((>= i 10) x) (go around) small (push 'a x) (go done) big (push 'b x) (go done) around (if (> i 4) (go big) (go small)) done)) (b b b b b a a a a a)) ;;; No increment form (deftest do*.8 (do* ((i 0 (1+ i)) (x nil)) ((>= i 10) x) (push 'a x)) (a a a a a a a a a a)) ;;; No do* locals (deftest do*.9 (let ((i 0)) (do* () ((>= i 10) i) (incf i))) 10) ;;; Return of no values (deftest do*.10 (do* ((i 0 (1+ i))) ((> i 10) (values)))) ;;; Return of two values (deftest do*.11 (do* ((i 0 (1+ i))) ((> i 10) (values i (1+ i)))) 11 12) ;;; The results* list is an implicit progn (deftest do*.12 (do* ((i 0 (1+ i))) ((> i 10) (incf i) (incf i) i)) 13) (deftest do*.13 (do* ((i 0 (1+ i))) ((> i 10))) nil) ;; Special var (deftest do*.14 (let ((x 0)) (flet ((%f () (locally (declare (special i)) (incf x i)))) (do* ((i 0 (1+ i))) ((>= i 10) x) (declare (special i)) (%f)))) 45) ;;; Confirm that the variables in succesive iterations are ;;; identical (deftest do*.15 (mapcar #'funcall (let ((x nil)) (do* ((i 0 (1+ i))) ((= i 5) x) (push #'(lambda () i) x)))) (5 5 5 5 5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Tests for DOLIST (deftest dolist.1 (let ((count 0)) (dolist (x '(a b nil d)) (incf count)) count) 4) (deftest dolist.2 (let ((count 0)) (dolist (x '(a nil c d) count) (incf count))) 4) (deftest dolist.3 (let ((count 0)) (dolist (x nil count) (incf count))) 0) (deftest dolist.4 (let ((y nil)) (flet ((%f () (locally (declare (special e)) (push e y)))) (dolist (e '(a b c) (reverse y)) (declare (special e)) (%f)))) (a b c)) ;;; Tests that it's a tagbody (deftest dolist.5 (let ((even nil) (odd nil)) (dolist (i '(1 2 3 4 5 6 7 8) (values (reverse even) (reverse odd))) (when (evenp i) (go even)) (push i odd) (go done) even (push i even) done)) (2 4 6 8) (1 3 5 7)) ;;; Test that bindings are not normally special (deftest dolist.6 (let ((i 0) (y nil)) (declare (special i)) (flet ((%f () i)) (dolist (i '(1 2 3 4)) (push (%f) y))) y) (0 0 0 0)) ;;; Test multiple return values (deftest dolist..7 (dolist (x '(a b) (values)))) (deftest dolist.8 (let ((count 0)) (dolist (x '(a b c) (values count count)) (incf count))) 3 3) ;;; Test ability to return, and the scope of the implicit ;;; nil block (deftest dolist.9 (block nil (eqlt (dolist (x '(a b c)) (return 1)) 1)) t) (deftest dolist.10 (block nil (eqlt (dolist (x '(a b c)) (return-from nil 1)) 1)) t) (deftest dolist.11 (block nil (dolist (x (return 1))) 2) 2) (deftest dolist.12 (block nil (dolist (x '(a b) (return 1))) 2) 2) ;;; Check that binding of element var is visible in the result form (deftest dolist.13 (dolist (e '(a b c) e)) nil) (deftest dolist.14 (let ((e 1)) (dolist (e '(a b c) (setf e 2))) e) 1) (deftest dolist.15 (let ((x nil)) (dolist (e '(a b c d e f)) (push e x) (when (eq e 'c) (return x)))) (c b a)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Tests for DOTIMES (deftest dotimes.1 (dotimes (i 10)) nil) (deftest dotimes.2 (dotimes (i 10 'a)) a) (deftest dotimes.3 (dotimes (i 10 (values)))) (deftest dotimes.3a (dotimes (i 10 (values 'a 'b 'c))) a b c) (deftest dotimes.4 (let ((x nil)) (dotimes (i 5 x) (push i x))) (4 3 2 1 0)) (deftest dotimes.5 (let ((x nil)) (dotimes (i 0 x) (push i x))) nil) (deftest dotimes.6 (let ((x nil)) (dotimes (i -1 x) (push i x))) nil) (deftest dotimes.7 (let ((x nil)) (dotimes (i (1- most-negative-fixnum) x) (push i x))) nil) ;;; Implicit nil block has the right scope (deftest dotimes.8 (block nil (dotimes (i (return 1))) 2) 2) (deftest dotimes.9 (block nil (dotimes (i 10 (return 1))) 2) 2) (deftest dotimes.10 (block nil (dotimes (i 10) (return 1)) 2) 2) (deftest dotimes.11 (let ((x nil)) (dotimes (i 10) (push i x) (when (= i 5) (return x)))) (5 4 3 2 1 0)) ;;; Check there's an implicit tagbody (deftest dotimes.12 (let ((even nil) (odd nil)) (dotimes (i 8 (values (reverse even) (reverse odd))) (when (evenp i) (go even)) (push i odd) (go done) even (push i even) done)) (0 2 4 6) (1 3 5 7)) ;;; Check that at the time the result form is evaluated, ;;; the index variable is set to the number of times the loop ;;; was executed. (deftest dotimes.13 (let ((i 100)) (dotimes (i 10 i))) 10) (deftest dotimes.14 (let ((i 100)) (dotimes (i 0 i))) 0) (deftest dotimes.15 (let ((i 100)) (dotimes (i -1 i))) 0) ;;; Check that the variable is not bound in the count form (deftest dotimes.16 (let ((i nil)) (values i (dotimes (i (progn (setf i 'a) 10) i)) i)) nil 10 a) ;;; Check special variable decls (deftest dotimes.17 (let ((i 0) (y nil)) (declare (special i)) (flet ((%f () i)) (dotimes (i 4) (push (%f) y))) y) (0 0 0 0)) (deftest dotimes.18 (let ((i 0) (y nil)) (declare (special i)) (flet ((%f () i)) (dotimes (i 4) (declare (special i)) (push (%f) y))) y) (3 2 1 0)) gcl/ansi-tests/labels.lsp000066400000000000000000000116561242227143400157110ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Oct 9 19:06:33 2002 ;;;; Contains: Tests of LABELS (in-package :cl-test) (deftest labels.1 (labels ((%f () 1)) (%f)) 1) (deftest labels.2 (labels ((%f (x) x)) (%f 2)) 2) (deftest labels.3 (labels ((%f (&rest args) args)) (%f 'a 'b 'c)) (a b c)) ;;; The optional arguments are not in the block defined by ;;; the local function declaration (deftest labels.4 (block %f (labels ((%f (&optional (x (return-from %f 10))) 20)) (%f))) 10) (deftest labels.5 (labels ((%f () (return-from %f 15) 35)) (%f)) 15) ;;; The aux parameters are not in the block defined by ;;; the local function declaration (deftest labels.6 (block %f (labels ((%f (&aux (x (return-from %f 10))) 20)) (%f))) 10) ;;; The function is visible inside itself (deftest labels.7 (labels ((%f (x n) (cond ((eql n 0) x) (t (%f (+ x n) (1- n)))))) (%f 0 10)) 55) ;;; Keyword arguments (deftest labels.8 (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f)) nil 0 nil) (deftest labels.9 (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a 1)) 1 0 nil) (deftest labels.10 (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :b 2)) nil 2 t) (deftest labels.11 (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :b 2 :a 3)) 3 2 t) ;;; Unknown keyword parameter should throw a program-error in safe code ;;; (section 3.5.1.4) (deftest labels.12 (classify-error (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4))) program-error) ;;; Odd # of keyword args should throw a program-error in safe code ;;; (section 3.5.1.6) (deftest labels.13 (classify-error (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a))) program-error) ;;; Too few arguments (section 3.5.1.2) (deftest labels.14 (classify-error (labels ((%f (a) a)) (%f))) program-error) ;;; Too many arguments (section 3.5.1.3) (deftest labels.15 (classify-error (labels ((%f (a) a)) (%f 1 2))) program-error) ;;; Invalid keyword argument (section 3.5.1.5) (deftest labels.16 (classify-error (labels ((%f (&key a) a)) (%f '(foo)))) program-error) ;;; Definition of a (setf ...) function (deftest labels.17 (labels (((setf %f) (x y) (setf (car y) x))) (let ((z (list 1 2))) (setf (%f z) 'a) z)) (a 2)) ;;; Scope of defined function names includes &AUX parameters (deftest labels.7b (labels ((%f (x &aux (b (%g x))) b) (%g (y) (+ y y))) (%f 10)) 20) ;;; Body is an implicit progn (deftest labels.18 (labels ((%f (x) (incf x) (+ x x))) (%f 10)) 22) ;;; Can handle at least 50 lambda parameters (deftest labels.19 (labels ((%f (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) (%f 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50)) 1275) ;;; labels works with the maximum number of arguments (if ;;; not too many.) (deftest labels.20 (let* ((n (min lambda-parameters-limit 1024)) (vars (loop for i from 1 to n collect (gensym)))) (eval `(eql ,n (labels ((%f ,vars (+ ,@ vars))) (%f ,@(loop for e in vars collect 1)))))) t) ;;; Declarations and documentation strings are ok (deftest labels.21 (labels ((%f (x) (declare (type fixnum x)) "Add one to the fixnum x." (1+ x))) (declare (ftype (function (fixnum) integer) %f)) (%f 10)) 11) ;;; Keywords can be function names (deftest labels.22 (labels ((:foo () 10) (:bar () (1+ (:foo)))) (:bar)) 11) (deftest labels.23 (labels ((:foo () 10) (:bar () (1+ (funcall #':foo)))) (funcall #':bar)) 11) (deftest labels.24 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (labels ((,s (x) (foo (1- x))) (foo (y) (if (<= y 0) 'a (,s (1- y))))) (,s 10))) unless (eq (eval form) 'a) collect s) nil) (deftest labels.25 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (labels ((,s (x) (foo (1- x))) (foo (y) (if (<= y 0) 'a (,s (1- y))))) (declare (ftype (function (integer) symbol) foo ,s)) (,s 10))) unless (eq (eval form) 'a) collect s) nil) (deftest labels.26 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (labels (((setf ,s) (&rest args) (declare (ignore args)) 'a)) (setf (,s) 10))) unless (eq (eval form) 'a) collect s) nil) gcl/ansi-tests/lambda-list-keywords.lsp000066400000000000000000000020051242227143400204710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 7 22:11:31 2002 ;;;; Contains: Tests for LAMBDA-LIST-KEYWORDS (in-package :cl-test) ;;; The variable is bound (deftest lambda-list-keywords.1 (not-mv (boundp 'lambda-list-keywords)) nil) ;;; The variable is a constant (deftest lambda-list-keywords.2 (not-mv (constantp 'lambda-list-keywords)) nil) ;;; The standard keywords are present in the list (deftest lambda-list-keywords.3 (and (consp lambda-list-keywords) (not-mv (set-difference '(&allow-other-keys &aux &body &environment &key &optional &rest &whole) lambda-list-keywords))) t) ;;; No lambda list keywords are in the keyword package (deftest lambda-list-keywords.4 (some #'keywordp lambda-list-keywords) nil) ;;; Every keyword starts with an ampersand (deftest lambda-list-keywords.5 (notevery #'(lambda (sym) (let ((name (symbol-name sym))) (and (> (length name) 0) (eql (aref name 0) #\&)))) lambda-list-keywords) nil) gcl/ansi-tests/lambda-parameters-limit.lsp000066400000000000000000000005671242227143400211430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 22:45:44 2002 ;;;; Contains: Tests for LAMBDA-PARAMETERS-LIMIT (in-package :cl-test) (deftest lambda-parameters-limit.1 (not (typep lambda-parameters-limit 'integer)) nil) (deftest lambda-parameters-limit.2 (< lambda-parameters-limit 50) nil) ;;; See also tests is flet.lsp, labels.lsp gcl/ansi-tests/lambda.lsp000066400000000000000000000017761242227143400156710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Nov 27 06:43:21 2002 ;;;; Contains: Tests of LAMBDA forms (in-package :cl-test) (deftest lambda.1 ((lambda (x) x) 'a) a) (deftest lambda.2 ((lambda () 'a)) a) (deftest lambda.3 ((lambda () "documentation" 'a)) a) (deftest lambda.4 ((lambda (x) (declare (type symbol x)) x) 'z) z) (deftest lambda.5 ((lambda (&aux (x 'a)) x)) a) (deftest lambda.6 ((lambda (&aux (x 'a)) (declare (type symbol x)) x)) a) (deftest lambda.7 ((lambda () "foo")) "foo") (deftest lambda.8 ((lambda () "foo" "bar")) "bar") (deftest lambda.9 ((lambda (x y) (declare (ignore x)) "foo" (declare (ignore y)) "bar") 1 2) "bar") (deftest lambda.10 ((lambda (x) (declare (type symbol x))) 'z) nil) ;;; Should test lambda argument lists more fully here ;;; Tests of lambda as a macro (deftest lambda.macro.1 (notnot (macro-function 'lambda)) t) (deftest lambda.macro.2 (funcall (eval (macroexpand '(lambda () 10)))) 10) gcl/ansi-tests/length.lsp000066400000000000000000000046241242227143400157250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 20 23:25:29 2002 ;;;; Contains: Test cases for LENGTH (in-package :cl-test) (deftest length-list.1 (length nil) 0) (deftest length-list.2 (length '(a b c d e)) 5) (deftest length-list.3 (length (make-list 200000)) 200000) (defun length-list-4-body () (let ((x ())) (loop for i from 0 to 999 do (progn (unless (eql (length x) i) (return nil)) (push i x)) finally (return t)))) (deftest length-list-4 (length-list-4-body) t) (deftest length-vector.1 (length #()) 0) (deftest length-vector.2 (length #(a)) 1) (deftest length-vector.3 (length #(a b)) 2) (deftest length-vector.4 (length #(a b c)) 3) (deftest length-nonsimple-vector.1 (length (make-array 10 :fill-pointer t :adjustable t)) 10) (deftest length-nonsimple-vector.2 (let ((a (make-array 10 :fill-pointer t :adjustable t))) (setf (fill-pointer a) 5) (length a)) 5) (deftest length-bitstring.1 (length #*) 0) (deftest length-bitstring.2 (length #*1) 1) (deftest length-bitstring.3 (length #*0) 1) (deftest length-bitstring.4 (length #*010101) 6) (deftest length-string.1 (length "") 0) (deftest length-string.2 (length "a") 1) (deftest length-string.3 (length "abcdefghijklm") 13) (deftest length-string.4 (length "\") 1) ;;; Error cases (deftest length.error.1 (classify-error (length 'a)) type-error) (deftest length.error.2 (classify-error (length 10)) type-error) (deftest length.error.3 (classify-error (length 1.0)) type-error) (deftest length.error.4 (classify-error (length #\a)) type-error) (deftest length.error.5 (classify-error (length 10/3)) type-error) (deftest length.error.6 (classify-error (length)) program-error) (deftest length.error.7 (classify-error (length nil nil)) program-error) (deftest length.error.8 (classify-error (locally (length 'a) t)) type-error) ;;; Length on vectors created with make-array (deftest array-length-1 (length (make-array '(20))) 20) (deftest array-length-2 (length (make-array '(100001))) 100001) (deftest array-length-3 (length (make-array '(0))) 0) (deftest array-length-4 (let ((x (make-array '(100) :fill-pointer 10))) (length x)) 10) (deftest array-length-5 (let ((x (make-array '(100) :fill-pointer 10))) (setf (fill-pointer x) 20) (length x)) 20) gcl/ansi-tests/let.lsp000066400000000000000000000075541242227143400152350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 09:24:36 2002 ;;;; Contains: Tests for LET, LET* (in-package :cl-test) ;;; LET and LET* are also heavily exercised in the many other tests. ;;; NOTE! Some of these tests bind a variable with the same name ;;; more than once. This apparently has underdetermined semantics that ;;; varies in different Lisps. (deftest let.1 (let ((x 0)) x) 0) (deftest let.2 (let ((x 0) (y 1)) (values x y)) 0 1) (deftest let.3 (let ((x 0) (y 1)) (declare (special x y)) (values x y)) 0 1) (deftest let.4 (let ((x 0)) (let ((x 1)) x)) 1) (deftest let.5 (let ((x 0)) (let ((#:x 1)) x)) 0) (deftest let.6 (let ((x 0)) (declare (special x)) (let ((x 1)) (values x (locally (declare (special x)) x)))) 1 0) (deftest let.7 (let ((x '(a b c))) (declare (dynamic-extent x)) x) (a b c)) ;;;(deftest let.8 ;;; (let ((x 0) (x 1)) x) ;;; 1) (deftest let.9 (let (x y z) (values x y z)) nil nil nil) ;;; (deftest let.10 ;;; (let ((x 1) x) x) ;;; nil) (deftest let.11 (let ((x 1)) (list x (let (x) (declare (special x)) x) x)) (1 nil 1)) ;;; (deftest let.12 ;;; (let ((x 0)) ;;; (values ;;; (let ((x 20) ;;; (x (1+ x))) ;;; x) ;;; x)) ;;; 1 0) ;;; (deftest let.13 ;;; (flet ((%f () (declare (special x)) ;;; (if (boundp 'x) x 10))) ;;; (let ((x 1) ;;; (x (1+ (%f)))) ;;; (declare (special x)) ;;; x)) ;;; 11) ;;; Tests of large number of LET variables (deftest let.14 (let* ((n 1000) (vars (mapcar #'gensym (make-list n :initial-element "G"))) (expr `(let ,(let ((i 0)) (mapcar #'(lambda (v) (list v (incf i))) vars)) ,(let ((sumexpr 0)) (dolist (v vars) (setq sumexpr `(+ ,v ,sumexpr))) sumexpr))) (val (eval expr))) (or (eqlt val (/ (* n (1+ n)) 2)) (list val))) t) ;;; Test that all non-variables exported from COMMON-LISP can be bound ;;; in LET forms. (deftest let.15 (loop for s in *cl-non-variable-constant-symbols* for form = `(classify-error (let ((,s 17)) ,s)) unless (eql (eval form) 17) collect s) nil) ;;; Tests for LET* (deftest let*.1 (let* ((x 0)) x) 0) (deftest let*.2 (let* ((x 0) (y 1)) (values x y)) 0 1) (deftest let*.3 (let* ((x 0) (y 1)) (declare (special x y)) (values x y)) 0 1) (deftest let*.4 (let* ((x 0)) (let* ((x 1)) x)) 1) (deftest let*.5 (let* ((x 0)) (let* ((#:x 1)) x)) 0) (deftest let*.6 (let* ((x 0)) (declare (special x)) (let* ((x 1)) (values x (locally (declare (special x)) x)))) 1 0) (deftest let*.7 (let* ((x '(a b c))) (declare (dynamic-extent x)) x) (a b c)) (deftest let*.8 (let* ((x 0) (x 1)) x) 1) (deftest let*.9 (let* (x y z) (values x y z)) nil nil nil) (deftest let*.10 (let* ((x 1) x) x) nil) (deftest let*.11 (let* ((x 1)) (list x (let* (x x x) (declare (special x)) x) x)) (1 nil 1)) (deftest let*.12 (let* ((x 1) (y (1+ x)) (x (1+ y)) (z (+ x y))) (values x y z)) 3 2 5) ;;; (deftest let*.13 ;;; (flet ((%f () (declare (special x)) x)) ;;; (let* ((x 1) ;;; (x (1+ (%f)))) ;;; (declare (special x)) ;;; x)) ;;; 2) ;;; Tests of large number of LET* variables (deftest let*.14 (let* ((n 1000) (vars (mapcar #'gensym (make-list n :initial-element "G"))) (expr `(let* ,(let ((i 0)) (mapcar #'(lambda (v) (list v (incf i))) vars)) ,(let ((sumexpr 0)) (dolist (v vars) (setq sumexpr `(+ ,v ,sumexpr))) sumexpr))) (val (eval expr))) (or (eqlt val (/ (* n (1+ n)) 2)) (list val))) t) ;;; Test that all non-variables exported from COMMON-LISP can be bound ;;; in LET* forms. (deftest let*.15 (loop for s in *cl-non-variable-constant-symbols* for form = `(classify-error (let* ((,s 17)) ,s)) unless (eql (eval form) 17) collect s) nil) gcl/ansi-tests/load-arrays.lsp000066400000000000000000000022061242227143400166540ustar00rootroot00000000000000;;; Tests on arrays (compile-and-load "array-aux.lsp") (load "aref.lsp") (load "array.lsp") (load "array-t.lsp") (load "array-as-class.lsp") (load "simple-array.lsp") (load "simple-array-t.lsp") (load "bit-vector.lsp") (load "simple-bit-vector.lsp") (load "make-array.lsp") (load "adjustable-array-p.lsp") (load "array-displacement.lsp") (load "array-dimension.lsp") (load "array-dimensions.lsp") (load "array-in-bounds-p.lsp") (load "array-misc.lsp") (load "array-rank.lsp") (load "array-row-major-index.lsp") (load "array-total-size.lsp") (load "arrayp.lsp") (load "fill-pointer.lsp") (load "row-major-aref.lsp") (load "simple-vector-p.lsp") (load "svref.lsp") (load "upgraded-array-element-type.lsp") (load "vector.lsp") (load "vector-pop.lsp") (load "vector-push.lsp") (load "vector-push-extend.lsp") (load "vectorp.lsp") (load "bit.lsp") (load "sbit.lsp") (load "bit-and.lsp") (load "bit-andc1.lsp") (load "bit-andc2.lsp") (load "bit-eqv.lsp") (load "bit-ior.lsp") (load "bit-nand.lsp") (load "bit-nor.lsp") (load "bit-orc1.lsp") (load "bit-orc2.lsp") (load "bit-xor.lsp") (load "bit-not.lsp") (load "bit-vector-p.lsp") (load "simple-bit-vector-p.lsp") gcl/ansi-tests/load-conditions.lsp000066400000000000000000000003501242227143400175220ustar00rootroot00000000000000;;; Tests of conditions (load "condition.lsp") (load "cell-error-name.lsp") (load "assert.lsp") (load "error.lsp") (load "cerror.lsp") (load "check-type.lsp") (load "warn.lsp") (load "invoke-debugger.lsp") (load "handler-bind.lsp") gcl/ansi-tests/load-cons.lsp000066400000000000000000000012371242227143400163200ustar00rootroot00000000000000;;; Tests of conses (load "cons-test-01.lsp") (load "cons-test-02.lsp") (load "cons-test-03.lsp") (load "cons-test-04.lsp") (load "cons-test-05.lsp") (load "cons-test-06.lsp") (load "cons-test-07.lsp") (load "cons-test-08.lsp") (load "cons-test-09.lsp") (load "cons-test-10.lsp") (load "cons-test-11.lsp") (load "cons-test-12.lsp") (load "cons-test-13.lsp") (load "cons-test-14.lsp") (load "cons-test-15.lsp") (load "cons-test-16.lsp") (load "cons-test-17.lsp") (load "cons-test-18.lsp") (load "cons-test-19.lsp") (load "cons-test-20.lsp") (load "cons-test-21.lsp") (load "cons-test-22.lsp") (load "cons-test-23.lsp") (load "cons-test-24.lsp") (load "cons-test-25.lsp") gcl/ansi-tests/load-data-and-control-flow.lsp000066400000000000000000000030731242227143400214520ustar00rootroot00000000000000;;; Tests of data and control flow (load "data-and-control-flow.lsp") (load "places.lsp") (load "and.lsp") (load "apply.lsp") (load "block.lsp") (load "call-arguments-limit.lsp") (load "case.lsp") (load "catch.lsp") (load "ccase.lsp") (load "compiled-function-p.lsp") (load "complement.lsp") (load "cond.lsp") (load "constantly.lsp") (load "ctypecase.lsp") (load "defconstant.lsp") (load "define-modify-macro.lsp") (load "defparameter.lsp") (load "defun.lsp") (load "defvar.lsp") (load "destructuring-bind.lsp") (load "ecase.lsp") (load "eql.lsp") (load "equal.lsp") (load "equalp.lsp") (load "etypecase.lsp") (load "every.lsp") (load "fboundp.lsp") (load "fdefinition.lsp") (load "flet.lsp") (load "fmakunbound.lsp") (load "funcall.lsp") (load "function-lambda-expression.lsp") (load "function.lsp") (load "functionp.lsp") (load "get-setf-expansion.lsp") (load "identity.lsp") (load "if.lsp") (load "labels.lsp") (load "lambda-list-keywords.lsp") (load "lambda-parameters-limit.lsp") (load "let.lsp") (load "macrolet.lsp") (load "multiple-value-bind.lsp") (load "multiple-value-call.lsp") ;; include multiple-value-list (load "multiple-value-prog1.lsp") (load "multiple-value-setq.lsp") (load "nil.lsp") (load "not-and-null.lsp") (load "notany.lsp") (load "notevery.lsp") (load "nth-value.lsp") (load "or.lsp") (load "prog.lsp") (load "prog1.lsp") (load "prog2.lsp") (load "progn.lsp") (load "progv.lsp") (load "some.lsp") (load "t.lsp") (load "tagbody.lsp") (load "typecase.lsp") (load "unless.lsp") (load "unwind-protect.lsp") (load "values-list.lsp") (load "values.lsp") (load "when.lsp") gcl/ansi-tests/load-eval-and-compile.lsp000066400000000000000000000002651242227143400204730ustar00rootroot00000000000000;;; Tests of evaluation and compilation (load "eval.lsp") (load "eval-and-compile.lsp") (load "compile.lsp") (load "compiler-macros.lsp") (load "constantp.lsp") (load "lambda.lsp") gcl/ansi-tests/load-iteration.lsp000066400000000000000000000006211242227143400173500ustar00rootroot00000000000000;;; Tests of iteration forms (load "iteration.lsp") (load "loop.lsp") (load "loop1.lsp") (load "loop2.lsp") (load "loop3.lsp") (load "loop4.lsp") (load "loop5.lsp") (load "loop6.lsp") (load "loop7.lsp") (load "loop8.lsp") (load "loop9.lsp") (load "loop10.lsp") (load "loop11.lsp") (load "loop12.lsp") (load "loop13.lsp") (load "loop14.lsp") (load "loop15.lsp") (load "loop16.lsp") (load "loop17.lsp") gcl/ansi-tests/load-sequences.lsp000066400000000000000000000020251242227143400173450ustar00rootroot00000000000000;;; Tests of sequences (load "copy-seq.lsp") (load "elt.lsp") (load "fill.lsp") (load "fill-strings.lsp") (load "make-sequence.lsp") (load "map.lsp") (load "map-into.lsp") (load "reduce.lsp") (load "count.lsp") (load "count-if.lsp") (load "count-if-not.lsp") (load "reverse.lsp") (load "nreverse.lsp") (load "sort.lsp") (load "find.lsp") (load "find-if.lsp") (load "find-if-not.lsp") (load "position.lsp") (compile-and-load "search-aux.lsp") (load "search-list.lsp") (load "search-vector.lsp") (load "search-bitvector.lsp") (load "search-string.lsp") (load "mismatch.lsp") (load "replace.lsp") (compile-and-load "subseq-aux.lsp") (load "subseq.lsp") (load "substitute.lsp") (load "substitute-if.lsp") (load "substitute-if-not.lsp") (load "nsubstitute.lsp") (load "nsubstitute-if.lsp") (load "nsubstitute-if-not.lsp") (load "concatenate.lsp") (load "merge.lsp") (compile-and-load "remove-aux.lsp") (load "remove.lsp") ;; also related funs (compile-and-load "remove-duplicates-aux.lsp") (load "remove-duplicates.lsp") ;; also delete-duplicates gcl/ansi-tests/load-strings.lsp000066400000000000000000000007171242227143400170510ustar00rootroot00000000000000;;; Tests of strings (load "char-schar.lsp") (load "string.lsp") (load "string-upcase.lsp") (load "string-downcase.lsp") (load "string-capitalize.lsp") (load "nstring-upcase.lsp") (load "nstring-downcase.lsp") (load "nstring-capitalize.lsp") (load "string-trim.lsp") (load "string-left-trim.lsp") (load "string-right-trim.lsp") ;;; Tests of string comparison functions (compile-and-load "string-aux.lsp") (load "string-comparisons.lsp") (load "make-string.lsp")gcl/ansi-tests/load-structures.lsp000066400000000000000000000002111242227143400175700ustar00rootroot00000000000000;;; Tests of structures (load "structure-00.lsp") (load "structures-01.lsp") (load "structures-02.lsp") #-ecl (load "structures-03.lsp")gcl/ansi-tests/load-symbols.lsp000066400000000000000000000002061242227143400170410ustar00rootroot00000000000000;;; Tests of symbols (compile-and-load "cl-symbols-aux.lsp") (load "cl-symbol-names.lsp") (load "cl-symbols.lsp") (load "boundp.lsp") gcl/ansi-tests/load-types-and-class.lsp000066400000000000000000000005651242227143400203700ustar00rootroot00000000000000;;; Tests of types and classes (load "types-and-class.lsp") (load "types-and-class-2.lsp") (load "coerce.lsp") (load "subtypep.lsp") (load "subtypep-integer.lsp") (load "subtypep-float.lsp") (load "subtypep-rational.lsp") (load "subtypep-real.lsp") #-lispworks (load "subtypep-cons.lsp") (load "subtypep-member.lsp") (load "subtypep-eql.lsp") (load "subtypep-array.lsp") gcl/ansi-tests/load.lsp000066400000000000000000000006411242227143400153560ustar00rootroot00000000000000;; Get the MK package ;; I've hardwired a path here; fix for your system ;; I assume the package is already compiled. (unless (find-package "MK") (load #.(concatenate 'string "../defsys30/defsystem." #+cmu (C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*) #+allegro "fasl" #+(or akcl gcl) "o"))) (load "rt/rt.system") (mk::load-system "rt") (mk::compile-system "cltest") (in-package :cl-test) gcl/ansi-tests/loop.lsp000066400000000000000000000015171242227143400154130ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 25 18:48:59 2002 ;;;; Contains: Tests of LOOP (in-package :cl-test) ;;; Simple loops (deftest sloop.1 (loop (return 'a)) a) (deftest sloop.2 (loop (return (values)))) (deftest sloop.3 (loop (return (values 'a 'b 'c 'd))) a b c d) (deftest sloop.4 (block nil (loop (return 'a)) 'b) b) (deftest sloop.5 (let ((i 0) (x nil)) (loop (when (>= i 4) (return x)) (incf i) (push 'a x))) (a a a a)) (deftest sloop.6 (let ((i 0) (x nil)) (block foo (tagbody (loop (when (>= i 4) (go a)) (incf i) (push 'a x)) a (return-from foo x)))) (a a a a)) (deftest sloop.7 (catch 'foo (let ((i 0) (x nil)) (loop (when (>= i 4) (throw 'foo x)) (incf i) (push 'a x)))) (a a a a)) gcl/ansi-tests/loop1.lsp000066400000000000000000000111721242227143400154720ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 25 19:07:19 2002 ;;;; Contains: Tests of extended loop, part 1 (in-package :cl-test) ;;; Tests of variable initialization and stepping clauses ;;; for-as-arithmetic (deftest loop.1.1 (loop for x from 1 to 10 collect x) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.1.2 (loop for x from 6 downto 1 collect x) (6 5 4 3 2 1)) (deftest loop.1.3 (loop for x from 1 to 1 collect x) (1)) (deftest loop.1.4 (loop for x from 1 to 0 collect x) nil) (deftest loop.1.5 (loop for x to 5 collect x) (0 1 2 3 4 5)) (deftest loop.1.6 (loop for x downfrom 5 to 0 collect x) (5 4 3 2 1 0)) (deftest loop.1.7 (loop for x upfrom 1 to 5 collect x) (1 2 3 4 5)) (deftest loop.1.8 (loop for x from 1.0 to 5.0 count x) 5) (deftest loop.1.9 (loop for x from 1 to 9 by 2 collect x) (1 3 5 7 9)) (deftest loop.1.10 (loop for x from 1 to 10 by 2 collect x) (1 3 5 7 9)) (deftest loop.1.11 (loop for x to 10 from 1 collect x) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.1.12 (loop for x to 10 by 2 from 1 collect x) (1 3 5 7 9)) (deftest loop.1.13 (loop for x by 2 to 10 from 1 collect x) (1 3 5 7 9)) (deftest loop.1.14 (loop for x by 2 to 10 collect x) (0 2 4 6 8 10)) (deftest loop.1.15 (loop for x to 10 by 2 collect x) (0 2 4 6 8 10)) (deftest loop.1.16 (let ((n 0)) (loop for x from (incf n) to (+ n 5) collect x)) (1 2 3 4 5 6)) (deftest loop.1.17 (let ((n 0)) (loop for x to (+ n 5) from (incf n) collect x)) (1 2 3 4 5)) (deftest loop.1.18 (let ((n 0)) (loop for x from (incf n) to (+ n 9) by (incf n) collect x)) (1 3 5 7 9)) (deftest loop.1.19 (let ((n 0)) (loop for x from (incf n) by (incf n) to (+ n 9) collect x)) (1 3 5 7 9 11)) (deftest loop.1.20 (let ((a 0) (b 5) (c 1)) (loop for x from a to b by c collect (progn (incf a) (incf b 2) (incf c 3) x))) (0 1 2 3 4 5)) (deftest loop.1.21 (loop for x from 0 to 5 by 1/2 collect x) (0 1/2 1 3/2 2 5/2 3 7/2 4 9/2 5)) (deftest loop.1.22 (loop for x from 1 below 5 collect x) (1 2 3 4)) (deftest loop.1.23 (loop for x from 1 below 5.01 collect x) (1 2 3 4 5)) (deftest loop.1.24 (loop for x below 5 from 2 collect x) (2 3 4)) (deftest loop.1.25 (loop for x from 10 above 4 collect x) (10 9 8 7 6 5)) (deftest loop.1.26 (loop for x from 14 above 6 by 2 collect x) (14 12 10 8)) (deftest loop.1.27 (loop for x above 6 from 14 by 2 collect x) (14 12 10 8)) (deftest loop.1.28 (loop for x downfrom 16 above 7 by 3 collect x) (16 13 10)) (deftest loop.1.29 (let (a b c (i 0)) (values (loop for x from (progn (setq a (incf i)) 0) below (progn (setq b (incf i)) 9) by (progn (setq c (incf i)) 2) collect x) a b c i)) (0 2 4 6 8) 1 2 3 3) (deftest loop.1.30 (let (a b c (i 0)) (values (loop for x from (progn (setq a (incf i)) 0) by (progn (setq c (incf i)) 2) below (progn (setq b (incf i)) 9) collect x) a b c i)) (0 2 4 6 8) 1 3 2 3) (deftest loop.1.31 (let (a b c (i 0)) (values (loop for x below (progn (setq b (incf i)) 9) by (progn (setq c (incf i)) 2) from (progn (setq a (incf i)) 0) collect x) a b c i)) (0 2 4 6 8) 3 1 2 3) (deftest loop.1.32 (let (a b c (i 0)) (values (loop for x by (progn (setq c (incf i)) 2) below (progn (setq b (incf i)) 9) from (progn (setq a (incf i)) 0) collect x) a b c i)) (0 2 4 6 8) 3 2 1 3) (deftest loop.1.33 (loop for x from 1 upto 5 collect x) (1 2 3 4 5)) (deftest loop.1.34 (loop for x from 1 to 4.0 collect x) (1 2 3 4)) (deftest loop.1.35 (loop for x below 5 collect x) (0 1 2 3 4)) (deftest loop.1.36 (loop for x below 20 by 3 collect x) (0 3 6 9 12 15 18)) (deftest loop.1.37 (loop for x by 3 below 20 collect x) (0 3 6 9 12 15 18)) (deftest loop.1.38 (loop for x of-type fixnum from 1 to 5 collect x) (1 2 3 4 5)) #| ;;; The following provides an example where an incorrect ;;; implementation will assign X an out-of-range value ;;; at the end. (deftest loop.1.39 (loop for x of-type (integer 1 5) from 1 to 5 collect x) (1 2 3 4 5)) ;;; Test that the index variable achieves the inclusive ;;; upper bound, but does not exceed it. (deftest loop.1.40 (loop for x from 1 to 5 do nil finally (return x)) 5) ;;; Test that the index variable acheives the exclusive ;;; upper bound, but does not exceed it. (deftest loop.1.41 (loop for x from 1 below 5 do nil finally (return x)) 4) (deftest loop.1.42 (loop for x from 10 downto 0 do nil finally (return x)) 0) (deftest loop.1.43 (loop for x from 10 above 0 do nil finally (return x)) 1) |#gcl/ansi-tests/loop10.lsp000066400000000000000000000216071242227143400155560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 16 09:07:02 2002 ;;;; Contains: Tests of LOOP numeric value accumulation clauses (in-package :cl-test) ;; Tests of COUNT, COUNTING (deftest loop.10.1 (loop for x from 1 to 10 count (< x 5)) 4) (deftest loop.10.2 (loop for x from 1 to 10 counting (< x 7)) 6) (deftest loop.10.3 (loop for x from 1 to 10 count (< x 5) fixnum) 4) (deftest loop.10.4 (loop for x from 1 to 10 count (< x 5) of-type integer) 4) (deftest loop.10.5 (let (z) (values (loop for x from 1 to 10 count (< x 5) into foo finally (setq z foo)) z)) nil 4) (deftest loop.10.6 (let (z) (values (loop for x from 1 to 10 count (< x 5) into foo fixnum finally (setq z foo)) z)) nil 4) (deftest loop.10.7 (let (z) (values (loop for x from 1 to 10 count (< x 5) into foo of-type (integer 0 100) finally (setq z foo)) z)) nil 4) (deftest loop.10.8 (let (z) (values (loop for x from 1 to 10 count (< x 5) into foo float finally (setq z foo)) z)) nil 4.0) (deftest loop.10.9 (classify-error (loop with foo = 10 for x in '(a b c) count x into foo finally (return foo))) program-error) (deftest loop.10.10 (classify-error (loop with foo = 10 for x in '(a b c) counting x into foo finally (return foo))) program-error) (declaim (special *loop-count-var*)) (deftest loop.10.11 (let ((*loop-count-var* 100)) (values (loop for x in '(a b c d) count x into *loop-count-var* finally (return *loop-count-var*)) *loop-count-var*)) 4 100) (deftest loop.10.12 (loop for x in '(a b nil d nil e) count x into foo collect foo) (1 2 2 3 3 4)) (deftest loop.10.13 (loop for x in '(a b nil d nil e) counting x into foo collect foo) (1 2 2 3 3 4)) (deftest loop.10.14 (loop for x in '(a b c) count (return 10)) 10) ;;; Tests of MAXIMIZE, MAXIMIZING (deftest loop.10.20 (loop for x in '(1 4 10 5 7 9) maximize x) 10) (deftest loop.10.21 (loop for x in '(1 4 10 5 7 9) maximizing x) 10) (deftest loop.10.22 (loop for x in '(1000000000000) maximizing x) 1000000000000) (deftest loop.10.23 (loop for x in '(-1000000000000) maximize x) -1000000000000) (deftest loop.10.24 (loop for x in '(1.0 2.0 3.0 -1.0) maximize x) 3.0) (deftest loop.10.25 (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x fixnum) 24) (deftest loop.10.26 (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x of-type integer) 24) (deftest loop.10.27 (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x of-type rational) 24) (deftest loop.10.28 (loop for x in '(1 4 10 5 7 9) maximize x into foo finally (return foo)) 10) (deftest loop.10.29 (let (z) (values (loop for x in '(1 4 10 5 7 9) maximize x into foo finally (setq z foo)) z)) nil 10) (deftest loop.10.30 (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x of-type real) 24) (deftest loop.10.31 (loop for x in '(0.08 0.20 0.05 0.03 0.24 0.01 0.19 0.04 0.20 0.03) maximize x of-type float) 0.24) (deftest loop.10.32 (loop for x in '(-1/8 -1/20 -1/5 -1/3 -1/24 -1/1 -1/19 -1/4 -1/20 -1/3) maximize x of-type rational) -1/24) (deftest loop.10.33 (loop for x in '(1 4 10 5 7 9) maximize x into foo fixnum finally (return foo)) 10) (deftest loop.10.34 (loop for x in '(1 4 10 5 7 9) maximize x into foo of-type integer finally (return foo)) 10) (deftest loop.10.35 (let ((foo 20)) (values (loop for x in '(3 5 8 3 7) maximize x into foo finally (return foo)) foo)) 8 20) (declaim (special *loop-max-var*)) (deftest loop.10.36 (let ((*loop-max-var* 100)) (values (loop for x in '(1 10 4 8) maximize x into *loop-max-var* finally (return *loop-max-var*)) *loop-max-var*)) 10 100) (deftest loop.10.37 (classify-error (loop with foo = 100 for i from 1 to 10 maximize i into foo finally (return foo))) program-error) (deftest loop.10.38 (classify-error (loop with foo = 100 for i from 1 to 10 maximizing i into foo finally (return foo))) program-error) (deftest loop.10.39 (loop for x in '(1 2 3) maximize (return 10)) 10) ;;; Tests of MINIMIZE, MINIMIZING (deftest loop.10.40 (loop for x in '(4 10 1 5 7 9) minimize x) 1) (deftest loop.10.41 (loop for x in '(4 10 5 7 1 9) minimizing x) 1) (deftest loop.10.42 (loop for x in '(1000000000000) minimizing x) 1000000000000) (deftest loop.10.43 (loop for x in '(-1000000000000) minimize x) -1000000000000) (deftest loop.10.44 (loop for x in '(1.0 2.0 -1.0 3.0) minimize x) -1.0) (deftest loop.10.45 (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x fixnum) 1) (deftest loop.10.46 (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x of-type integer) 1) (deftest loop.10.47 (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x of-type rational) 1) (deftest loop.10.48 (loop for x in '(1 4 10 5 7 9) minimize x into foo finally (return foo)) 1) (deftest loop.10.49 (let (z) (values (loop for x in '(4 1 10 1 5 7 9) minimize x into foo finally (setq z foo)) z)) nil 1) (deftest loop.10.50 (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x of-type real) 1) (deftest loop.10.51 (loop for x in '(0.08 0.40 0.05 0.03 0.44 0.01 0.19 0.04 0.40 0.03) minimize x of-type float) 0.01) (deftest loop.10.52 (loop for x in '(-1/8 -1/20 -1/5 -1/3 -1/24 -1/1 -1/19 -1/4 -1/20 -1/3) minimize x of-type rational) -1/1) (deftest loop.10.53 (loop for x in '(4 10 5 1 7 9) minimize x into foo fixnum finally (return foo)) 1) (deftest loop.10.54 (loop for x in '(1 4 10 5 7 9) minimize x into foo of-type integer finally (return foo)) 1) (deftest loop.10.55 (let ((foo 20)) (values (loop for x in '(4 5 8 3 7) minimize x into foo finally (return foo)) foo)) 3 20) (declaim (special *loop-min-var*)) (deftest loop.10.56 (let ((*loop-min-var* 100)) (values (loop for x in '(10 4 8) minimize x into *loop-min-var* finally (return *loop-min-var*)) *loop-min-var*)) 4 100) (deftest loop.10.57 (classify-error (loop with foo = 100 for i from 1 to 10 minimize i into foo finally (return foo))) program-error) (deftest loop.10.58 (classify-error (loop with foo = 100 for i from 1 to 10 minimizing i into foo finally (return foo))) program-error) (deftest loop.10.58a (loop for x in '(1 2 3) minimize (return 10)) 10) ;;; Tests combining MINIMIZE, MAXIMIZE (deftest loop.10.59 (loop for i from 1 to 10 minimize i maximize (- i)) 1) (deftest loop.10.60 (loop for i from 1 to 10 maximize (- i) minimize i) -1) (deftest loop.10.61 (loop for i from 5 downto 1 maximize i minimize (- i)) -1) ;;; Tests for SUM, SUMMING (deftest loop.10.70 (loop for i from 1 to 4 sum i) 10) (deftest loop.10.71 (loop for i from 1 to 4 summing i) 10) (deftest loop.10.72 (loop for i from 1 to 4 sum (float i)) 10.0) (deftest loop.10.73 (loop for i from 1 to 4 sum (complex i i)) #c(10 10)) (deftest loop.10.74 (loop for i from 1 to 4 sum i fixnum) 10) (deftest loop.10.75 (loop for i from 1 to 4 sum i of-type integer) 10) (deftest loop.10.76 (loop for i from 1 to 4 sum i of-type rational) 10) (deftest loop.10.77 (loop for i from 1 to 4 sum (float i) float) 10.0) (deftest loop.10.78 (loop for i from 1 to 4 sum i of-type number) 10) (deftest loop.10.79 (loop for i from 1 to 4 sum i into foo finally (return foo)) 10) (deftest loop.10.80 (loop for i from 1 to 4 sum i into foo fixnum finally (return foo)) 10) (deftest loop.10.81 (let (z) (values (loop for i from 1 to 4 sum i into foo of-type (integer 0 10) finally (setq z foo)) z)) nil 10) (deftest loop.10.82 (loop for i from 1 to 4 sum i fixnum count t) 14) (deftest loop.10.83 (loop for i from 1 to 4 sum i fixnum count t fixnum) 14) (deftest loop.10.84 (let ((foo 100)) (values (loop for i from 1 to 4 sum i into foo of-type integer finally (return foo)) foo)) 10 100) (deftest loop.10.85 (classify-error (loop with foo = 100 for i from 1 to 4 sum i into foo finally (return foo))) program-error) (deftest loop.10.86 (classify-error (loop with foo = 100 for i from 1 to 4 summing i into foo finally (return foo))) program-error) (deftest loop.10.87 (loop for i from 1 to 4 sum (complex i (1+ i)) of-type complex) #c(10 14)) (deftest loop.10.88 (loop for i from 1 to 4 sum (/ i 17) of-type rational) 10/17) (deftest loop.10.89 (loop for i from 1 to 4 summing (/ i 17)) 10/17) (deftest loop.10.90 (loop for i from 1 to 4 sum i into foo sum (1+ i) into bar finally (return (values foo bar))) 10 14) (deftest loop.10.91 (loop for i from 1 to 4 sum i into foo fixnum sum (float (1+ i)) into bar float finally (return (values foo bar))) 10 14.0) (deftest loop.10.92 (loop for i from 1 to 4 sum (return 100)) 100) (deftest loop.10.93 (loop for i from 1 to 4 summing (return 100)) 100) gcl/ansi-tests/loop11.lsp000066400000000000000000000053231242227143400155540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 16 21:39:33 2002 ;;;; Contains: Tests for loop termination clauses REPEAT, WHILE and UNTIL (in-package :cl-test) ;;; Tests of REPEAT (deftest loop.11.1 (let ((z 0)) (values (loop repeat 10 do (incf z)) z)) nil 10) (deftest loop.11.2 (loop repeat 10 collect 'a) (a a a a a a a a a a)) (deftest loop.11.3 (let ((z 0)) (loop repeat 0 do (incf z)) z) 0) (deftest loop.11.4 (let ((z 0)) (loop repeat -1 do (incf z)) z) 0) (deftest loop.11.5 (let ((z 0)) (loop repeat -1.5 do (incf z)) z) 0) (deftest loop.11.6 (let ((z 0)) (loop repeat -1000000000000 do (incf z)) z) 0) (deftest loop.11.7 (let ((z 0)) (loop repeat 10 do (incf z) (loop-finish)) z) 1) (deftest loop.11.8 (loop repeat 3 for i in '(a b c d e) collect i) (a b c)) (deftest loop.11.9 (loop for i in '(a b c d e) collect i repeat 3) (a b c)) ;;; Tests of WHILE (deftest loop.11.10 (loop with i = 0 while (< i 10) collect (incf i)) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.11.11 (loop with i = 0 while (if (< i 10) t (return 'good)) collect (incf i)) good) (deftest loop.11.12 (loop with i = 0 while (< i 10) collect (incf i) while (< i 10) collect (incf i) while (< i 10) collect (incf i)) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.11.13 (loop with i = 0 while (< i 10) collect (incf i) finally (return 'done)) done) (deftest loop.11.14 (loop for i in '(a b c) while nil collect i) nil) (deftest loop.11.15 (loop for i in '(a b c) collect i while nil) (a)) (deftest loop.11.16 (loop for i in '(a b c) while t collect i) (a b c)) (deftest loop.11.17 (loop for i in '(a b c) collect i while t) (a b c)) (deftest loop.11.18 (loop for i from 1 to 10 while (< i 6) finally (return i)) 6) ;;; Tests of UNTIL (deftest loop.11.20 (loop with i = 0 until (>= i 10) collect (incf i)) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.11.21 (loop with i = 0 while (if (< i 10) t (return 'good)) collect (incf i)) good) (deftest loop.11.22 (loop with i = 0 until (>= i 10) collect (incf i) until (>= i 10) collect (incf i) until (>= i 10) collect (incf i)) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.11.23 (loop with i = 0 until (>= i 10) collect (incf i) finally (return 'done)) done) (deftest loop.11.24 (loop for i in '(a b c) until t collect i) nil) (deftest loop.11.25 (loop for i in '(a b c) collect i until t) (a)) (deftest loop.11.26 (loop for i in '(a b c) until nil collect i) (a b c)) (deftest loop.11.27 (loop for i in '(a b c) collect i until nil) (a b c)) (deftest loop.11.28 (loop for i from 1 to 10 until (>= i 6) finally (return i)) 6) gcl/ansi-tests/loop12.lsp000066400000000000000000000072311242227143400155550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Nov 17 08:47:43 2002 ;;;; Contains: Tests for ALWAYS, NEVER, THEREIS (in-package :cl-test) ;;; Tests of ALWAYS clauses (deftest loop.12.1 (loop for i in '(1 2 3 4) always (< i 10)) t) (deftest loop.12.2 (loop for i in nil always nil) t) (deftest loop.12.3 (loop for i in '(a) always nil) nil) (deftest loop.12.4 (loop for i in '(1 2 3 4 5 6 7) always t until (> i 5)) t) (deftest loop.12.5 (loop for i in '(1 2 3 4 5 6 7) always (< i 6) until (>= i 5)) t) (deftest loop.12.6 (loop for x in '(a b c d e) always x) t) (deftest loop.12.7 (loop for x in '(1 2 3 4 5 6) always (< x 20) never (> x 10)) t) (deftest loop.12.8 (loop for x in '(1 2 3 4 5 6) always (< x 20) never (> x 5)) nil) (deftest loop.12.9 (loop for x in '(1 2 3 4 5 6) never (> x 5) always (< x 20)) nil) (deftest loop.12.10 (loop for x in '(1 2 3 4 5) always (< x 10) finally (return 'good)) good) (deftest loop.12.11 (loop for x in '(1 2 3 4 5) always (< x 3) finally (return 'bad)) nil) (deftest loop.12.12 (loop for x in '(1 2 3 4 5 6) always t when (= x 4) do (loop-finish)) t) (deftest loop.12.13 (loop for x in '(1 2 3 4 5 6) do (loop-finish) always nil) t) ;;; Tests of NEVER (deftest loop.12.21 (loop for i in '(1 2 3 4) never (> i 10)) t) (deftest loop.12.22 (loop for i in nil never t) t) (deftest loop.12.23 (loop for i in '(a) never t) nil) (deftest loop.12.24 (loop for i in '(1 2 3 4 5 6 7) never nil until (> i 5)) t) (deftest loop.12.25 (loop for i in '(1 2 3 4 5 6 7) never (>= i 6) until (>= i 5)) t) (deftest loop.12.26 (loop for x in '(a b c d e) never (not x)) t) (deftest loop.12.30 (loop for x in '(1 2 3 4 5) never (>= x 10) finally (return 'good)) good) (deftest loop.12.31 (loop for x in '(1 2 3 4 5) never (>= x 3) finally (return 'bad)) nil) (deftest loop.12.32 (loop for x in '(1 2 3 4 5 6) never nil when (= x 4) do (loop-finish)) t) (deftest loop.12.33 (loop for x in '(1 2 3 4 5 6) do (loop-finish) never t) t) ;;; Tests of THEREIS (deftest loop.12.41 (loop for x in '(1 2 3 4 5) thereis (and (eqlt x 3) 'good)) good) (deftest loop.12.42 (loop for x in '(nil nil a nil nil) thereis x) a) (deftest loop.12.43 (loop for x in '(1 2 3 4 5) thereis (eql x 4) when (eql x 2) do (loop-finish)) nil) ;;; Error cases (deftest loop.12.error.50 (classify-error (loop for i from 1 to 10 collect i always (< i 20))) program-error) (deftest loop.12.error.50a (classify-error (loop for i from 1 to 10 always (< i 20) collect i)) program-error) (deftest loop.12.error.51 (classify-error (loop for i from 1 to 10 collect i never (> i 20))) program-error) (deftest loop.12.error.51a (classify-error (loop for i from 1 to 10 never (> i 20) collect i)) program-error) (deftest loop.12.error.52 (classify-error (loop for i from 1 to 10 collect i thereis (> i 20))) program-error) (deftest loop.12.error.52a (classify-error (loop for i from 1 to 10 thereis (> i 20) collect i)) program-error) ;;; Non-error cases (deftest loop.12.53 (loop for i from 1 to 10 collect i into foo always (< i 20)) t) (deftest loop.12.53a (loop for i from 1 to 10 always (< i 20) collect i into foo) t) (deftest loop.12.54 (loop for i from 1 to 10 collect i into foo never (> i 20)) t) (deftest loop.12.54a (loop for i from 1 to 10 never (> i 20) collect i into foo) t) (deftest loop.12.55 (loop for i from 1 to 10 collect i into foo thereis i) 1) (deftest loop.12.55a (loop for i from 1 to 10 thereis i collect i into foo) 1) gcl/ansi-tests/loop13.lsp000066400000000000000000000212531242227143400155560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Nov 17 12:37:45 2002 ;;;; Contains: Tests of DO, DOING, RETURN in LOOP. Tests of NAMED loops (in-package :cl-test) (deftest loop.13.1 (loop do (return 10)) 10) (deftest loop.13.2 (loop doing (return 10)) 10) (deftest loop.13.3 (loop for i from 0 below 100 by 7 when (> i 50) return i) 56) (deftest loop.13.4 (let ((x 0)) (loop do (incf x) (when (= x 10) (return x)))) 10) (deftest loop.13.5 (loop return 'a) a) (deftest loop.13.6 (loop return (values))) (deftest loop.13.7 (loop return (values 1 2)) 1 2) (deftest loop.13.8 (let* ((limit (min 1000 (1- multiple-values-limit))) (vals (make-list limit :initial-element :a)) (vals2 (multiple-value-list (eval `(loop return (values ,@vals)))))) (equalt vals vals2)) t) (deftest loop.13.9 (loop named foo return 'a) a) (deftest loop.13.10 (block nil (return (loop named foo return :good)) :bad) :good) (deftest loop.13.11 (block nil (loop named foo do (return :good)) :bad) :good) (deftest loop.13.12 (loop named foo with a = (return-from foo :good) return :bad) :good) (deftest loop.13.13 (loop named foo with b = 1 and a = (return-from foo :good) return :bad) :good) (deftest loop.13.14 (loop named foo for a = (return-from foo :good) return :bad) :good) (deftest loop.13.15 (loop named foo for a in (return-from foo :good)) :good) (deftest loop.13.16 (loop named foo for a from (return-from foo :good) return :bad) :good) (deftest loop.13.17 (loop named foo for a on (return-from foo :good) return :bad) :good) (deftest loop.13.18 (loop named foo for a across (return-from foo :good) return :bad) :good) (deftest loop.13.19 (loop named foo for a being the hash-keys of (return-from foo :good) return :bad) :good) (deftest loop.13.20 (loop named foo for a being the symbols of (return-from foo :good) return :bad) :good) (deftest loop.13.21 (loop named foo repeat (return-from foo :good) return :bad) :good) (deftest loop.13.22 (loop named foo for i from 0 to (return-from foo :good) return :bad) :good) (deftest loop.13.23 (loop named foo for i from 0 to 10 by (return-from foo :good) return :bad) :good) (deftest loop.13.24 (loop named foo for i from 10 downto (return-from foo :good) return :bad) :good) (deftest loop.13.25 (loop named foo for i from 10 above (return-from foo :good) return :bad) :good) (deftest loop.13.26 (loop named foo for i from 10 below (return-from foo :good) return :bad) :good) (deftest loop.13.27 (loop named foo for i in '(a b c) by (return-from foo :good) return :bad) :good) (deftest loop.13.28 (loop named foo for i on '(a b c) by (return-from foo :good) return :bad) :good) (deftest loop.13.29 (loop named foo for i = 1 then (return-from foo :good)) :good) (deftest loop.13.30 (loop named foo for x in '(a b c) collect (return-from foo :good)) :good) (deftest loop.13.31 (loop named foo for x in '(a b c) append (return-from foo :good)) :good) (deftest loop.13.32 (loop named foo for x in '(a b c) nconc (return-from foo :good)) :good) (deftest loop.13.33 (loop named foo for x in '(a b c) count (return-from foo :good)) :good) (deftest loop.13.34 (loop named foo for x in '(a b c) sum (return-from foo :good)) :good) (deftest loop.13.35 (loop named foo for x in '(a b c) maximize (return-from foo :good)) :good) (deftest loop.13.36 (loop named foo for x in '(a b c) minimize (return-from foo :good)) :good) (deftest loop.13.37 (loop named foo for x in '(a b c) thereis (return-from foo :good)) :good) (deftest loop.13.38 (loop named foo for x in '(a b c) always (return-from foo :good)) :good) (deftest loop.13.39 (loop named foo for x in '(a b c) never (return-from foo :good)) :good) (deftest loop.13.40 (loop named foo for x in '(a b c) until (return-from foo :good)) :good) (deftest loop.13.41 (loop named foo for x in '(a b c) while (return-from foo :good)) :good) (deftest loop.13.42 (loop named foo for x in '(a b c) when (return-from foo :good) return :bad) :good) (deftest loop.13.43 (loop named foo for x in '(a b c) unless (return-from foo :good) return :bad) :good) (deftest loop.13.44 (loop named foo for x in '(a b c) if (return-from foo :good) return :bad) :good) (deftest loop.13.45 (loop named foo for x in '(a b c) return (return-from foo :good)) :good) (deftest loop.13.46 (loop named foo initially (return-from foo :good) return :bad) :good) (deftest loop.13.47 (loop named foo do (loop-finish) finally (return-from foo :good)) :good) (deftest loop.13.52 (block nil (loop named foo with a = (return :good) return :bad) :bad) :good) (deftest loop.13.53 (block nil (loop named foo with b = 1 and a = (return :good) return :bad) :bad) :good) (deftest loop.13.54 (block nil (loop named foo for a = (return :good) return :bad) :bad) :good) (deftest loop.13.55 (block nil (loop named foo for a in (return :good)) :bad) :good) (deftest loop.13.56 (block nil (loop named foo for a from (return :good) return :bad) :bad) :good) (deftest loop.13.57 (block nil (loop named foo for a on (return :good) return :bad) :bad) :good) (deftest loop.13.58 (block nil (loop named foo for a across (return :good) return :bad) :bad) :good) (deftest loop.13.59 (block nil (loop named foo for a being the hash-keys of (return :good) return :bad) :bad) :good) (deftest loop.13.60 (block nil (loop named foo for a being the symbols of (return :good) return :bad) :bad) :good) (deftest loop.13.61 (block nil (loop named foo repeat (return :good) return :bad) :bad) :good) (deftest loop.13.62 (block nil (loop named foo for i from 0 to (return :good) return :bad) :bad) :good) (deftest loop.13.63 (block nil (loop named foo for i from 0 to 10 by (return :good) return :bad) :bad) :good) (deftest loop.13.64 (block nil (loop named foo for i from 10 downto (return :good) return :bad) :bad) :good) (deftest loop.13.65 (block nil (loop named foo for i from 10 above (return :good) return :bad) :bad) :good) (deftest loop.13.66 (block nil (loop named foo for i from 10 below (return :good) return :bad) :bad) :good) (deftest loop.13.67 (block nil (loop named foo for i in '(a b c) by (return :good) return :bad) :bad) :good) (deftest loop.13.68 (block nil (loop named foo for i on '(a b c) by (return :good) return :bad) :bad) :good) (deftest loop.13.69 (block nil (loop named foo for i = 1 then (return :good)) :bad) :good) (deftest loop.13.70 (block nil (loop named foo for x in '(a b c) collect (return :good)) :bad) :good) (deftest loop.13.71 (block nil (loop named foo for x in '(a b c) append (return :good)) :bad) :good) (deftest loop.13.72 (block nil (loop named foo for x in '(a b c) nconc (return :good)) :bad) :good) (deftest loop.13.73 (block nil (loop named foo for x in '(a b c) count (return :good)) :bad) :good) (deftest loop.13.74 (block nil (loop named foo for x in '(a b c) sum (return :good)) :bad) :good) (deftest loop.13.75 (block nil (loop named foo for x in '(a b c) maximize (return :good)) :bad) :good) (deftest loop.13.76 (block nil (loop named foo for x in '(a b c) minimize (return :good)) :bad) :good) (deftest loop.13.77 (block nil (loop named foo for x in '(a b c) thereis (return :good)) :bad) :good) (deftest loop.13.78 (block nil (loop named foo for x in '(a b c) always (return :good)) :bad) :good) (deftest loop.13.79 (block nil (loop named foo for x in '(a b c) never (return :good)) :bad) :good) (deftest loop.13.80 (block nil (loop named foo for x in '(a b c) until (return :good)) :bad) :good) (deftest loop.13.81 (block nil (loop named foo for x in '(a b c) while (return :good)) :bad) :good) (deftest loop.13.82 (block nil (loop named foo for x in '(a b c) when (return :good) return :bad) :bad) :good) (deftest loop.13.83 (block nil (loop named foo for x in '(a b c) unless (return :good) return :bad) :bad) :good) (deftest loop.13.84 (block nil (loop named foo for x in '(a b c) if (return :good) return :bad) :bad) :good) (deftest loop.13.85 (block nil (loop named foo for x in '(a b c) return (return :good)) :bad) :good) (deftest loop.13.86 (block nil (loop named foo initially (return :good) return :bad) :bad) :good) (deftest loop.13.87 (block nil (loop named foo do (loop-finish) finally (return :good)) :bad) :good) gcl/ansi-tests/loop14.lsp000066400000000000000000000147711242227143400155660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Nov 20 06:33:21 2002 ;;;; Contains: Tests of LOOP conditional execution clauses (in-package :cl-test) (deftest loop.14.1 (loop for x from 1 to 6 when (evenp x) collect x) (2 4 6)) (deftest loop.14.2 (loop for x from 1 to 6 unless (evenp x) collect x) (1 3 5)) (deftest loop.14.3 (loop for x from 1 to 10 when (evenp x) collect x into foo and count t into bar finally (return (values foo bar))) (2 4 6 8 10) 5) (deftest loop.14.4 (loop for x from 1 to 10 when (evenp x) collect x end) (2 4 6 8 10)) (deftest loop.14.5 (loop for x from 1 to 10 when (evenp x) collect x into evens else collect x into odds end finally (return (values evens odds))) (2 4 6 8 10) (1 3 5 7 9)) (deftest loop.14.6 (loop for x from 1 to 10 unless (oddp x) collect x into foo and count t into bar finally (return (values foo bar))) (2 4 6 8 10) 5) (deftest loop.14.7 (loop for x from 1 to 10 unless (oddp x) collect x end) (2 4 6 8 10)) (deftest loop.14.8 (loop for x from 1 to 10 unless (oddp x) collect x into evens else collect x into odds end finally (return (values evens odds))) (2 4 6 8 10) (1 3 5 7 9)) (deftest loop.14.9 (loop for x from 1 to 6 if (evenp x) collect x) (2 4 6)) (deftest loop.14.10 (loop for x from 1 to 10 if (evenp x) collect x into foo and count t into bar finally (return (values foo bar))) (2 4 6 8 10) 5) (deftest loop.14.11 (loop for x from 1 to 10 if (evenp x) collect x end) (2 4 6 8 10)) (deftest loop.14.12 (loop for x from 1 to 10 if (evenp x) collect x into evens else collect x into odds end finally (return (values evens odds))) (2 4 6 8 10) (1 3 5 7 9)) ;;; Test that else associates with the nearest conditional unclosed ;;; by end (deftest loop.14.13 (loop for i from 1 to 20 if (evenp i) if (= (mod i 3) 0) collect i into list1 else collect i into list2 finally (return (values list1 list2))) (6 12 18) (2 4 8 10 14 16 20)) (deftest loop.14.14 (loop for i from 1 to 20 when (evenp i) if (= (mod i 3) 0) collect i into list1 else collect i into list2 finally (return (values list1 list2))) (6 12 18) (2 4 8 10 14 16 20)) (deftest loop.14.15 (loop for i from 1 to 20 if (evenp i) when (= (mod i 3) 0) collect i into list1 else collect i into list2 finally (return (values list1 list2))) (6 12 18) (2 4 8 10 14 16 20)) (deftest loop.14.16 (loop for i from 1 to 20 if (evenp i) if (= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.17 (loop for i from 1 to 20 when (evenp i) if (= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.18 (loop for i from 1 to 20 if (evenp i) when (= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.19 (loop for i from 1 to 20 when (evenp i) when (= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.20 (loop for i from 1 to 20 unless (oddp i) if (= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.21 (loop for i from 1 to 20 if (evenp i) unless (/= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.22 (loop for i from 1 to 20 unless (oddp i) unless (/= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) ;;; More tests conditionals (deftest loop.14.23 (loop for i from 1 to 20 if (evenp i) collect i into list1 else if (= (mod i 3) 0) collect i into list2 else collect i into list3 finally (return (values list1 list2 list3))) (2 4 6 8 10 12 14 16 18 20) (3 9 15) (1 5 7 11 13 17 19)) ;;; Tests of 'IT' (deftest loop.14.24 (loop for x in '((a) nil (b) (c) (nil) (d)) when (car x) collect it) (a b c d)) (deftest loop.14.25 (loop for x in '((a) nil (b) (c) (nil) (d)) if (car x) collect it) (a b c d)) (deftest loop.14.26 (loop for x in '(nil (a) nil (b) (c) (nil) (d)) when (car x) return it) a) (deftest loop.14.27 (loop for x in '(nil (a) nil (b) (c) (nil) (d)) if (car x) return it) a) (deftest loop.14.28 (loop for x in '((a) nil (b) (c) (nil) (d)) when (car x) collect it and collect 'foo) (a foo b foo c foo d foo)) (deftest loop.14.29 (let ((it 'z)) (loop for x in '(a b c d) when x collect it and collect it)) (a z b z c z d z)) (deftest loop.14.30 (let ((it 'z)) (loop for x in '(a b c d) if x collect it end collect it)) (a z b z c z d z)) (deftest loop.14.31 (loop for it on '(a b c d) when (car it) collect it) (a b c d)) (deftest loop.14.32 (loop for x in '(a b nil c d nil e) when x collecting it) (a b c d e)) (deftest loop.14.33 (loop for x in '(a b nil c d nil e) when x append (list x)) (a b c d e)) (deftest loop.14.34 (loop for x in '(a b nil c d nil e) when x appending (list x)) (a b c d e)) (deftest loop.14.35 (loop for x in '(a b nil c d nil e) when x nconc (list x)) (a b c d e)) (deftest loop.14.36 (loop for x in '(a b nil c d nil e) when x nconcing (list x)) (a b c d e)) (deftest loop.14.37 (loop for it on '(a b c d) when (car it) collect it into foo finally (return foo)) (a b c d)) (deftest loop.14.38 (loop for x in '(1 2 nil 3 4 nil 5 nil) when x count it) 5) (deftest loop.14.39 (loop for x in '(1 2 nil 3 4 nil 5 nil) when x counting it) 5) (deftest loop.14.40 (loop for x in '(1 2 nil 3 4 nil 6 nil) when x maximize it) 6) (deftest loop.14.41 (loop for x in '(1 2 nil 3 4 nil 6 nil) when x maximizing it) 6) (deftest loop.14.42 (loop for x in '(1 2 nil 3 4 nil 6 nil) when x minimize it) 1) (deftest loop.14.43 (loop for x in '(1 2 nil 3 4 nil 6 nil) when x minimizing it) 1) (deftest loop.14.44 (loop for x in '(1 2 nil 3 4 nil 6 nil) when x sum it) 16) (deftest loop.14.45 (loop for x in '(1 2 nil 3 4 nil 6 nil) when x summing it) 16) gcl/ansi-tests/loop15.lsp000066400000000000000000000117611242227143400155630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 21 07:08:21 2002 ;;;; Contains: Tests that keywords can be loop keywords (in-package :cl-test) ;;; Tests of loop keywords (deftest loop.15.30 (loop :for i :from 1 :to 10 :collect i) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.15.31 (loop :for i :upfrom 1 :below 10 :by 2 :collect i) (1 3 5 7 9)) (deftest loop.15.32 (loop :with x = 1 :and y = 2 :return (values x y)) 1 2) (deftest loop.15.33 (loop :named foo :doing (return-from foo 1)) 1) (deftest loop.15.34 (let ((x 0)) (loop :initially (setq x 2) :until t :finally (return x))) 2) (deftest loop.15.35 (loop :for x :in '(a b c) :collecting x) (a b c)) (deftest loop.15.36 (loop :for x :in '(a b c) :append (list x)) (a b c)) (deftest loop.15.37 (loop :for x :in '(a b c) :appending (list x)) (a b c)) (deftest loop.15.38 (loop :for x :in '(a b c) :nconc (list x)) (a b c)) (deftest loop.15.39 (loop :for x :in '(a b c) :nconcing (list x)) (a b c)) (deftest loop.15.40 (loop :for x :in '(1 2 3) :count x) 3) (deftest loop.15.41 (loop :for x :in '(1 2 3) :counting x) 3) (deftest loop.15.42 (loop :for x :in '(1 2 3) :sum x) 6) (deftest loop.15.43 (loop :for x :in '(1 2 3) :summing x) 6) (deftest loop.15.44 (loop :for x :in '(10 20 30) :maximize x) 30) (deftest loop.15.45 (loop :for x :in '(10 20 30) :maximizing x) 30) (deftest loop.15.46 (loop :for x :in '(10 20 30) :minimize x) 10) (deftest loop.15.47 (loop :for x :in '(10 20 30) :minimizing x) 10) (deftest loop.15.48 (loop :for x :in '(1 2 3 4) :sum x :into foo :of-type fixnum :finally (return foo)) 10) (deftest loop.15.49 (loop :for x :upfrom 1 :to 10 :if (evenp x) :sum x :into foo :else :sum x :into bar :end :finally (return (values foo bar))) 30 25) (deftest loop.15.50 (loop :for x :downfrom 10 :above 0 :when (evenp x) :sum x :into foo :else :sum x :into bar :end :finally (return (values foo bar))) 30 25) (deftest loop.15.51 (loop :for x :in '(a b nil c d nil) :unless x :count t) 2) (deftest loop.15.52 (loop :for x :in '(a b nil c d nil) :unless x :collect x :into bar :and :count t :into foo :end finally (return (values bar foo))) (nil nil) 2) (deftest loop.15.53 (loop :for x :in '(nil nil a b nil c nil) :collect x :until x) (nil nil a)) (deftest loop.15.54 (loop :for x :in '(a b nil c nil) :while x :collect x) (a b)) (deftest loop.15.55 (loop :for x :in '(nil nil a b nil c nil) :thereis x) a) (deftest loop.15.56 (loop :for x :in '(nil nil a b nil c nil) :never x) nil) (deftest loop.15.57 (loop :for x :in '(a b c d e) :always x) t) (deftest loop.15.58 (loop :as x :in '(a b c) :count t) 3) (deftest loop.15.59 (loop :for i :from 10 :downto 5 :collect i) (10 9 8 7 6 5)) (deftest loop.15.60 (loop :for i :from 0 :upto 5 :collect i) (0 1 2 3 4 5)) (deftest loop.15.61 (loop :for x :on '(a b c) :collecting (car x)) (a b c)) (deftest loop.15.62 (loop :for x = '(a b c) :then (cdr x) :while x :collect (car x)) (a b c)) (deftest loop.15.63 (loop :for x :across #(a b c) :collect x) (a b c)) (deftest loop.15.64 (loop :for x :being :the :hash-keys :of (make-hash-table) :count t) 0) (deftest loop.15.65 (loop :for x :being :each :hash-key :in (make-hash-table) :count t) 0) (deftest loop.15.66 (loop :for x :being :each :hash-value :of (make-hash-table) :count t) 0) (deftest loop.15.67 (loop :for x :being :the :hash-values :in (make-hash-table) :count t) 0) (deftest loop.15.68 (loop :for x :being :the :hash-values :in (make-hash-table) :using (:hash-key k) :count t) 0) (deftest loop.15.69 (loop :for x :being :the :hash-keys :in (make-hash-table) :using (:hash-value v) :count t) 0) (deftest loop.15.70 (progn (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :the :symbols :of p :count t))) 0) (deftest loop.15.71 (progn (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :each :symbol :of p :count t))) 0) (deftest loop.15.72 (progn (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :the :external-symbols :of p :count t))) 0) (deftest loop.15.73 (progn (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :each :external-symbol :of p :count t))) 0) (deftest loop.15.74 (progn (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :the :present-symbols :of p :count t))) 0) (deftest loop.15.75 (progn (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :each :present-symbol :of p :count t))) 0) gcl/ansi-tests/loop16.lsp000066400000000000000000000122561242227143400155640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 21 09:46:27 2002 ;;;; Contains: Tests that uninterned symbols can be loop keywords (in-package :cl-test) (deftest loop.16.30 (loop #:for i #:from 1 #:to 10 #:collect i) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.16.31 (loop #:for i #:upfrom 1 #:below 10 #:by 2 #:collect i) (1 3 5 7 9)) (deftest loop.16.32 (loop #:with x = 1 #:and y = 2 #:return (values x y)) 1 2) (deftest loop.16.33 (loop #:named foo #:doing (return-from foo 1)) 1) (deftest loop.16.34 (let ((x 0)) (loop #:initially (setq x 2) #:until t #:finally (return x))) 2) (deftest loop.16.35 (loop #:for x #:in '(a b c) #:collecting x) (a b c)) (deftest loop.16.36 (loop #:for x #:in '(a b c) #:append (list x)) (a b c)) (deftest loop.16.37 (loop #:for x #:in '(a b c) #:appending (list x)) (a b c)) (deftest loop.16.38 (loop #:for x #:in '(a b c) #:nconc (list x)) (a b c)) (deftest loop.16.39 (loop #:for x #:in '(a b c) #:nconcing (list x)) (a b c)) (deftest loop.16.40 (loop #:for x #:in '(1 2 3) #:count x) 3) (deftest loop.16.41 (loop #:for x #:in '(1 2 3) #:counting x) 3) (deftest loop.16.42 (loop #:for x #:in '(1 2 3) #:sum x) 6) (deftest loop.16.43 (loop #:for x #:in '(1 2 3) #:summing x) 6) (deftest loop.16.44 (loop #:for x #:in '(10 20 30) #:maximize x) 30) (deftest loop.16.45 (loop #:for x #:in '(10 20 30) #:maximizing x) 30) (deftest loop.16.46 (loop #:for x #:in '(10 20 30) #:minimize x) 10) (deftest loop.16.47 (loop #:for x #:in '(10 20 30) #:minimizing x) 10) (deftest loop.16.48 (loop #:for x #:in '(1 2 3 4) #:sum x #:into foo #:of-type fixnum #:finally (return foo)) 10) (deftest loop.16.49 (loop #:for x #:upfrom 1 #:to 10 #:if (evenp x) #:sum x #:into foo #:else #:sum x #:into bar #:end #:finally (return (values foo bar))) 30 25) (deftest loop.16.50 (loop #:for x #:downfrom 10 #:above 0 #:when (evenp x) #:sum x #:into foo #:else #:sum x #:into bar #:end #:finally (return (values foo bar))) 30 25) (deftest loop.16.51 (loop #:for x #:in '(a b nil c d nil) #:unless x #:count t) 2) (deftest loop.16.52 (loop #:for x #:in '(a b nil c d nil) #:unless x #:collect x #:into bar #:and #:count t #:into foo #:end finally (return (values bar foo))) (nil nil) 2) (deftest loop.16.53 (loop #:for x #:in '(nil nil a b nil c nil) #:collect x #:until x) (nil nil a)) (deftest loop.16.54 (loop #:for x #:in '(a b nil c nil) #:while x #:collect x) (a b)) (deftest loop.16.55 (loop #:for x #:in '(nil nil a b nil c nil) #:thereis x) a) (deftest loop.16.56 (loop #:for x #:in '(nil nil a b nil c nil) #:never x) nil) (deftest loop.16.57 (loop #:for x #:in '(a b c d e) #:always x) t) (deftest loop.16.58 (loop #:as x #:in '(a b c) #:count t) 3) (deftest loop.16.59 (loop #:for i #:from 10 #:downto 5 #:collect i) (10 9 8 7 6 5)) (deftest loop.16.60 (loop #:for i #:from 0 #:upto 5 #:collect i) (0 1 2 3 4 5)) (deftest loop.16.61 (loop #:for x #:on '(a b c) #:collecting (car x)) (a b c)) (deftest loop.16.62 (loop #:for x = '(a b c) #:then (cdr x) #:while x #:collect (car x)) (a b c)) (deftest loop.16.63 (loop #:for x #:across #(a b c) #:collect x) (a b c)) (deftest loop.16.64 (loop #:for x #:being #:the #:hash-keys #:of (make-hash-table) #:count t) 0) (deftest loop.16.65 (loop #:for x #:being #:each #:hash-key #:in (make-hash-table) #:count t) 0) (deftest loop.16.66 (loop #:for x #:being #:each #:hash-value #:of (make-hash-table) #:count t) 0) (deftest loop.16.67 (loop #:for x #:being #:the #:hash-values #:in (make-hash-table) #:count t) 0) (deftest loop.16.68 (loop #:for x #:being #:the #:hash-values #:in (make-hash-table) #:using (#:hash-key k) #:count t) 0) (deftest loop.16.69 (loop #:for x #:being #:the #:hash-keys #:in (make-hash-table) #:using (#:hash-value v) #:count t) 0) (deftest loop.16.70 (progn (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:the #:symbols #:of p #:count t))) 0) (deftest loop.16.71 (progn (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:each #:symbol #:of p #:count t))) 0) (deftest loop.16.72 (progn (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:the #:external-symbols #:of p #:count t))) 0) (deftest loop.16.73 (progn (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:each #:external-symbol #:of p #:count t))) 0) (deftest loop.16.74 (progn (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:the #:present-symbols #:of p #:count t))) 0) (deftest loop.16.75 (progn (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:each #:present-symbol #:of p #:count t))) 0) gcl/ansi-tests/loop17.lsp000066400000000000000000000041221242227143400155560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 21 09:48:38 2002 ;;;; Contains: Miscellaneous loop tests (in-package :cl-test) ;;; Initially and finally take multiple forms, ;;; and execute them in the right order (deftest loop.17.1 (loop with x = 0 initially (incf x 1) (incf x (+ x x)) initially (incf x (+ x x x)) until t finally (incf x 100) (incf x (+ x x)) finally (return x)) 336) (deftest loop.17.2 (loop with x = 0 until t initially (incf x 1) (incf x (+ x x)) finally (incf x 100) (incf x (+ x x)) initially (incf x (+ x x x)) finally (return x)) 336) (deftest loop.17.3 (let ((x 0)) (loop with y = (incf x 1) initially (incf x 2) until t finally (return (values x y)))) 3 1) (deftest loop.17.4 (loop doing (return 'a) finally (return 'b)) a) (deftest loop.17.5 (loop return 'a finally (return 'b)) a) (deftest loop.17.6 (let ((x 0)) (tagbody (loop do (go done) finally (incf x)) done) x) 0) (deftest loop.17.7 (let ((x 0)) (catch 'done (loop do (throw 'done nil) finally (incf x))) x) 0) (deftest loop.17.8 (loop for x in '(1 2 3) collect x finally (return 'good)) good) (deftest loop.17.9 (loop for x in '(1 2 3) append (list x) finally (return 'good)) good) (deftest loop.17.10 (loop for x in '(1 2 3) nconc (list x) finally (return 'good)) good) (deftest loop.17.11 (loop for x in '(1 2 3) count (> x 1) finally (return 'good)) good) (deftest loop.17.12 (loop for x in '(1 2 3) sum x finally (return 'good)) good) (deftest loop.17.13 (loop for x in '(1 2 3) maximize x finally (return 'good)) good) (deftest loop.17.14 (loop for x in '(1 2 3) minimize x finally (return 'good)) good) ;;; iteration clause grouping (deftest loop.17.20 (loop for i from 1 to 5 for j = 0 then (+ j i) collect j) (0 2 5 9 14)) (deftest loop.17.21 (loop for i from 1 to 5 and j = 0 then (+ j i) collect j) (0 1 3 6 10)) gcl/ansi-tests/loop2.lsp000066400000000000000000000052121242227143400154710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 26 13:45:45 2002 ;;;; Contains: Tests of the FOR-AS-IN-LIST loop iteration control form, ;;;; and of destructuring in loop forms (in-package :cl-test) (deftest loop.2.1 (loop for x in '(1 2 3) sum x) 6) (deftest loop.2.2 (loop for x in '(1 2 3 4) do (when (evenp x) (return x))) 2) (deftest loop.2.3 (classify-error (loop for x in '(a . b) collect x)) type-error) (deftest loop.2.4 (let ((x nil)) (loop for e in '(a b c d) do (push e x)) x) (d c b a)) (deftest loop.2.5 (loop for e in '(a b c d e f) by #'cddr collect e) (a c e)) (deftest loop.2.6 (loop for e in '(a b c d e f g) by #'cddr collect e) (a c e g)) (deftest loop.2.7 (loop for e in '(a b c d e f) by #'(lambda (l) (and (cdr l) (cons (car l) (cddr l)))) collect e) (a a a a a a)) (deftest loop.2.8 (loop for (x . y) in '((a . b) (c . d) (e . f)) collect (list x y)) ((a b) (c d) (e f))) (deftest loop.2.9 (loop for (x nil y) in '((a b c) (d e f) (g h i)) collect (list x y)) ((a c) (d f) (g i))) (deftest loop.2.10 (loop for (x y) of-type fixnum in '((1 2) (3 4) (5 6)) collect (+ x y)) (3 7 11)) (deftest loop.2.11 (loop for (x y) of-type fixnum in '((1 2) (3 4) (5 6)) collect (+ x y)) (3 7 11)) (deftest loop.2.12 (loop for (x y) of-type (fixnum fixnum) in '((1 2) (3 4) (5 6)) collect (+ x y)) (3 7 11)) (deftest loop.2.13 (loop for (x . y) of-type (fixnum . fixnum) in '((1 . 2) (3 . 4) (5 . 6)) collect (+ x y)) (3 7 11)) (deftest loop.2.14 (classify-error (loop for x in '(a b c) for x in '(d e f) collect x)) program-error) (deftest loop.2.15 (classify-error (loop for (x . x) in '((a b) (c d)) collect x)) program-error) (deftest loop.2.16 (loop for nil in nil do (return t)) nil) (deftest loop.2.17 (let ((x '(a b c))) (values x (loop for x in '(d e f) collect (list x)) x)) (a b c) ((d) (e) (f)) (a b c)) (deftest loop.2.18 (loop for x of-type (integer 0 10) in '(2 4 6 7) sum x) 19) ;;; Tests of the 'AS' form (deftest loop.2.19 (loop as x in '(1 2 3) sum x) 6) (deftest loop.2.20 (loop as x in '(a b c) as y in '(1 2 3) collect (list x y)) ((a 1) (b 2) (c 3))) (deftest loop.2.21 (loop as x in '(a b c) for y in '(1 2 3) collect (list x y)) ((a 1) (b 2) (c 3))) (deftest loop.2.22 (loop for x in '(a b c) as y in '(1 2 3) collect (list x y)) ((a 1) (b 2) (c 3))) (deftest loop.2.23 (let (a b (i 0)) (values (loop for e in (progn (setf a (incf i)) '(a b c d e f g)) by (progn (setf b (incf i)) #'cddr) collect e) a b i)) (a c e g) 1 2 2) gcl/ansi-tests/loop3.lsp000066400000000000000000000052731242227143400155010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 27 08:36:36 2002 ;;;; Contains: Tests of FOR-ON-AS-LIST iteration control in LOOP (in-package :cl-test) (deftest loop.3.1 (loop for x on '(1 2 3) sum (car x)) 6) (deftest loop.3.2 (loop for x on '(1 2 3 4) do (when (evenp (car x)) (return x))) (2 3 4)) (deftest loop.3.3 (loop for x on '(a b c . d) collect (car x)) (a b c)) (deftest loop.3.4 (let ((x nil)) (loop for e on '(a b c d) do (push (car e) x)) x) (d c b a)) (deftest loop.3.5 (loop for e on '(a b c d e f) by #'cddr collect (car e)) (a c e)) (deftest loop.3.6 (loop for e on '(a b c d e f g) by #'cddr collect (car e)) (a c e g)) (deftest loop.3.7 (loop for e on '(a b c d e f) by #'(lambda (l) (and (cdr l) (cons (car l) (cddr l)))) collect (car e)) (a a a a a a)) (deftest loop.3.8 (loop for ((x . y)) on '((a . b) (c . d) (e . f)) collect (list x y)) ((a b) (c d) (e f))) (deftest loop.3.9 (loop for ((x nil y)) on '((a b c) (d e f) (g h i)) collect (list x y)) ((a c) (d f) (g i))) (deftest loop.3.10 (loop for ((x y)) of-type (fixnum) on '((1 2) (3 4) (5 6)) collect (+ x y)) (3 7 11)) (deftest loop.3.11 (loop for ((x y)) of-type (fixnum) on '((1 2) (3 4) (5 6)) collect (+ x y)) (3 7 11)) (deftest loop.3.12 (loop for ((x y)) of-type ((fixnum fixnum)) on '((1 2) (3 4) (5 6)) collect (+ x y)) (3 7 11)) (deftest loop.3.13 (loop for ((x . y)) of-type ((fixnum . fixnum)) on '((1 . 2) (3 . 4) (5 . 6)) collect (+ x y)) (3 7 11)) (deftest loop.3.14 (classify-error (loop for x on '(a b c) for x on '(d e f) collect x)) program-error) (deftest loop.3.15 (classify-error (loop for (x . x) on '((a b) (c d)) collect x)) program-error) (deftest loop.3.16 (loop for nil on nil do (return t)) nil) (deftest loop.3.17 (let ((x '(a b c))) (values x (loop for x on '(d e f) collect x) x)) (a b c) ((d e f) (e f) (f)) (a b c)) (deftest loop.3.18 (loop for (x) of-type ((integer 0 10)) on '(2 4 6 7) sum x) 19) ;;; Tests of the 'AS' form (deftest loop.3.19 (loop as x on '(1 2 3) sum (car x)) 6) (deftest loop.3.20 (loop as x on '(a b c) as y on '(1 2 3) collect (list (car x) (car y))) ((a 1) (b 2) (c 3))) (deftest loop.3.21 (loop as x on '(a b c) for y on '(1 2 3) collect (list (car x) (car y))) ((a 1) (b 2) (c 3))) (deftest loop.3.22 (loop for x on '(a b c) as y on '(1 2 3) collect (list (car x) (car y))) ((a 1) (b 2) (c 3))) (deftest loop.3.23 (let (a b (i 0)) (values (loop for e on (progn (setf a (incf i)) '(a b c d e f g)) by (progn (setf b (incf i)) #'cddr) collect (car e)) a b i)) (a c e g) 1 2 2) gcl/ansi-tests/loop4.lsp000066400000000000000000000020661242227143400154770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 27 22:46:39 2002 ;;;; Contains: Tests for LOOP FOR-AS-EQUAL-THEN (in-package :cl-test) (deftest loop.4.1 (loop for x = 1 then (1+ x) until (> x 5) collect x) (1 2 3 4 5)) (deftest loop.4.2 (loop for i from 1 to 10 for j = (1+ i) collect j) (2 3 4 5 6 7 8 9 10 11)) (deftest loop.4.3 (loop for i from 1 to 10 for j of-type integer = (1+ i) collect j) (2 3 4 5 6 7 8 9 10 11)) (deftest loop.4.4 (loop for e on '(a b c d e) for (x . y) = e collect x) (a b c d e)) (deftest loop.4.5 (loop for (x . y) = '(a b c d e) then y while x collect x) (a b c d e)) ;;; Error cases (deftest loop.4.6 (classify-error (loop for (x . x) = '(nil nil nil) until x count t)) program-error) (deftest loop.4.7 (classify-error* (macroexpand '(loop for (x . x) = '(nil nil nil) until x count t))) program-error) (deftest loop.4.8 (classify-error* (macroexpand '(loop for x = '(nil nil nil) for x = 1 count x until t))) program-error) gcl/ansi-tests/loop5.lsp000066400000000000000000000100171242227143400154730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 2 13:52:50 2002 ;;;; Contains: Tests of LOOP clause FOR-AS-ACROSS (in-package :cl-test) (deftest loop.5.1 (let ((x "abcd")) (loop for e across x collect e)) (#\a #\b #\c #\d)) (deftest loop.5.2 (let ((x "abcd")) (loop for e across (the string x) collect e)) (#\a #\b #\c #\d)) (deftest loop.5.3 (let ((x "abcd")) (loop for e across (the simple-string x) collect e)) (#\a #\b #\c #\d)) (deftest loop.5.4 (loop for e across "abcd" collect e) (#\a #\b #\c #\d)) (deftest loop.5.5 (loop for e across "abcd" for i from 1 to 3 collect e) (#\a #\b #\c)) (deftest loop.5.6 (loop for e of-type base-char across "abcd" for i from 1 to 3 collect e) (#\a #\b #\c)) (deftest loop.5.7 (let ((x "abcd")) (loop for e across (the base-string x) collect e)) (#\a #\b #\c #\d)) (deftest loop.5.8 (let ((x "abcd")) (loop for e of-type character across x collect e)) (#\a #\b #\c #\d)) (deftest loop.5.10 (let ((x #*00010110)) (loop for e across x collect e)) (0 0 0 1 0 1 1 0)) (deftest loop.5.11 (let ((x #*00010110)) (loop for e across (the bit-vector x) collect e)) (0 0 0 1 0 1 1 0)) (deftest loop.5.12 (let ((x #*00010110)) (loop for e across (the simple-bit-vector x) collect e)) (0 0 0 1 0 1 1 0)) (deftest loop.5.13 (let ((x #*00010110)) (loop for e of-type bit across (the simple-bit-vector x) collect e)) (0 0 0 1 0 1 1 0)) (deftest loop.5.14 (let ((x #*00010110)) (loop for e of-type bit across x for i from 1 to 4 collect e)) (0 0 0 1)) (deftest loop.5.20 (let ((x (vector 'a 'b 'c 'd))) (loop for e across x collect e)) (a b c d)) (deftest loop.5.21 (let ((x (vector 'a 'b 'c 'd))) (loop for e across (the vector x) collect e)) (a b c d)) (deftest loop.5.22 (let ((x (vector 'a 'b 'c 'd))) (loop for e across (the simple-vector x) collect e)) (a b c d)) (deftest loop.5.23 (let ((x (vector '(a) '(b) '(c) '(d)))) (loop for (e) across x collect e)) (a b c d)) (deftest loop.5.30 (let ((x (make-array '(5) :initial-contents '(a b c d e) :adjustable t))) (loop for e across x collect e)) (a b c d e)) (deftest loop.5.32 (let* ((x (make-array '(5) :initial-contents '(a b c d e))) (y (make-array '(3) :displaced-to x :displaced-index-offset 1))) (loop for e across y collect e)) (b c d)) ;;; tests of 'as' form (deftest loop.5.33 (loop as e across "abc" collect e) (#\a #\b #\c)) (deftest loop.5.34 (loop as e of-type character across "abc" collect e) (#\a #\b #\c)) (deftest loop.5.35 (loop as e of-type integer across (the simple-vector (coerce '(1 2 3) 'simple-vector)) sum e) 6) ;;; Loop across displaced vectors (deftest loop.5.36 (let* ((a (make-array '(10) :initial-contents '(a b c d e f g h i j))) (da (make-array '(5) :displaced-to a :displaced-index-offset 2))) (loop for e across da collect e)) (c d e f g)) (deftest loop.5.37 (let* ((a (make-array '(10) :element-type 'base-char :initial-contents "abcdefghij")) (da (make-array '(5) :element-type 'base-char :displaced-to a :displaced-index-offset 2))) (loop for e across da collect e)) (#\c #\d #\e #\f #\g)) (deftest loop.5.38 (let* ((a (make-array '(10) :element-type 'bit :initial-contents '(0 1 1 0 0 1 0 1 1 1))) (da (make-array '(5) :element-type 'bit :displaced-to a :displaced-index-offset 2))) (loop for e across da collect e)) (1 0 0 1 0)) ;;; Error cases (deftest loop.5.error.1 (classify-error (loop for (e . e) across (vector '(x . y) '(u . v)) collect e)) program-error) (deftest loop.5.error.2 (classify-error (loop for e across (vector '(x . y) '(u . v)) for e from 1 to 5 collect e)) program-error) (deftest loop.5.error.3 (classify-error* (macroexpand '(loop for (e . e) across (vector '(x . y) '(u . v)) collect e))) program-error) (deftest loop.5.error.4 (classify-error* (macroexpand '(loop for e across (vector '(x . y) '(u . v)) for e from 1 to 5 collect e))) program-error) gcl/ansi-tests/loop6.lsp000066400000000000000000000160761242227143400155070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Nov 10 21:13:04 2002 ;;;; Contains: Tests for LOOP-AS-HASH forms (in-package :cl-test) (defparameter *loop.6.alist* '((a . 1) (b . 2) (c . 3))) (defparameter *loop.6.alist.2* '(("a" . 1) ("b" . 2) ("c" . 3))) (defparameter *loop.6.alist.3* '(((a1 . a2) . 1) ((b1 . b2) . 2) ((c1 . c2) . 3))) (defparameter *loop.6.hash.1* (let ((table (make-hash-table :test #'eq))) (loop for (key . val) in *loop.6.alist* do (setf (gethash key table) val)) table)) (defparameter *loop.6.hash.2* (let ((table (make-hash-table :test #'eql))) (loop for (key . val) in *loop.6.alist* do (setf (gethash key table) val)) table)) (defparameter *loop.6.hash.3* (let ((table (make-hash-table :test #'equal))) (loop for (key . val) in *loop.6.alist.3* do (setf (gethash key table) val)) table)) ;;; (defparameter *loop.6.hash.4* ;;; (let ((table (make-hash-table :test #'equalp))) ;;; (loop for (key . val) in *loop.6.alist.2* ;;; do (setf (gethash key table) val)) ;;; table)) (defparameter *loop.6.hash.5* (let ((table (make-hash-table :test #'eql))) (loop for (val . key) in *loop.6.alist.3* do (setf (gethash key table) val)) table)) (defparameter *loop.6.hash.6* (let ((table (make-hash-table :test #'eq))) (loop for (key . val) in *loop.6.alist* do (setf (gethash key table) (coerce val 'float))) table)) (defparameter *loop.6.hash.7* (let ((table (make-hash-table :test #'equal))) (loop for (val . key) in *loop.6.alist.3* do (setf (gethash (coerce key 'float) table) val)) table)) (defparameter *loop.6.alist.8* '(((1 . 2) . 1) ((3 . 4) . b) ((5 . 6) . c))) (defparameter *loop.6.hash.8* (let ((table (make-hash-table :test #'equal))) (loop for (key . val) in *loop.6.alist.8* do (setf (gethash key table) val)) table)) (defparameter *loop.6.hash.9* (let ((table (make-hash-table :test #'equal))) (loop for (val . key) in *loop.6.alist.8* do (setf (gethash key table) val)) table)) ;;; being {each | the} {hash-value | hash-values | hash-key | hash-keys} {in | of } (deftest loop.6.1 (loop for x being the hash-value of *loop.6.hash.1* sum x) 6) (deftest loop.6.2 (loop for x being the hash-values of *loop.6.hash.1* sum x) 6) (deftest loop.6.3 (loop for x being each hash-value of *loop.6.hash.1* sum x) 6) (deftest loop.6.4 (loop for x being each hash-values of *loop.6.hash.1* sum x) 6) (deftest loop.6.5 (loop for x being the hash-values in *loop.6.hash.1* sum x) 6) (deftest loop.6.6 (sort (loop for x being the hash-key of *loop.6.hash.1* collect x) #'symbol<) (a b c)) (deftest loop.6.7 (sort (loop for x being the hash-keys of *loop.6.hash.1* collect x) #'symbol<) (a b c)) (deftest loop.6.8 (sort (loop for x being each hash-key of *loop.6.hash.1* collect x) #'symbol<) (a b c)) (deftest loop.6.9 (sort (loop for x being each hash-keys of *loop.6.hash.1* collect x) #'symbol<) (a b c)) (deftest loop.6.10 (sort (loop for x being each hash-keys in *loop.6.hash.1* collect x) #'symbol<) (a b c)) (deftest loop.6.11 (sort (loop for (u . v) being the hash-keys of *loop.6.hash.3* collect u) #'symbol<) (a1 b1 c1)) (deftest loop.6.12 (sort (loop for (u . v) being the hash-keys of *loop.6.hash.3* collect v) #'symbol<) (a2 b2 c2)) (deftest loop.6.13 (sort (loop for (u . v) being the hash-values of *loop.6.hash.5* collect u) #'symbol<) (a1 b1 c1)) (deftest loop.6.14 (sort (loop for (u . v) being the hash-values of *loop.6.hash.5* collect v) #'symbol<) (a2 b2 c2)) (deftest loop.6.15 (sort (loop for k being the hash-keys of *loop.6.hash.1* using (hash-value v) collect (list k v)) #'< :key #'second) ((a 1) (b 2) (c 3))) (deftest loop.6.16 (sort (loop for v being the hash-values of *loop.6.hash.1* using (hash-key k) collect (list k v)) #'< :key #'second) ((a 1) (b 2) (c 3))) (deftest loop.6.17 (sort (loop for (u . nil) being the hash-values of *loop.6.hash.5* collect u) #'symbol<) (a1 b1 c1)) (deftest loop.6.18 (sort (loop for (nil . v) being the hash-values of *loop.6.hash.5* collect v) #'symbol<) (a2 b2 c2)) (deftest loop.6.19 (loop for nil being the hash-values of *loop.6.hash.5* count t) 3) (deftest loop.6.20 (loop for nil being the hash-keys of *loop.6.hash.5* count t) 3) (deftest loop.6.21 (loop for v being the hash-values of *loop.6.hash.5* using (hash-key nil) count t) 3) (deftest loop.6.22 (loop for k being the hash-keys of *loop.6.hash.5* using (hash-value nil) count t) 3) (deftest loop.6.23 (loop for v fixnum being the hash-values of *loop.6.hash.1* sum v) 6) (deftest loop.6.24 (loop for v of-type fixnum being the hash-values of *loop.6.hash.1* sum v) 6) (deftest loop.6.25 (loop for k fixnum being the hash-keys of *loop.6.hash.5* sum k) 6) (deftest loop.6.26 (loop for k of-type fixnum being the hash-keys of *loop.6.hash.5* sum k) 6) (deftest loop.6.27 (loop for k t being the hash-keys of *loop.6.hash.5* sum k) 6) (deftest loop.6.28 (loop for k of-type t being the hash-keys of *loop.6.hash.5* sum k) 6) (deftest loop.6.29 (loop for v t being the hash-values of *loop.6.hash.1* sum v) 6) (deftest loop.6.30 (loop for v of-type t being the hash-values of *loop.6.hash.1* sum v) 6) (deftest loop.6.31 (loop for v float being the hash-values of *loop.6.hash.6* sum v) 6.0) (deftest loop.6.32 (loop for v of-type float being the hash-values of *loop.6.hash.6* sum v) 6.0) (deftest loop.6.33 (loop for k float being the hash-keys of *loop.6.hash.7* sum k) 6.0) (deftest loop.6.34 (loop for k of-type float being the hash-keys of *loop.6.hash.7* sum k) 6.0) (deftest loop.6.35 (loop for (k1 . k2) of-type (integer . integer) being the hash-keys of *loop.6.hash.8* sum (+ k1 k2)) 21) (deftest loop.6.36 (loop for (v1 . v2) of-type (integer . integer) being the hash-values of *loop.6.hash.9* sum (+ v1 v2)) 21) (deftest loop.6.37 (loop for v being the hash-values of *loop.6.hash.8* using (hash-key (k1 . k2)) sum (+ k1 k2)) 21) (deftest loop.6.38 (loop for k being the hash-keys of *loop.6.hash.9* using (hash-value (v1 . v2)) sum (+ v1 v2)) 21) (deftest loop.6.39 (loop as x being the hash-value of *loop.6.hash.1* sum x) 6) (deftest loop.6.40 (sort (loop as x being the hash-key of *loop.6.hash.1* collect x) #'symbol<) (a b c)) ;;; Error tests (deftest loop.6.error.1 (classify-error (loop for k from 1 to 10 for k being the hash-keys of *loop.6.hash.1* count t)) program-error) (deftest loop.6.error.2 (classify-error (loop for k being the hash-keys of *loop.6.hash.1* for k from 1 to 10 count t)) program-error) (deftest loop.6.error.3 (classify-error (loop for (k . k) being the hash-keys of *loop.6.hash.3* count t)) program-error) (deftest loop.6.error.4 (classify-error (loop for k being the hash-keys of *loop.6.hash.3* using (hash-value k) count t)) program-error) (deftest loop.6.error.5 (classify-error (loop for k being the hash-values of *loop.6.hash.3* using (hash-key k) count t)) program-error) gcl/ansi-tests/loop7.lsp000066400000000000000000000126351242227143400155050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Nov 11 21:40:05 2002 ;;;; Contains: Tests for FOR-AS-PACKAGE clause for LOOP (in-package :cl-test) (defpackage "LOOP.CL-TEST.1" (:use) (:intern "FOO" "BAR" "BAZ") (:export "A" "B" "C")) (defpackage "LOOP.CL-TEST.2" (:use "LOOP.CL-TEST.1") (:intern "X" "Y" "Z")) (deftest loop.7.1 (sort (mapcar #'symbol-name (loop for x being the symbols of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.2 (sort (mapcar #'symbol-name (loop for x being each symbol of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.3 (sort (mapcar #'symbol-name (loop for x being the symbol of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.4 (sort (mapcar #'symbol-name (loop for x being each symbols of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.5 (sort (mapcar #'symbol-name (loop for x being the symbols in "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.6 (sort (mapcar #'symbol-name (loop for x being each symbol in "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.7 (sort (mapcar #'symbol-name (loop for x being the symbol in "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.8 (sort (mapcar #'symbol-name (loop for x being each symbols in "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.9 (sort (mapcar #'symbol-name (loop for x being the external-symbols of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "C")) (deftest loop.7.10 (sort (mapcar #'symbol-name (loop for x being each external-symbol in "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "C")) (deftest loop.7.11 (sort (mapcar #'symbol-name (loop for x being each external-symbol in (find-package "LOOP.CL-TEST.1") collect x)) #'string<) ("A" "B" "C")) (deftest loop.7.12 (sort (mapcar #'symbol-name (loop for x being each external-symbol in :LOOP.CL-TEST.1 collect x)) #'string<) ("A" "B" "C")) (deftest loop.7.13 (sort (mapcar #'symbol-name (loop for x being the symbols of "LOOP.CL-TEST.2" collect x)) #'string<) ("A" "B" "C" "X" "Y" "Z")) (deftest loop.7.14 (sort (mapcar #'symbol-name (loop for x being the present-symbols of "LOOP.CL-TEST.2" collect x)) #'string<) ("X" "Y" "Z")) ;;; According to the ANSI CL spec, "If the package for the iteration is not supplied, ;;; the current package is used." Thse next tests are of the cases that the package ;;; is not supplied in the loop form. (deftest loop.7.15 (let ((*package* (find-package "LOOP.CL-TEST.1"))) (sort (mapcar #'symbol-name (loop for x being each symbol collect x)) #'string<)) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.16 (let ((*package* (find-package "LOOP.CL-TEST.1"))) (sort (mapcar #'symbol-name (loop for x being each external-symbol collect x)) #'string<)) ("A" "B" "C")) (deftest loop.7.17 (let ((*package* (find-package "LOOP.CL-TEST.2"))) (sort (mapcar #'symbol-name (loop for x being each present-symbol collect x)) #'string<)) ("X" "Y" "Z")) ;;; Cases where the package doesn't exist. According to the standard, ;;; (section 6.1.2.1.7), this should cause a pacakge-error. (deftest loop.7.18 (progn (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (classify-error (loop for x being each symbol of "LOOP.MISSING.PACKAGE" collect x))) package-error) (deftest loop.7.19 (progn (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (classify-error (loop for x being each present-symbol of "LOOP.MISSING.PACKAGE" collect x))) package-error) (deftest loop.7.20 (progn (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (classify-error (loop for x being each external-symbol of "LOOP.MISSING.PACKAGE" collect x))) package-error) ;;; NIL d-var-specs (deftest loop.7.21 (loop for nil being the symbols of "LOOP.CL-TEST.1" count t) 6) (deftest loop.7.22 (loop for nil being the external-symbols of "LOOP.CL-TEST.1" count t) 3) (deftest loop.7.23 (loop for nil being the present-symbols of "LOOP.CL-TEST.2" count t) 3) ;;; Type specs (deftest loop.7.24 (loop for x t being the symbols of "LOOP.CL-TEST.1" count x) 6) (deftest loop.7.25 (loop for x t being the external-symbols of "LOOP.CL-TEST.1" count x) 3) (deftest loop.7.26 (loop for x t being the present-symbols of "LOOP.CL-TEST.2" count x) 3) (deftest loop.7.27 (loop for x of-type symbol being the symbols of "LOOP.CL-TEST.1" count x) 6) (deftest loop.7.28 (loop for x of-type symbol being the external-symbols of "LOOP.CL-TEST.1" count x) 3) (deftest loop.7.29 (loop for x of-type symbol being the present-symbols of "LOOP.CL-TEST.2" count x) 3) ;;; Tests of the 'as' form (deftest loop.7.30 (sort (mapcar #'symbol-name (loop as x being the symbols of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.31 (sort (mapcar #'symbol-name (loop as x being each symbol of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.32 (sort (mapcar #'symbol-name (loop as x being the symbol of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) gcl/ansi-tests/loop8.lsp000066400000000000000000000054321242227143400155030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Nov 12 06:30:14 2002 ;;;; Contains: Tests of LOOP local variable initialization (in-package :cl-test) (deftest loop.8.1 (loop with x = 1 do (return x)) 1) (deftest loop.8.2 (loop with x = 1 with y = (1+ x) do (return (list x y))) (1 2)) (deftest loop.8.3 (let ((y 2)) (loop with x = y with y = (1+ x) do (return (list x y)))) (2 3)) (deftest loop.8.4 (let (a b) (loop with a = 1 and b = (list a) and c = (list b) return (list a b c))) (1 (nil) (nil))) ;;; type specs (deftest loop.8.5 (loop with a t = 1 return a) 1) (deftest loop.8.6 (loop with a fixnum = 2 return a) 2) (deftest loop.8.7 (loop with a float = 3.0 return a) 3.0) (deftest loop.8.8 (loop with a of-type string = "abc" return a) "abc") (deftest loop.8.9 (loop with (a b) = '(1 2) return (list b a)) (2 1)) (deftest loop.8.10 (loop with (a b) of-type (fixnum fixnum) = '(3 4) return (+ a b)) 7) (deftest loop.8.11 (loop with a of-type fixnum return a) 0) (deftest loop.8.12 (loop with a of-type float return a) 0.0) (deftest loop.8.13 (loop with a of-type t return a) nil) (deftest loop.8.14 (loop with a t return a) nil) (deftest loop.8.15 (loop with a t and b t return (list a b)) (nil nil)) (deftest loop.8.16 (loop with (a b c) of-type (fixnum float t) return (list a b c)) (0 0.0 nil)) (deftest loop.8.17 (loop with nil = nil return nil) nil) ;;; The NIL block of a loop encloses the entire loop. (deftest loop.8.18 (loop with nil = (return t) return nil) t) (deftest loop.8.19 (loop with (nil a) = '(1 2) return a) 2) (deftest loop.8.20 (loop with (a nil) = '(1 2) return a) 1) (deftest loop.8.21 (loop with b = 3 and (a nil) = '(1 2) return (list a b)) (1 3)) (deftest loop.8.22 (loop with b = 3 and (nil a) = '(1 2) return (list a b)) (2 3)) ;;; The NIL block of a loop encloses the entire loop. (deftest loop.8.23 (loop with a = 1 and b = (return 2) return 3) 2) ;;; Error cases ;;; The spec says (in section 6.1.1.7) that: ;;; "An error of type program-error is signaled (at macro expansion time) ;;; if the same variable is bound twice in any variable-binding clause ;;; of a single loop expression. Such variables include local variables, ;;; iteration control variables, and variables found by destructuring." ;;; ;;; This is somewhat ambiguous. Test loop.8.error.1 binds A twice in ;;; the same clause, but loop.8.error.2 binds A in two different clauses. ;;; I am interpreting the spec as ruling out the latter as well. (deftest loop.8.error.1 (classify-error (loop with a = 1 and a = 2 return a)) program-error) (deftest loop.8.error.2 (classify-error (loop with a = 1 with a = 2 return a)) program-error) gcl/ansi-tests/loop9.lsp000066400000000000000000000113641242227143400155050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 14 06:25:21 2002 ;;;; Contains: Tests for loop list accumulation clauses (in-package :cl-test) ;;; Tests of COLLECT, COLLECTING (deftest loop.9.1 (loop for x in '(2 3 4) collect (1+ x)) (3 4 5)) (deftest loop.9.2 (loop for x in '(2 3 4) collecting (1+ x)) (3 4 5)) (deftest loop.9.3 (loop for x in '(0 1 2) when (eql x 2) do (return 'good) collect x) good) (deftest loop.9.4 (loop for x in '(a b c) collect (list x) into foo finally (return (reverse foo))) ((c) (b) (a))) (deftest loop.9.5 (loop for x in '(a b c) collecting (list x) into foo finally (return (reverse foo))) ((c) (b) (a))) (deftest loop.9.6 (loop for x from 1 to 10 when (evenp x) collect x into foo when (oddp x) collect x into bar finally (return (list foo bar))) ((2 4 6 8 10) (1 3 5 7 9))) (deftest loop.9.7 (loop for x from 1 to 10 collect (if (> x 5) (loop-finish) x)) (1 2 3 4 5)) (deftest loop.9.8 (loop for x from 1 to 20 when (eql (mod x 5) 0) collect x into foo when (eql (mod x 5) 2) collect x into foo finally (return foo)) (2 5 7 10 12 15 17 20)) (deftest loop.9.9 (loop for x from 1 to 20 when (eql (mod x 5) 0) collecting x into foo when (eql (mod x 5) 2) collecting x into foo finally (return foo)) (2 5 7 10 12 15 17 20)) (deftest loop.9.10 (classify-error (loop with foo = '(a b) for x in '(c d) collect x into foo finally (return foo))) program-error) (deftest loop.9.11 (classify-error (loop with foo = '(a b) for x in '(c d) collecting x into foo finally (return foo))) program-error) (deftest loop.9.12 (let ((foo '(a b))) (values (loop for x in '(c d e) collect x into foo finally (return foo)) foo)) (c d e) (a b)) ;;; Tests of APPEND, APPENDING (deftest loop.9.20 (loop for x in '((a b) (c d) (e f g) () (i)) append x) (a b c d e f g i)) (deftest loop.9.21 (loop for x in '((a b) (c d) (e f g) () (i)) appending x) (a b c d e f g i)) (deftest loop.9.22 (loop for x in '((a) (b) (c . whatever)) append x) (a b c . whatever)) (deftest loop.9.23 (loop for x in '((a) (b) (c . whatever)) appending x) (a b c . whatever)) (deftest loop.9.24 (loop for x in '(a b c d) append (list x) when (eq x 'b) append '(1 2 3) when (eq x 'd) appending '(4 5 6)) (a b 1 2 3 c d 4 5 6)) (deftest loop.9.25 (let (z) (values (loop for x in '((a) (b) (c) (d)) append x into foo finally (setq z foo)) z)) nil (a b c d)) (deftest loop.9.26 (loop for x in '((a) (b) (c) (d)) for i from 1 append x into foo append x into foo appending (list i) into foo finally (return foo)) (a a 1 b b 2 c c 3 d d 4)) (deftest loop.9.27 (classify-error (loop with foo = '(a b) for x in '(c d) append (list x) into foo finally (return foo))) program-error) (deftest loop.9.28 (classify-error (loop with foo = '(a b) for x in '(c d) appending (list x) into foo finally (return foo))) program-error) ;;; NCONC, NCONCING (deftest loop.9.30 (loop for x in '((a b) (c d) (e f g) () (i)) nconc (copy-seq x)) (a b c d e f g i)) (deftest loop.9.31 (loop for x in '((a b) (c d) (e f g) () (i)) nconcing (copy-seq x)) (a b c d e f g i)) (deftest loop.9.32 (loop for x in '((a) (b) (c . whatever)) nconc (cons (car x) (cdr x))) (a b c . whatever)) (deftest loop.9.33 (loop for x in '((a) (b) (c . whatever)) nconcing (cons (car x) (cdr x))) (a b c . whatever)) (deftest loop.9.34 (loop for x in '(a b c d) nconc (list x) when (eq x 'b) nconc (copy-seq '(1 2 3)) when (eq x 'd) nconcing (copy-seq '(4 5 6))) (a b 1 2 3 c d 4 5 6)) (deftest loop.9.35 (let (z) (values (loop for x in '((a) (b) (c) (d)) nconc (copy-seq x) into foo finally (setq z foo)) z)) nil (a b c d)) (deftest loop.9.36 (loop for x in '((a) (b) (c) (d)) for i from 1 nconc (copy-seq x) into foo nconc (copy-seq x) into foo nconcing (list i) into foo finally (return foo)) (a a 1 b b 2 c c 3 d d 4)) (deftest loop.9.37 (classify-error (loop with foo = '(a b) for x in '(c d) nconc (list x) into foo finally (return foo))) program-error) (deftest loop.9.38 (classify-error (loop with foo = '(a b) for x in '(c d) nconcing (list x) into foo finally (return foo))) program-error) ;;; Combinations (deftest loop.9.40 (loop for x in '(1 2 3 4 5 6 7) if (< x 2) append (list x) else if (< x 5) nconc (list (1+ x)) else collect (+ x 2)) (1 3 4 5 7 8 9)) (deftest loop.9.41 (loop for x in '(1 2 3 4 5 6 7) if (< x 2) append (list x) into foo else if (< x 5) nconc (list (1+ x)) into foo else collect (+ x 2) into foo finally (return foo)) (1 3 4 5 7 8 9)) ;;; More nconc tests (deftest loop.9.42 (loop for x in '(a b c d e) nconc (cons x 'foo)) (a b c d e . foo)) gcl/ansi-tests/macrolet.lsp000066400000000000000000000066311242227143400162520ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Oct 9 19:41:24 2002 ;;;; Contains: Tests of MACROLET (in-package :cl-test) (deftest macrolet.1 (let ((z (list 3 4))) (macrolet ((%m (x) `(car ,x))) (let ((y (list 1 2))) (values (%m y) (%m z))))) 1 3) (deftest macrolet.2 (let ((z (list 3 4))) (macrolet ((%m (x) `(car ,x))) (let ((y (list 1 2))) (values (setf (%m y) 6) (setf (%m z) 'a) y z)))) 6 a (6 2) (a 4)) ;;; Inner definitions shadow outer ones (deftest macrolet.3 (macrolet ((%m (w) `(cadr ,w))) (let ((z (list 3 4))) (macrolet ((%m (x) `(car ,x))) (let ((y (list 1 2))) (values (%m y) (%m z) (setf (%m y) 6) (setf (%m z) 'a) y z))))) 1 3 6 a (6 2) (a 4)) ;;; &whole parameter (deftest macrolet.4 (let ((x nil)) (macrolet ((%m (&whole w arg) `(progn (setq x (quote ,w)) ,arg))) (values (%m 1) x))) 1 (%m 1)) ;;; &whole parameter (nested, destructuring; see section 3.4.4) (deftest macrolet.5 (let ((x nil)) (macrolet ((%m ((&whole w arg)) `(progn (setq x (quote ,w)) ,arg))) (values (%m (1)) x))) 1 (1)) ;;; key parameter (deftest macrolet.6 (let ((x nil)) (macrolet ((%m (&key (a 'xxx) b) `(setq x (quote ,a)))) (values (%m :a foo) x (%m :b bar) x))) foo foo xxx xxx) ;;; nested key parameters (deftest macrolet.7 (let ((x nil)) (macrolet ((%m ((&key a b)) `(setq x (quote ,a)))) (values (%m (:a foo)) x (%m (:b bar)) x))) foo foo nil nil) ;;; nested key parameters (deftest macrolet.8 (let ((x nil)) (macrolet ((%m ((&key (a 10) b)) `(setq x (quote ,a)))) (values (%m (:a foo)) x (%m (:b bar)) x))) foo foo 10 10) ;;; keyword parameter with supplied-p parameter (deftest macrolet.9 (let ((x nil)) (macrolet ((%m (&key (a 'xxx a-p) b) `(setq x (quote ,(list a (not (not a-p))))))) (values (%m :a foo) x (%m :b bar) x))) (foo t) (foo t) (xxx nil) (xxx nil)) ;;; rest parameter (deftest macrolet.10 (let ((x nil)) (macrolet ((%m (b &rest a) `(setq x (quote ,a)))) (values (%m a1 a2) x))) (a2) (a2)) ;;; rest parameter w. destructuring (deftest macrolet.11 (let ((x nil)) (macrolet ((%m ((b &rest a)) `(setq x (quote ,a)))) (values (%m (a1 a2)) x))) (a2) (a2)) ;;; rest parameter w. whole (deftest macrolet.12 (let ((x nil)) (macrolet ((%m (&whole w b &rest a) `(setq x (quote ,(list a w))))) (values (%m a1 a2) x))) ((a2) (%m a1 a2)) ((a2) (%m a1 a2))) ;;; Interaction with symbol-macrolet (deftest macrolet.13 (symbol-macrolet ((a b)) (macrolet ((foo (x &environment env) (let ((y (macroexpand x env))) (if (eq y 'a) 1 2)))) (foo a))) 2) (deftest macrolet.14 (symbol-macrolet ((a b)) (macrolet ((foo (x &environment env) (let ((y (macroexpand-1 x env))) (if (eq y 'a) 1 2)))) (foo a))) 2) (deftest macrolet.15 (macrolet ((nil () ''a)) (nil)) a) (deftest macrolet.16 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (macrolet ((,s () ''a)) (,s))) unless (eq (eval form) 'a) collect s) nil) ;;; Symbol-macrolet tests (deftest symbol-macrolet.1 (loop for s in *cl-non-variable-constant-symbols* for form = `(classify-error (symbol-macrolet ((,s 17)) ,s)) unless (eql (eval form) 17) collect s) nil) gcl/ansi-tests/make-array.lsp000066400000000000000000000453451242227143400165020ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Sep 20 06:47:37 2002 ;;;; Contains: Tests for MAKE-ARRAY (in-package :cl-test) ;;; See array-aux.lsp for auxiliary functions (deftest make-array.1 (let ((a (make-array-with-checks 10))) (and (symbolp a) a)) nil) (deftest make-array.1a (let ((a (make-array-with-checks '(10)))) (and (symbolp a) a)) nil) (deftest make-array.2 (make-array-with-checks 3 :initial-element 'z) #(z z z)) (deftest make-array.2a (make-array-with-checks 3 :initial-contents '(a b c)) #(a b c)) (deftest make-array.2b (make-array-with-checks 3 :initial-contents #(a b c)) #(a b c)) (deftest make-array.2c (make-array-with-checks 3 :initial-contents "abc") #(#\a #\b #\c)) (deftest make-array.2d (make-array-with-checks 3 :initial-contents #*010) #(0 1 0)) (deftest make-array.3 (let ((a (make-array-with-checks 5 :element-type 'bit))) (and (symbolp a) a)) nil) (deftest make-array.4 (make-array-with-checks 5 :element-type 'bit :initial-element 1) #*11111) (deftest make-array.4a (make-array-with-checks 5 :element-type 'bit :initial-contents '(1 0 0 1 0)) #*10010) (deftest make-array.4b (make-array-with-checks 5 :element-type 'bit :initial-contents #(1 0 0 1 0)) #*10010) (deftest make-array.4c (make-array-with-checks 5 :element-type 'bit :initial-contents #*10010) #*10010) (deftest make-array.5 (let ((a (make-array-with-checks 4 :element-type 'character))) (and (symbolp a) a)) nil) (deftest make-array.5a (let ((a (make-array-with-checks '(4) :element-type 'character))) (and (symbolp a) a)) nil) (deftest make-array.6 (make-array-with-checks 4 :element-type 'character :initial-element #\x) "xxxx") (deftest make-array.6a (make-array-with-checks 4 :element-type 'character :initial-contents '(#\a #\b #\c #\d)) "abcd") (deftest make-array.6b (make-array-with-checks 4 :element-type 'character :initial-contents "abcd") "abcd") (deftest make-array.7 (make-array-with-checks 5 :element-type 'symbol :initial-element 'a) #(a a a a a)) (deftest make-array.7a (make-array-with-checks 5 :element-type 'symbol :initial-contents '(a b c d e)) #(a b c d e)) (deftest make-array.7b (make-array-with-checks '(5) :element-type 'symbol :initial-contents '(a b c d e)) #(a b c d e)) (deftest make-array.8 (let ((a (make-array-with-checks 8 :element-type '(integer 0 (256))))) (and (symbolp a) a)) nil) (deftest make-array.8a (make-array-with-checks 8 :element-type '(integer 0 (256)) :initial-element 9) #(9 9 9 9 9 9 9 9)) (deftest make-array.8b (make-array-with-checks '(8) :element-type '(integer 0 (256)) :initial-contents '(4 3 2 1 9 8 7 6)) #(4 3 2 1 9 8 7 6)) ;;; Zero dimensional arrays (deftest make-array.9 (let ((a (make-array-with-checks nil))) (and (symbolp a) a)) nil) (deftest make-array.10 (make-array-with-checks nil :initial-element 1) #0a1) (deftest make-array.11 (make-array-with-checks nil :initial-contents 2) #0a2) (deftest make-array.12 (make-array-with-checks nil :element-type 'bit :initial-contents 1) #0a1) (deftest make-array.13 (make-array-with-checks nil :element-type t :initial-contents 'a) #0aa) ;;; Higher dimensional arrays (deftest make-array.14 (let ((a (make-array-with-checks '(2 3)))) (and (symbolp a) a)) nil) (deftest make-array.15 (make-array-with-checks '(2 3) :initial-element 'x) #2a((x x x) (x x x))) (deftest make-array.16 (equalpt (make-array-with-checks '(0 0)) (read-from-string "#2a()")) t) (deftest make-array.17 (make-array-with-checks '(2 3) :initial-contents '((a b c) (d e f))) #2a((a b c) (d e f))) (deftest make-array.18 (make-array-with-checks '(2 3) :initial-contents '(#(a b c) #(d e f))) #2a((a b c) (d e f))) (deftest make-array.19 (make-array-with-checks '(4) :initial-contents (make-array '(10) :initial-element 1 :fill-pointer 4)) #(1 1 1 1)) (deftest make-array.20 (let ((a (make-array '(10) :initial-element 1 :fill-pointer 4))) (make-array-with-checks '(3 4) :initial-contents (list a a a))) #2a((1 1 1 1) (1 1 1 1) (1 1 1 1))) (deftest make-array.21 (make-array-with-checks '(3 4) :initial-contents (make-array '(10) :initial-element '(1 2 3 4) :fill-pointer 3)) #2a((1 2 3 4) (1 2 3 4) (1 2 3 4))) (deftest make-array.22 (loop for i from 3 below (min array-rank-limit 128) always (equalpt (make-array-with-checks (make-list i :initial-element 0)) (read-from-string (format nil "#~Aa()" i)))) t) (deftest make-array.23 (let ((len (1- array-rank-limit))) (equalpt (make-array-with-checks (make-list len :initial-element 0)) (read-from-string (format nil "#~Aa()" len)))) t) (deftest make-array.24 (make-array-with-checks '(5) :initial-element 'a :displaced-to nil) #(a a a a a)) (deftest make-array.25 (make-array '(4) :initial-element 'x :nonsense-argument t :allow-other-keys t) #(x x x x)) (deftest make-array.26 (make-array '(4) :initial-element 'x :allow-other-keys nil) #(x x x x)) (deftest make-array.27 (make-array '(4) :initial-element 'x :allow-other-keys t :allow-other-keys nil :nonsense-argument t) #(x x x x)) (deftest make-array.28 (let ((*package* (find-package :cl-test))) (let ((len (1- (min 10000 array-rank-limit)))) (equalpt (make-array (make-list len :initial-element 1) :initial-element 'x) (read-from-string (concatenate 'string (format nil "#~dA" len) (make-string len :initial-element #\() "x" (make-string len :initial-element #\))))))) t) (deftest make-array.29 (make-array-with-checks '(5) :element-type '(integer 0 (256)) :initial-contents '(0 5 255 119 57)) #(0 5 255 119 57)) (deftest make-array.30 (make-array-with-checks '(5) :element-type '(integer -128 127) :initial-contents '(-10 5 -128 86 127)) #(-10 5 -128 86 127)) (deftest make-array.31 (make-array-with-checks '(5) :element-type '(integer 0 (65536)) :initial-contents '(0 100 65535 7623 13)) #(0 100 65535 7623 13)) (deftest make-array.32 (make-array-with-checks '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5)) #(1 2 3 4 5)) (deftest make-array.33 (make-array-with-checks '(5) :element-type 'short-float :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) (deftest make-array.34 (make-array-with-checks '(5) :element-type 'single-float :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) (deftest make-array.35 (make-array-with-checks '(5) :element-type 'double-float :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) (deftest make-array.36 (make-array-with-checks '(5) :element-type 'long-float :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) ;;; Adjustable arrays (deftest make-array.adjustable.1 (let ((a (make-array-with-checks '(10) :adjustable t))) (and (symbolp a) a)) nil) (deftest make-array.adjustable.2 (make-array-with-checks '(4) :adjustable t :initial-element 6) #(6 6 6 6)) (deftest make-array.adjustable.3 (make-array-with-checks nil :adjustable t :initial-element 7) #0a7) (deftest make-array.adjustable.4 (make-array-with-checks '(2 3) :adjustable t :initial-element 7) #2a((7 7 7) (7 7 7))) (deftest make-array.adjustable.5 (make-array-with-checks '(2 3) :adjustable t :initial-contents '((1 2 3) "abc")) #2a((1 2 3) (#\a #\b #\c))) (deftest make-array.adjustable.6 (make-array-with-checks '(4) :adjustable t :initial-contents '(a b c d)) #(a b c d)) (deftest make-array.adjustable.7 (make-array-with-checks '(4) :adjustable t :fill-pointer t :initial-contents '(a b c d)) #(a b c d)) (deftest make-array.adjustable.8 (make-array-with-checks '(4) :adjustable t :element-type '(integer 0 (256)) :initial-contents '(1 4 7 9)) #(1 4 7 9)) (deftest make-array.adjustable.9 (make-array-with-checks '(4) :adjustable t :element-type 'base-char :initial-contents "abcd") "abcd") (deftest make-array.adjustable.10 (make-array-with-checks '(4) :adjustable t :element-type 'bit :initial-contents '(0 1 1 0)) #*0110) (deftest make-array.adjustable.11 (make-array-with-checks '(4) :adjustable t :element-type 'symbol :initial-contents '(a b c d)) #(a b c d)) ;;; Displaced arrays (deftest make-array.displaced.1 (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) (make-array-with-checks '(5) :displaced-to a)) #(a b c d e)) (deftest make-array.displaced.2 (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) (make-array-with-checks '(5) :displaced-to a :displaced-index-offset 3)) #(d e f g h)) (deftest make-array.displaced.3 (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) (make-array-with-checks '(5) :displaced-to a :displaced-index-offset 5)) #(f g h i j)) (deftest make-array.displaced.4 (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) (make-array-with-checks '(0) :displaced-to a :displaced-index-offset 10)) #()) (deftest make-array.displaced.5 (let ((a (make-array '(10) :element-type '(integer 0 (256)) :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) (make-array-with-checks '(5) :element-type '(integer 0 (256)) :displaced-to a)) #(1 3 5 7 9)) (deftest make-array.displaced.6 (let ((a (make-array '(10) :element-type '(integer 0 (256)) :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) (loop for i from 0 to 5 collect (make-array-with-checks '(5) :element-type '(integer 0 (256)) :displaced-to a :displaced-index-offset i))) (#(1 3 5 7 9) #(3 5 7 9 11) #(5 7 9 11 13) #(7 9 11 13 15) #(9 11 13 15 17) #(11 13 15 17 19))) (deftest make-array.displaced.7 (let ((a (make-array '(10) :element-type '(integer 0 (256)) :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) (make-array-with-checks '(0) :element-type '(integer 0 (256)) :displaced-to a :displaced-index-offset 10)) #()) (deftest make-array.displaced.8 (let ((a (make-array '(10) :element-type 'bit :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) (make-array-with-checks '(5) :element-type 'bit :displaced-to a)) #*01101) (deftest make-array.displaced.9 (let ((a (make-array '(10) :element-type 'bit :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) (loop for i from 0 to 5 collect (make-array-with-checks '(5) :element-type 'bit :displaced-to a :displaced-index-offset i))) (#*01101 #*11011 #*10111 #*01110 #*11101 #*11010)) (deftest make-array.displaced.10 (let ((a (make-array '(10) :element-type 'bit :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) (make-array-with-checks '(0) :element-type 'bit :displaced-to a :displaced-index-offset 10)) #*) (deftest make-array.displaced.11 (let ((a (make-array '(10) :element-type 'base-char :initial-contents "abcdefghij"))) (make-array-with-checks '(5) :element-type 'base-char :displaced-to a)) "abcde") (deftest make-array.displaced.12 (let ((a (make-array '(10) :element-type 'base-char :initial-contents "abcdefghij"))) (loop for i from 0 to 5 collect (make-array-with-checks '(5) :element-type 'base-char :displaced-to a :displaced-index-offset i))) ("abcde" "bcdef" "cdefg" "defgh" "efghi" "fghij")) (deftest make-array.displaced.13 (let ((a (make-array '(10) :element-type 'base-char :initial-contents "abcdefghij"))) (make-array-with-checks '(0) :element-type 'base-char :displaced-to a :displaced-index-offset 10)) "") (deftest make-array.displaced.14 (let ((a (make-array '(10) :element-type 'character :initial-contents "abcdefghij"))) (make-array-with-checks '(5) :element-type 'character :displaced-to a)) "abcde") (deftest make-array.displaced.15 (let ((a (make-array '(10) :element-type 'character :initial-contents "abcdefghij"))) (loop for i from 0 to 5 collect (make-array-with-checks '(5) :element-type 'character :displaced-to a :displaced-index-offset i))) ("abcde" "bcdef" "cdefg" "defgh" "efghi" "fghij")) (deftest make-array.displaced.16 (let ((a (make-array '(10) :element-type 'character :initial-contents "abcdefghij"))) (make-array-with-checks '(0) :element-type 'character :displaced-to a :displaced-index-offset 10)) "") ;;; Multidimensional displaced arrays (deftest make-array.displaced.17 (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) (9 10 11 12))))) (make-array-with-checks '(8) :displaced-to a)) #(1 2 3 4 5 6 7 8)) (deftest make-array.displaced.18 (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) (9 10 11 12))))) (make-array-with-checks '(8) :displaced-to a :displaced-index-offset 3)) #(4 5 6 7 8 9 10 11)) (deftest make-array.displaced.19 (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) (9 10 11 12))))) (make-array-with-checks '(2 4) :displaced-to a :displaced-index-offset 4)) #2a((5 6 7 8) (9 10 11 12))) (deftest make-array.displaced.20 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(24) :displaced-to a)) #(a b c d e f g h i j k l m n o p q r s t u v w x)) (deftest make-array.displaced.21 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(3 8) :displaced-to a)) #2a((a b c d e f g h) (i j k l m n o p) (q r s t u v w x))) (deftest make-array.displaced.22 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a :displaced-index-offset 5)) #(f g h i j k l m n o)) (deftest make-array.displaced.23 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a :displaced-index-offset 5 :fill-pointer t)) #(f g h i j k l m n o)) (deftest make-array.displaced.24 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a :displaced-index-offset 5 :fill-pointer 5)) #(f g h i j)) (deftest make-array.displaced.25 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a :displaced-index-offset 5 :adjustable t)) #(f g h i j k l m n o)) (deftest make-array.displaced.26 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a :displaced-index-offset 5 :fill-pointer 8 :adjustable t)) #(f g h i j k l m)) (deftest make-array.displaced.27 (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer t))) (make-array-with-checks '(2 4) :displaced-to a)) #2a((1 2 3 4) (5 6 7 8))) (deftest make-array.displaced.28 (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 4))) (make-array-with-checks '(2 4) :displaced-to a)) #2a((1 2 3 4) (5 6 7 8))) (deftest make-array.displaced.29 (let ((a (make-array '(10) :initial-element 0))) (prog1 (make-array-with-checks '(2 4) :displaced-to a) (loop for i below 10 do (setf (aref a i) (1+ i))))) #2a((1 2 3 4) (5 6 7 8))) (deftest make-array.displaced.30 (let* ((a1 (make-array '(10) :initial-element 0)) (a2 (make-array '(10) :displaced-to a1))) (prog1 (make-array-with-checks '(2 4) :displaced-to a2) (loop for i below 10 do (setf (aref a2 i) (1+ i))))) #2a((1 2 3 4) (5 6 7 8))) (deftest make-array.displaced.31 (let* ((a1 (make-array '(10) :initial-element 0)) (a2 (make-array '(10) :displaced-to a1))) (prog1 (make-array-with-checks '(2 4) :displaced-to a2) (loop for i below 10 do (setf (aref a1 i) (1+ i))))) #2a((1 2 3 4) (5 6 7 8))) ;;; Keywords tests (deftest make-array.allow-other-keys.1 (make-array '(5) :initial-element 'a :allow-other-keys t) #(a a a a a)) (deftest make-array.allow-other-keys.2 (make-array '(5) :initial-element 'a :allow-other-keys nil) #(a a a a a)) (deftest make-array.allow-other-keys.3 (make-array '(5) :initial-element 'a :allow-other-keys t '#:bad t) #(a a a a a)) (deftest make-array.allow-other-keys.4 (make-array '(5) :initial-element 'a :bad t :allow-other-keys t) #(a a a a a)) (deftest make-array.allow-other-keys.5 (make-array '(5) :bad t :initial-element 'a :allow-other-keys t) #(a a a a a)) (deftest make-array.allow-other-keys.6 (make-array '(5) :bad t :initial-element 'a :allow-other-keys t :allow-other-keys nil :also-bad nil) #(a a a a a)) (deftest make-array.allow-other-keys.7 (make-array '(5) :allow-other-keys t :initial-element 'a) #(a a a a a)) (deftest make-array.keywords.8. (make-array '(5) :initial-element 'x :initial-element 'a) #(x x x x x)) ;;; Error tests (deftest make-array.error.1 (classify-error (make-array)) program-error) (deftest make-array.error.2 (classify-error (make-array '(10) :bad t)) program-error) (deftest make-array.error.3 (classify-error (make-array '(10) :allow-other-keys nil :bad t)) program-error) (deftest make-array.error.4 (classify-error (make-array '(10) :allow-other-keys nil :allow-other-keys t :bad t)) program-error) (deftest make-array.error.5 (classify-error (make-array '(10) :bad)) program-error) (deftest make-array.error.6 (classify-error (make-array '(10) 1 2)) program-error) ;;; Order of evaluation tests (deftest make-array.order.1 (let ((i 0) a b c d e) (values (make-array (progn (setf a (incf i)) 5) :initial-element (progn (setf b (incf i)) 'a) :fill-pointer (progn (setf c (incf i)) nil) :displaced-to (progn (setf d (incf i)) nil) :element-type (progn (setf e (incf i)) t) ) i a b c d e)) #(a a a a a) 5 1 2 3 4 5) (deftest make-array.order.2 (let ((i 0) a b c d e) (values (make-array (progn (setf a (incf i)) 5) :element-type (progn (setf b (incf i)) t) :displaced-to (progn (setf c (incf i)) nil) :fill-pointer (progn (setf d (incf i)) nil) :initial-element (progn (setf e (incf i)) 'a) ) i a b c d e)) #(a a a a a) 5 1 2 3 4 5) gcl/ansi-tests/make-hash-table.lsp000066400000000000000000000005661242227143400173700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 21:36:33 2003 ;;;; Contains: Tests for MAKE-HASH-TABLE (in-package :cl-test) #| (deftest make-hash-table.1 (let ((ht (make-hash-table))) (values (check-values (typep ht 'hash-table)) (notnot (check-values (hash-table-p ht))) (check-values (hash-table-count ht)) |# gcl/ansi-tests/make-sequence.lsp000066400000000000000000000147231242227143400171700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 14 09:58:47 2002 ;;;; Contains: Tests for MAKE-SEQUENCE (in-package :cl-test) (deftest make-sequence.1 (let ((x (make-sequence 'list 4))) (and (eql (length x) 4) (listp x) (loop for e in x always (eql (car x) e)) t)) t) (deftest make-sequence.2 (make-sequence 'list 4 :initial-element 'a) (a a a a)) (deftest make-sequence.3 (let ((x (make-sequence 'cons 4))) (and (eql (length x) 4) (listp x) (loop for e in x always (eql (car x) e)) t)) t) (deftest make-sequence.4 (make-sequence 'cons 4 :initial-element 'a) (a a a a)) (deftest make-sequence.5 (make-sequence 'string 10 :initial-element #\a) "aaaaaaaaaa") (deftest make-sequence.6 (let ((s (make-sequence 'string 10))) (and (eql (length s) 10) (loop for e across s always (eql e (aref s 0))) t)) t) (deftest make-sequence.7 (make-sequence 'simple-string 10 :initial-element #\a) "aaaaaaaaaa") (deftest make-sequence.8 (let ((s (make-sequence 'simple-string 10))) (and (eql (length s) 10) (loop for e across s always (eql e (aref s 0))) t)) t) (deftest make-sequence.9 (make-sequence 'null 0) nil) (deftest make-sequence.10 (let ((x (make-sequence 'vector 10))) (and (eql (length x) 10) (loop for e across x always (eql e (aref x 0))) t)) t) (deftest make-sequence.11 (let* ((u (list 'a)) (x (make-sequence 'vector 10 :initial-element u))) (and (eql (length x) 10) (loop for e across x always (eql e u)) t)) t) (deftest make-sequence.12 (let ((x (make-sequence 'simple-vector 10))) (and (eql (length x) 10) (loop for e across x always (eql e (aref x 0))) t)) t) (deftest make-sequence.13 (let* ((u (list 'a)) (x (make-sequence 'simple-vector 10 :initial-element u))) (and (eql (length x) 10) (loop for e across x always (eql e u)) t)) t) (deftest make-sequence.14 (let ((x (make-sequence '(vector *) 10))) (and (eql (length x) 10) (loop for e across x always (eql e (aref x 0))) t)) t) (deftest make-sequence.15 (let* ((u (list 'a)) (x (make-sequence '(vector *) 10 :initial-element u))) (and (eql (length x) 10) (loop for e across x always (eql e u)) t)) t) (deftest make-sequence.16 (let ((x (make-sequence '(simple-vector *) 10))) (and (eql (length x) 10) (loop for e across x always (eql e (aref x 0))) t)) t) (deftest make-sequence.17 (let* ((u (list 'a)) (x (make-sequence '(simple-vector *) 10 :initial-element u))) (and (eql (length x) 10) (loop for e across x always (eql e u)) t)) t) (deftest make-sequence.18 (let ((x (make-sequence '(string *) 10))) (and (eql (length x) 10) (loop for e across x always (eql e (aref x 0))) t)) t) (deftest make-sequence.19 (let* ((u #\a) (x (make-sequence '(string *) 10 :initial-element u))) (and (eql (length x) 10) (loop for e across x always (eql e u)) t)) t) (deftest make-sequence.20 (let ((x (make-sequence '(simple-string *) 10))) (and (eql (length x) 10) (loop for e across x always (eql e (aref x 0))) t)) t) (deftest make-sequence.21 (let* ((u #\a) (x (make-sequence '(simple-string *) 10 :initial-element u))) (and (eql (length x) 10) (loop for e across x always (eql e u)) t)) t) (deftest make-sequence.22 (make-sequence '(vector * 5) 5 :initial-element 'a) #(a a a a a)) (deftest make-sequence.23 (make-sequence '(vector fixnum 5) 5 :initial-element 1) #(1 1 1 1 1)) (deftest make-sequence.24 (make-sequence '(vector (integer 0 255) 5) 5 :initial-element 17) #(17 17 17 17 17)) (deftest make-sequence.25 (make-sequence '(simple-vector 5) 5 :initial-element 'a) #(a a a a a)) (deftest make-sequence.26 (equalp (make-sequence 'string 5) (make-string 5)) t) ;;; Keyword tests (deftest make-sequence.allow-other-keys.1 (make-sequence 'list 5 :allow-other-keys t :initial-element 'a :bad t) (a a a a a)) (deftest make-sequence.allow-other-keys.2 (make-sequence 'list 5 :initial-element 'a :bad t :allow-other-keys t) (a a a a a)) (deftest make-sequence.allow-other-keys.3 (make-sequence 'list 5 :initial-element 'a :allow-other-keys t) (a a a a a)) (deftest make-sequence.allow-other-keys.4 (make-sequence 'list 5 :initial-element 'a :allow-other-keys nil) (a a a a a)) (deftest make-sequence.allow-other-keys.5 (make-sequence 'list 5 :initial-element 'a :allow-other-keys t :allow-other-keys nil :bad t) (a a a a a)) (deftest make-sequence.keywords.6 (make-sequence 'list 5 :initial-element 'a :initial-element 'b) (a a a a a)) ;;; Tests for errors (deftest make-sequence.error.1 (classify-error (make-sequence 'symbol 10)) type-error) (deftest make-sequence.error.2 (classify-error (make-sequence 'null 1)) type-error) (deftest make-sequence.error.3 (classify-error (make-sequence '(vector * 4) 3)) type-error) (deftest make-sequence.error.4 (classify-error (make-sequence '(vector * 2) 3)) type-error) (deftest make-sequence.error.5 (classify-error (make-sequence '(string 4) 3)) type-error) (deftest make-sequence.error.6 (classify-error (make-sequence '(simple-string 2) 3)) type-error) (deftest make-sequence.error.7 (classify-error (make-sequence 'cons 0)) type-error) (deftest make-sequence.error.8 (classify-error (make-sequence)) program-error) (deftest make-sequence.error.9 (classify-error (make-sequence 'list)) program-error) (deftest make-sequence.error.10 (classify-error (make-sequence 'list 10 :bad t)) program-error) (deftest make-sequence.error.11 (classify-error (make-sequence 'list 10 :bad t :allow-other-keys nil)) program-error) (deftest make-sequence.error.12 (classify-error (make-sequence 'list 10 :initial-element)) program-error) (deftest make-sequence.error.13 (classify-error (make-sequence 'list 10 0 0)) program-error) (deftest make-sequence.error.14 (classify-error (locally (make-sequence 'symbol 10) t)) type-error) ;;; Order of execution tests (deftest make-sequence.order.1 (let ((i 0) a b c) (values (make-sequence (progn (setf a (incf i)) 'list) (progn (setf b (incf i)) 5) :initial-element (progn (setf c (incf i)) 'a)) i a b c)) (a a a a a) 3 1 2 3) (deftest make-sequence.order.2 (let ((i 0) a b c d e) (values (make-sequence (progn (setf a (incf i)) 'list) (progn (setf b (incf i)) 5) :allow-other-keys (setf c (incf i)) :initial-element (progn (setf d (incf i)) 'a) :foo (setf e (incf i))) i a b c d e)) (a a a a a) 5 1 2 3 4 5) gcl/ansi-tests/make-string.lsp000066400000000000000000000071571242227143400166710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 5 12:32:20 2002 ;;;; Contains: Tests for MAKE-STRING (in-package :cl-test) (deftest make-string.1 (let ((s (make-string 10))) (and (stringp s) ;; (string-all-the-same s) (eqlt (length s) 10) )) t) (deftest make-string.2 (let ((s (make-string 10 :initial-element #\a))) (and (stringp s) (eql (length s) 10) s)) "aaaaaaaaaa") (deftest make-string.3 (let ((s (make-string 10 :initial-element #\a :element-type 'character))) (and (stringp s) (eql (length s) 10) s)) "aaaaaaaaaa") (deftest make-string.4 (let ((s (make-string 10 :initial-element #\a :element-type 'standard-char))) (and (stringp s) (eql (length s) 10) s)) "aaaaaaaaaa") (deftest make-string.5 (let ((s (make-string 10 :initial-element #\a :element-type 'base-char))) (and (stringp s) (eql (length s) 10) s)) "aaaaaaaaaa") (deftest make-string.6 (make-string 0) "") (deftest make-string.7 (let ((s (make-string 10 :element-type 'character))) (and (stringp s) (eqlt (length s) 10) #| (string-all-the-same s) |# )) t) (deftest make-string.8 (let ((s (make-string 10 :element-type 'standard-char))) (and (stringp s) (eqlt (length s) 10) #| (string-all-the-same s) |# )) t) (deftest make-string.9 (let ((s (make-string 10 :element-type 'base-char))) (and (stringp s) (eqlt (length s) 10) #| (string-all-the-same s) |# )) t) ;;; Keyword tests ; (deftest make-string.allow-other-keys.1 (make-string 5 :allow-other-keys t :initial-element #\a) "aaaaa") (deftest make-string.allow-other-keys.2 (make-string 5 :initial-element #\a :allow-other-keys t) "aaaaa") (deftest make-string.allow-other-keys.3 (make-string 5 :initial-element #\a :allow-other-keys t :bad t) "aaaaa") (deftest make-string.allow-other-keys.4 (make-string 5 :bad t :allow-other-keys t :allow-other-keys nil :initial-element #\a) "aaaaa") (deftest make-string.allow-other-keys.5 (make-string 5 :allow-other-keys t :bad t :allow-other-keys nil :initial-element #\a) "aaaaa") (deftest make-string.allow-other-keys.6 (make-string 5 :allow-other-keys t :allow-other-keys nil :bad nil :initial-element #\a) "aaaaa") (deftest make-string.keywords.7 (make-string 5 :initial-element #\a :initial-element #\b) "aaaaa") ;; Error cases (deftest make-string.error.1 (classify-error (make-string)) program-error) (deftest make-string.error.2 (classify-error (make-string 10 :bad t)) program-error) (deftest make-string.error.3 (classify-error (make-string 10 :bad t :allow-other-keys nil)) program-error) (deftest make-string.error.4 (classify-error (make-string 10 :initial-element)) program-error) (deftest make-string.error.5 (classify-error (make-string 10 1 1)) program-error) (deftest make-string.error.6 (classify-error (make-string 10 :element-type)) program-error) ;;; Order of evaluation (deftest make-string.order.1 (let ((i 0) a b) (values (make-string (progn (setf a (incf i)) 4) :initial-element (progn (setf b (incf i)) #\a)) i a b)) "aaaa" 2 1 2) (deftest make-string.order.2 (let ((i 0) a b c) (values (make-string (progn (setf a (incf i)) 4) :initial-element (progn (setf b (incf i)) #\a) :element-type (progn (setf c (incf i)) 'base-char)) i a b c)) "aaaa" 3 1 2 3) (deftest make-string.order.3 (let ((i 0) a b c) (values (make-string (progn (setf a (incf i)) 4) :element-type (progn (setf b (incf i)) 'base-char) :initial-element (progn (setf c (incf i)) #\a)) i a b c)) "aaaa" 3 1 2 3) gcl/ansi-tests/make-tar000077500000000000000000000001761242227143400153510ustar00rootroot00000000000000rm -f binary/* rt/binary/* tar cvf cltest.tar README *.system *.lsp make-tar binary/ rt/*.system rt/*.lsp rt/*.txt rt/binary/ gcl/ansi-tests/makefile000066400000000000000000000003661242227143400154230ustar00rootroot00000000000000-include ../makedefs test-unixport: echo "(load \"gclload.lsp\")" | ../unixport/saved_ansi_gcl$(EXE) | tee test.out test: echo "(load \"gclload.lsp\")" | gcl | tee test.out clean: rm -f test.out *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl gcl/ansi-tests/map-into.lsp000066400000000000000000000222561242227143400161710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 18 10:10:04 2002 ;;;; Contains: Tests for the MAP-INTO function (in-package :cl-test) (deftest map-into-list.1 (let ((a (copy-seq '(a b c d e f))) (b nil)) (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) (values a b)) (1 2 3 4 5 6) (6 5 4 3 2 1)) (deftest map-into-list.2 (let ((a (copy-seq '(a b c d e f g)))) (map-into a #'identity '(1 2 3)) a) (1 2 3 d e f g)) (deftest map-into-list.3 (let ((a (copy-seq '(a b c)))) (map-into a #'identity '(1 2 3 4 5 6)) a) (1 2 3)) (deftest map-into-list.4 (let ((a (copy-seq '(a b c d e f))) (b nil)) (map-into a #'(lambda (x y) (let ((z (+ x y))) (push z b) z)) '(1 2 3 4 5 6) '(10 11 12 13 14 15)) (values a b)) (11 13 15 17 19 21) (21 19 17 15 13 11)) (deftest map-into-list.5 (let ((a (copy-seq '(a b c d e f)))) (map-into a 'identity '(1 2 3 4 5 6)) a) (1 2 3 4 5 6)) (deftest map-into-list.6 (let ((b nil)) (values (map-into nil #'(lambda (x y) (let ((z (+ x y))) (push z b) z)) '(1 2 3 4 5 6) '(10 11 12 13 14 15)) b)) nil nil) (deftest map-into-list.7 (let ((a (copy-seq '(a b c d e f)))) (map-into a #'(lambda () 1)) a) (1 1 1 1 1 1)) (deftest map-into-list.8 (let ((a (copy-seq '(a b c d e f))) (s2 (make-array '(6) :initial-element 'x :fill-pointer 4))) (map-into a #'identity s2) a) (x x x x e f)) (deftest map-into-array.1 (let ((a (copy-seq #(a b c d e f))) b) (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) (values a b)) #(1 2 3 4 5 6) (6 5 4 3 2 1)) (deftest map-into-array.2 (let ((a (copy-seq #(a b c d e f g h))) b) (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) (values a b)) #(1 2 3 4 5 6 g h) (6 5 4 3 2 1)) (deftest map-into-array.3 (let ((a (copy-seq #(a b c d))) b) (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) (values a b)) #(1 2 3 4) (4 3 2 1)) (deftest map-into-array.4 (let ((a (copy-seq #(a b c d e f))) b) (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) (values a b)) #(1 2 3 4 5 6) (6 5 4 3 2 1)) (deftest map-into-array.5 (let ((a (copy-seq #(a b c d e f g h))) b) (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) (values a b)) #(1 2 3 4 5 6 g h) (6 5 4 3 2 1)) (deftest map-into-array.6 (let ((a (copy-seq #(a b c d))) b) (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) (values a b)) #(1 2 3 4) (4 3 2 1)) ;;; Tests of mapping into arrays with fill pointers (deftest map-into-array.7 (let ((a (make-array 6 :initial-element 'x :fill-pointer 3))) (map-into a #'identity '(1 2 3)) a) #(1 2 3)) (deftest map-into-array.8 (let ((a (make-array 6 :initial-element 'x :fill-pointer 3))) (map-into a #'identity '(1 2)) a) #(1 2)) (deftest map-into-array.9 (let ((a (make-array 6 :initial-element 'x :fill-pointer 3))) (map-into a #'identity '(1 2 3 4 5)) (and (eqlt (fill-pointer a) 5) a)) #(1 2 3 4 5)) (deftest map-into-array.10 (let ((a (make-array 6 :initial-element 'x :fill-pointer 3))) (map-into a #'(lambda () 'y)) (and (eqlt (fill-pointer a) 6) a)) #(y y y y y y)) (deftest map-into-array.11 (let ((a (copy-seq #(a b c d e f))) (s2 (make-array '(6) :initial-element 'x :fill-pointer 4))) (map-into a #'identity s2) a) #(x x x x e f)) ;;; mapping into strings (deftest map-into-string.1 (let ((a (copy-seq "abcdef"))) (map-into a #'identity "123456") (values (not (not (stringp a))) a)) t "123456") (deftest map-into-string.2 (let ((a (copy-seq "abcdef"))) (map-into a #'identity "1234") (values (not (not (stringp a))) a)) t "1234ef") (deftest map-into-string.3 (let ((a (copy-seq "abcd"))) (map-into a #'identity "123456") (values (not (not (stringp a))) a)) t "1234") (deftest map-into-string.4 (let ((a (make-array 6 :initial-element #\x :element-type 'character :fill-pointer 3))) (map-into a #'identity "abcde") (values (fill-pointer a) (aref a 5) a)) 5 #\x "abcde") (deftest map-into-string.5 (let ((a (make-array 6 :initial-element #\x :element-type 'character :fill-pointer 3))) (map-into a #'(lambda () #\y)) (values (fill-pointer a) a)) 6 "yyyyyy") (deftest map-into-string.6 (let ((a (make-array 6 :initial-element #\x :element-type 'character))) (map-into a #'(lambda () #\y)) a) "yyyyyy") (deftest map-into-string.7 (let ((a (make-array 6 :initial-element #\x :element-type 'base-char :fill-pointer 3))) (map-into a #'identity "abcde") (values (fill-pointer a) (aref a 5) a)) 5 #\x "abcde") (deftest map-into-string.8 (let ((a (make-array 6 :initial-element #\x :element-type 'base-char :fill-pointer 3))) (map-into a #'(lambda () #\y)) (values (fill-pointer a) a)) 6 "yyyyyy") (deftest map-into-string.9 (let ((a (make-array 6 :initial-element #\x :element-type 'base-char))) (map-into a #'(lambda () #\y)) a) "yyyyyy") (deftest map-into-string.10 (let ((a (copy-seq "abcdef")) (s2 (make-array '(6) :initial-element #\x :fill-pointer 4))) (map-into a #'identity s2) a) "xxxxef") (deftest map-into-string.11 (let ((a (make-array 6 :initial-element #\x :element-type 'character :fill-pointer 3))) (map-into a #'identity "abcd") (values (fill-pointer a) (aref a 4) (aref a 5) a)) 4 #\x #\x "abcd") (deftest map-into-string.12 (let ((a (make-array 6 :initial-element #\x :element-type 'character :fill-pointer 3))) (map-into a #'identity "abcdefgh") (values (fill-pointer a) a)) 6 "abcdef") ;;; Tests on bit vectors (deftest map-into.bit-vector.1 (let ((v (copy-seq #*0100110))) (map-into v #'(lambda (x) (- 1 x)) v) (and (bit-vector-p v) v)) #*1011001) (deftest map-into.bit-vector.2 (let ((v (copy-seq #*0100110))) (map-into v #'(lambda () 0)) (and (bit-vector-p v) v)) #*0000000) (deftest map-into.bit-vector.3 (let ((v (copy-seq #*0100110))) (map-into v #'identity '(0 1 1 1 0 0 1)) (and (bit-vector-p v) v)) #*0111001) (deftest map-into.bit-vector.4 (let ((v (copy-seq #*0100110))) (map-into v #'identity '(0 1 1 1)) (and (bit-vector-p v) v)) #*0111110) (deftest map-into.bit-vector.5 (let ((v (copy-seq #*0100110))) (map-into v #'identity '(0 1 1 1 0 0 1 4 5 6 7)) (and (bit-vector-p v) v)) #*0111001) (deftest map-into.bit-vector.6 (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) :fill-pointer 4 :element-type 'bit))) (map-into v #'(lambda () 1)) (and (bit-vector-p v) v)) #*11111111) (deftest map-into.bit-vector.7 (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) :fill-pointer 4 :element-type 'bit))) (map-into v #'identity v) (and (bit-vector-p v) v)) #*0100) (deftest map-into.bit-vector.8 (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) :fill-pointer 4 :element-type 'bit))) (map-into v #'identity '(1 1 1 1 1 1)) (and (bit-vector-p v) (values (fill-pointer v) v))) 6 #*111111) (deftest map-into.bit-vector.9 (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) :fill-pointer 4 :element-type 'bit))) (map-into v #'identity '(1 1 1 1 1 1 0 0 1 1 1)) (and (bit-vector-p v) (values (fill-pointer v) v))) 8 #*11111100) ;;; Error cases (deftest map-into.error.1 (classify-error (map-into 'a #'(lambda () nil))) type-error) ;;; The next test was changed because if the first argument ;;; is NIL, map-into is said to 'return nil immediately', so ;;; the 'should be prepared' notation for the error checking ;;; means that error checking may be skipped. (deftest map-into.error.2 (case (classify-error (map-into nil #'identity 'a)) ((nil type-error) 'good) (t 'bad)) good) (deftest map-into.error.3 (classify-error (map-into (copy-seq '(a b c)) #'cons '(d e f) 100)) type-error) (deftest map-into.error.4 (classify-error (map-into)) program-error) (deftest map-into.error.5 (classify-error (map-into (list 'a 'b 'c))) program-error) (deftest map-into.error.6 (classify-error (locally (map-into 'a #'(lambda () nil)) t)) type-error) (deftest map-into.error.7 (classify-error (map-into (list 'a 'b 'c) #'cons '(a b c))) program-error) (deftest map-into.error.8 (classify-error (map-into (list 'a 'b 'c) #'car '(a b c))) type-error) ;;; Order of evaluation tests (deftest map-into.order.1 (let ((i 0) a b c) (values (map-into (progn (setf a (incf i)) (list 1 2 3 4)) (progn (setf b (incf i)) #'identity) (progn (setf c (incf i)) '(a b c d))) i a b c)) (a b c d) 3 1 2 3) (deftest map-into.order.2 (let ((i 0) a b c d) (values (map-into (progn (setf a (incf i)) (list 1 2 3 4)) (progn (setf b (incf i)) #'list) (progn (setf c (incf i)) '(a b c d)) (progn (setf d (incf i)) '(e f g h))) i a b c d)) ((a e) (b f) (c g) (d h)) 4 1 2 3 4) gcl/ansi-tests/map.lsp000066400000000000000000000137011242227143400152150ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 17 20:54:48 2002 ;;;; Contains: Tests for the MAP function (in-package :cl-test) (deftest map-array.1 (map 'list #'1+ #(1 2 3 4)) (2 3 4 5)) (deftest map-array.2 (map 'vector #'+ #(1 2 3 4) #(6 6 6 6)) #(7 8 9 10)) (deftest map-array.3 (map 'vector #'+ #(1 2 3 4 5) #(6 6 6 6)) #(7 8 9 10)) (deftest map-array.4 (map 'vector #'+ #(1 2 3 4) #(6 6 6 6 6)) #(7 8 9 10)) (deftest map-array.5 (map '(vector *) #'+ #(1 2 3 4) #(6 6 6 6)) #(7 8 9 10)) (deftest map-array.6 (map '(vector * 4) #'+ #(1 2 3 4) #(6 6 6 6)) #(7 8 9 10)) ;;; (deftest map-array.7 ;;; (map 'array #'identity '(a b c d e f)) ;;; #(a b c d e f)) ;;; (deftest map-array.8 ;;; (map 'simple-array #'identity '(a b c d e f)) ;;; #(a b c d e f)) (deftest map-array.9 (map 'simple-vector #'identity '(a b c d e f)) #(a b c d e f)) (deftest map-array.10 (map 'simple-vector #'cons '(a b c d e f) #(1 2 3 4 5 6)) #((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) (deftest map-array.11 (map 'vector #'identity '(#\a #\b #\c #\d #\e)) #(#\a #\b #\c #\d #\e)) (deftest map-array.12 (map 'vector #'identity "abcde") #(#\a #\b #\c #\d #\e)) (deftest map-array.13 (map 'vector #'identity #*000001) #(0 0 0 0 0 1)) (deftest map-array.14 (map 'list #'identity #*000001) (0 0 0 0 0 1)) (deftest map-bit-vector.15 (map 'bit-vector #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.16 (map 'simple-bit-vector #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.17 (map '(vector bit) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.18 (map '(simple-vector *) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.19 (map '(bit-vector 6) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.20 (map '(bit-vector *) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.21 (map '(simple-bit-vector 6) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.22 (map '(simple-bit-vector *) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.23 (map '(vector bit 6) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.24 (map '(vector bit *) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.25 (map '(simple-vector 6) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-string.26 (map 'string #'identity '(#\a #\b #\c #\d #\e)) "abcde") (deftest map-string.27 (map 'string #'identity "abcde") "abcde") (deftest map-string.28 (map '(vector character) #'identity '(#\a #\b #\c #\d #\e)) "abcde") (deftest map-string.29 (map '(vector character 5) #'identity '(#\a #\b #\c #\d #\e)) "abcde") (deftest map-string.30 (map '(simple-vector 5) #'identity '(#\a #\b #\c #\d #\e)) "abcde") ;;; Use a more elaborate form of the simple-array type specifier ;;; (deftest map-string.31 ;;; (map '(simple-array character *) #'identity "abcde") ;;; "abcde") ;;; Use a more elaborate form of the simple-array type specifier ;;; (deftest map-string.32 ;;; (map '(simple-array character 5) #'identity "abcde") ;;; "abcde") (deftest map-nil.33 (let ((a nil)) (values (map nil #'(lambda (x) (push x a)) "abcdef") a)) nil (#\f #\e #\d #\c #\b #\a)) (deftest map-nil.34 (let ((a nil)) (values (map nil #'(lambda (x) (push x a)) '(a b c d e)) a)) nil (e d c b a)) (deftest map-nil.35 (let ((a nil)) (values (map nil #'(lambda (x) (push x a)) #(a b c d e)) a)) nil (e d c b a)) (deftest map-nil.36 (let ((a nil)) (values (map nil #'(lambda (x) (push x a)) #*001011110) a)) nil (0 1 1 1 1 0 1 0 0)) (deftest map-null.1 (map 'null #'identity nil) nil) (deftest map-cons.1 (map 'cons #'identity '(a b c)) (a b c)) (deftest map.error.1 (handler-case (progn (proclaim '(optimize (safety 3))) (eval '(map 'symbol #'identity '(a b c)))) (error () :caught)) :caught) (deftest map.error.2 (classify-error (map '(vector * 8) #'identity '(a b c))) type-error) (deftest map.error.3 (classify-error (map 'list #'identity '(a b . c))) type-error) (deftest map.error.4 (classify-error (map)) program-error) (deftest map.error.5 (classify-error (map 'list)) program-error) (deftest map.error.6 (classify-error (map 'list #'null)) program-error) (deftest map.error.7 (classify-error (map 'list #'cons '(a b c d))) program-error) (deftest map.error.8 (classify-error (map 'list #'cons '(a b c d) '(1 2 3 4) '(5 6 7 8))) program-error) (deftest map.error.9 (classify-error (map 'list #'car '(a b c d))) type-error) ;;; Test mapping on arrays with fill pointers (deftest map.fill.1 (let ((s1 (make-array '(10) :initial-contents '(a b c d e f g h i j) :fill-pointer 8))) (map 'list #'identity s1)) (a b c d e f g h)) (deftest map.fill.2 (let ((s1 (make-array '(10) :initial-contents '(a b c d e f g h i j) :fill-pointer 8))) (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) (1 2 3 4 5 6 7 8)) (deftest map.fill.3 (let ((s1 (make-array '(10) :initial-element #\a :element-type 'character :fill-pointer 8))) (map 'string #'identity s1)) "aaaaaaaa") (deftest map.fill.4 (let ((s1 (make-array '(10) :initial-element #\a :element-type 'base-char :fill-pointer 8))) (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) (1 2 3 4 5 6 7 8)) (deftest map.fill.5 (let ((s1 (make-array '(10) :initial-element 0 :element-type 'bit :fill-pointer 8))) (map 'bit-vector #'identity s1)) #*00000000) (deftest map.fill.6 (let ((s1 (make-array '(10) :initial-element 1 :element-type 'bit :fill-pointer 8))) (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) (1 2 3 4 5 6 7 8)) ;;; Order of evaluation tests (deftest map.order.1 (let ((i 0) a b c d) (values (map (progn (setf a (incf i)) 'list) (progn (setf b (incf i)) #'list) (progn (setf c (incf i)) '(a b c)) (progn (setf d (incf i)) '(b c d))) i a b c d)) ((a b)(b c)(c d)) 4 1 2 3 4) gcl/ansi-tests/merge.lsp000066400000000000000000000313751242227143400155460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Sep 6 07:24:17 2002 ;;;; Contains: Tests for MERGE (in-package :cl-test) (deftest merge-list.1 (let ((x (list 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'list x y #'<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.2 (let ((x nil) (y (list 2 4 5 8 11))) (merge 'list x y #'<)) (2 4 5 8 11)) (deftest merge-list.3 (let ((x nil) (y (list 2 4 5 8 11))) (merge 'list y x #'<)) (2 4 5 8 11)) (deftest merge-list.4 (merge 'list nil nil #'<) nil) (deftest merge-list.5 (let ((x (vector 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'list x y #'<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.6 (let ((x (list 1 3 7 8 10)) (y (vector 2 4 5 8 11))) (merge 'list x y #'<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.7 (let ((x (vector 1 3 7 8 10)) (y (vector 2 4 5 8 11))) (merge 'list x y #'<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.8 (let ((x (sort (list 1 3 7 8 10) #'>)) (y (sort (list 2 4 5 8 11) #'>))) (merge 'list x y #'< :key #'-)) (11 10 8 8 7 5 4 3 2 1)) (deftest merge-list.9 (let ((x (list 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'list x y #'< :key nil)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.10 (let ((x (list 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'list x y '<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.11 (let ((x (vector)) (y (vector))) (merge 'list x y #'<)) nil) (deftest merge-list.12 (let ((x nil) (y (vector 1 2 3))) (merge 'list x y #'<)) (1 2 3)) (deftest merge-list.13 (let ((x (vector)) (y (list 1 2 3))) (merge 'list x y #'<)) (1 2 3)) (deftest merge-list.14 (let ((x nil) (y (vector 1 2 3))) (merge 'list y x #'<)) (1 2 3)) (deftest merge-list.15 (let ((x (vector)) (y (list 1 2 3))) (merge 'list y x #'<)) (1 2 3)) ;;; Tests yielding vectors (deftest merge-vector.1 (let ((x (list 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'vector x y #'<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.2 (let ((x nil) (y (list 2 4 5 8 11))) (merge 'vector x y #'<)) #(2 4 5 8 11)) (deftest merge-vector.3 (let ((x nil) (y (list 2 4 5 8 11))) (merge 'vector y x #'<)) #(2 4 5 8 11)) (deftest merge-vector.4 (merge 'vector nil nil #'<) #()) (deftest merge-vector.5 (let ((x (vector 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'vector x y #'<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.6 (let ((x (list 1 3 7 8 10)) (y (vector 2 4 5 8 11))) (merge 'vector x y #'<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.7 (let ((x (vector 1 3 7 8 10)) (y (vector 2 4 5 8 11))) (merge 'vector x y #'<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.8 (let ((x (sort (list 1 3 7 8 10) #'>)) (y (sort (list 2 4 5 8 11) #'>))) (merge 'vector x y #'< :key #'-)) #(11 10 8 8 7 5 4 3 2 1)) (deftest merge-vector.9 (let ((x (list 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'vector x y #'< :key nil)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.10 (let ((x (list 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'vector x y '<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.11 (let ((x (vector)) (y (vector))) (merge 'vector x y #'<)) #()) (deftest merge-vector.12 (let ((x nil) (y (vector 1 2 3))) (merge 'vector x y #'<)) #(1 2 3)) (deftest merge-vector.13 (let ((x (vector)) (y (list 1 2 3))) (merge 'vector x y #'<)) #(1 2 3)) (deftest merge-vector.14 (let ((x nil) (y (vector 1 2 3))) (merge 'vector y x #'<)) #(1 2 3)) (deftest merge-vector.15 (let ((x (vector)) (y (list 1 2 3))) (merge 'vector y x #'<)) #(1 2 3)) (deftest merge-vector.16 (let ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) :fill-pointer 5)) (y (list 1 6 10))) (merge 'vector x y #'<)) #(1 2 5 6 8 9 10 11)) (deftest merge-vector.16a (let ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) :fill-pointer 5)) (y (list 1 6 10))) (merge 'vector y x #'<)) #(1 2 5 6 8 9 10 11)) (deftest merge-vector.17 (let* ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) :fill-pointer 5)) (result (merge 'vector x () #'<))) (values (array-element-type result) result)) t #(2 5 8 9 11)) ;;; Tests on strings (deftest merge-string.1 (let ((x (list #\1 #\3 #\7 #\8)) (y (list #\2 #\4 #\5 #\9))) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1a (let ((x "1378") (y (list #\2 #\4 #\5 #\9))) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1b (let ((x (list #\1 #\3 #\7 #\8)) (y "2459")) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1c (let ((x "1378") (y "2459")) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1d (let ((x "1378") (y "2459")) (merge 'string y x #'char<)) "12345789") (deftest merge-string.2 (let ((x nil) (y (list #\2 #\4 #\5 #\9))) (merge 'string x y #'char<)) "2459") (deftest merge-string.3 (let ((x nil) (y (list #\2 #\4 #\5 #\9))) (merge 'string y x #'char<)) "2459") (deftest merge-string.4 (merge 'string nil nil #'char<) "") (deftest merge-string.8 (let ((x (list #\1 #\3 #\7 #\8)) (y (list #\2 #\4 #\5))) (merge 'string x y #'char< :key #'nextdigit)) "1234578") (deftest merge-string.9 (let ((x (list #\1 #\3 #\7 #\8)) (y (list #\2 #\4 #\5 #\9))) (merge 'string x y #'char< :key nil)) "12345789") (deftest merge-string.10 (let ((x (list #\1 #\3 #\7 #\8)) (y (list #\2 #\4 #\5 #\9))) (merge 'string x y 'char<)) "12345789") (deftest merge-string.11 (let ((x (vector)) (y (vector))) (merge 'string x y #'char<)) "") (deftest merge-string.12 (let ((x nil) (y (vector #\1 #\2 #\3))) (merge 'string x y #'char<)) "123") (deftest merge-string.13 (let ((x (vector)) (y (list #\1 #\2 #\3))) (merge 'string x y #'char<)) "123") (deftest merge-string.13a (let ((x (copy-seq "")) (y (list #\1 #\2 #\3))) (merge 'string x y #'char<)) "123") (deftest merge-string.14 (let ((x nil) (y (vector #\1 #\2 #\3))) (merge 'string y x #'char<)) "123") (deftest merge-string.14a (let ((x (copy-seq "")) (y (vector #\1 #\2 #\3))) (merge 'string y x #'char<)) "123") (deftest merge-string.15 (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" :fill-pointer 5 :element-type 'character)) (y (copy-seq "bci"))) (merge 'string x y #'char<)) "abcdgikm") (deftest merge-string.16 (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" :fill-pointer 5 :element-type 'character)) (y (copy-seq "bci"))) (merge 'string y x #'char<)) "abcdgikm") (deftest merge-string.17 (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" :fill-pointer 5 :element-type 'character))) (merge 'string nil x #'char<)) "adgkm") (deftest merge-string.18 (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" :fill-pointer 5 :element-type 'character))) (merge 'string x nil #'char<)) "adgkm") ;;; Tests for bit vectors (deftest merge-bit-vector.1 (let ((x (list 0 0 1 1 1)) (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.2 (let ((x nil) (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*00011) (deftest merge-bit-vector.3 (let ((x nil) (y (list 0 0 0 1 1))) (merge 'bit-vector y x #'<)) #*00011) (deftest merge-bit-vector.4 (merge 'bit-vector nil nil #'<) #*) (deftest merge-bit-vector.5 (let ((x (vector 0 0 1 1 1)) (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5a (let ((x (copy-seq #*00111)) (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5b (let ((x (list 0 0 1 1 1)) (y (copy-seq #*00011))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5c (let ((x (copy-seq #*00111)) (y (copy-seq #*00011))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5d (let ((x (copy-seq #*11111)) (y (copy-seq #*00000))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5e (let ((x (copy-seq #*11111)) (y (copy-seq #*00000))) (merge 'bit-vector y x #'<)) #*0000011111) (deftest merge-bit-vector.6 (let ((x (list 0 0 1 1 1)) (y (vector 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.7 (let ((x (vector 0 0 1 1 1)) (y (vector 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.8 (let ((x (list 1 1 1 0 0)) (y (list 1 1 0 0 0))) (merge 'bit-vector x y #'< :key #'-)) #*1111100000) (deftest merge-bit-vector.9 (let ((x (list 0 0 1 1 1)) (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'< :key nil)) #*0000011111) (deftest merge-bit-vector.10 (let ((x (list 0 0 1 1 1)) (y (list 0 0 0 1 1))) (merge 'bit-vector x y '<)) #*0000011111) (deftest merge-bit-vector.11 (let ((x (copy-seq #*)) (y (copy-seq #*))) (merge 'bit-vector x y #'<)) #*) (deftest merge-bit-vector.12 (let ((x (copy-seq #*)) (y (copy-seq #*011))) (merge 'bit-vector x y #'<)) #*011) (deftest merge-bit-vector.13 (let ((x (copy-seq #*)) (y (list 0 1 1))) (merge 'bit-vector x y #'<)) #*011) (deftest merge-bit-vector.14 (let ((x nil) (y (vector 0 1 1))) (merge 'bit-vector y x #'<)) #*011) (deftest merge-bit-vector.15 (let ((x (copy-seq #*)) (y (list 0 1 1))) (merge 'bit-vector y x #'<)) #*011) (deftest merge-bit-vector.16 (let* ((x (make-array '(10) :initial-contents #*0001101010 :fill-pointer 5 :element-type 'bit)) (y (copy-seq #*001))) (merge 'bit-vector x y #'<)) #*00000111) (deftest merge-bit-vector.17 (let* ((x (make-array '(10) :initial-contents #*0001101010 :fill-pointer 5 :element-type 'bit)) (y (copy-seq #*001))) (merge 'bit-vector y x #'<)) #*00000111) (deftest merge-bit-vector.18 (let* ((x (make-array '(10) :initial-contents #*0001101010 :fill-pointer 5 :element-type 'bit))) (merge 'bit-vector nil x #'<)) #*00011) (deftest merge-bit-vector.19 (let* ((x (make-array '(10) :initial-contents #*0001101010 :fill-pointer 5 :element-type 'bit))) (merge 'bit-vector x nil #'<)) #*00011) ;;; Cons (which is a recognizable subtype of list) (deftest merge-cons.1 (merge 'cons (list 1 2 3) (list 4 5 6) #'<) (1 2 3 4 5 6)) ;;; Null, which is a recognizable subtype of list (deftest merge-null.1 (merge 'null nil nil #'<) nil) ;;; Vectors with length (deftest merge-vector-length.1 (merge '(vector * 6) (list 1 2 3) (list 4 5 6) #'<) #(1 2 3 4 5 6)) (deftest merge-bit-vector-length.1 (merge '(bit-vector 6) (list 0 1 1) (list 0 0 1) #'<) #*000111) ;;; Order of evaluation (deftest merge.order.1 (let ((i 0) a b c d) (values (merge (progn (setf a (incf i)) 'list) (progn (setf b (incf i)) (list 2 5 6)) (progn (setf c (incf i)) (list 1 3 4)) (progn (setf d (incf i)) #'<)) i a b c d)) (1 2 3 4 5 6) 4 1 2 3 4) ;;; Tests of error situations (deftest merge.error.1 (handler-case (eval '(locally (declare (optimize (safety 3))) (merge 'symbol (list 1 2 3) (list 4 5 6) #'<))) (error () :caught)) :caught) (deftest merge.error.2 (classify-error (merge '(vector * 3) (list 1 2 3) (list 4 5 6) #'<)) type-error) (deftest merge.error.3 (classify-error (merge '(bit-vector 3) (list 0 0 0) (list 1 1 1) #'<)) type-error) (deftest merge.error.4 (classify-error (merge '(vector * 7) (list 1 2 3) (list 4 5 6) #'<)) type-error) (deftest merge.error.5 (classify-error (merge '(bit-vector 7) (list 0 0 0) (list 1 1 1) #'<)) type-error) (deftest merge.error.6 (classify-error (merge 'null (list 1 2 3) (list 4 5 6) #'<)) type-error) (deftest merge.error.7 (classify-error (merge)) program-error) (deftest merge.error.8 (classify-error (merge 'list)) program-error) (deftest merge.error.9 (classify-error (merge 'list (list 2 4 6))) program-error) (deftest merge.error.10 (classify-error (merge 'list (list 2 4 6) (list 1 3 5))) program-error) (deftest merge.error.11 (classify-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t)) program-error) (deftest merge.error.12 (classify-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :key)) program-error) (deftest merge.error.13 (classify-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t :allow-other-keys nil)) program-error) (deftest merge.error.14 (classify-error (merge 'list (list 2 4 6) (list 1 3 5) #'< 1 2)) program-error) (deftest merge.error.15 (classify-error (locally (merge '(vector * 3) (list 1 2 3) (list 4 5 6) #'<) t)) type-error) (deftest merge.error.16 (classify-error (merge 'list (list 1 2) (list 3 4) #'car)) program-error) (deftest merge.error.17 (classify-error (merge 'list (list 'a 'b) (list 3 4) #'max)) type-error) gcl/ansi-tests/mismatch.lsp000066400000000000000000000401401242227143400162420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 26 23:55:29 2002 ;;;; Contains: Tests for MISMATCH (in-package :cl-test) (deftest mismatch-list.1 (mismatch '() '(a b c)) 0) (deftest mismatch-list.2 (mismatch '(a b c d) '()) 0) (deftest mismatch-list.3 (mismatch '(a b c) '(a b c)) nil) (deftest mismatch-list.4 (mismatch '(a b c) '(a b d)) 2) (deftest mismatch-list.5 (mismatch '(a b c) '(b c) :start1 1) nil) (deftest mismatch-list.6 (mismatch '(a b c d) '(z b c e) :start1 1 :start2 1) 3) (deftest mismatch-list.7 (mismatch '(a b c d) '(z b c e) :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-list.8 (mismatch '(1 2 3 4) '(5 6 7 8) :test #'(lambda (x y) (= x (- y 4)))) nil) (deftest mismatch-list.9 (mismatch '(1 2 3 4) '(5 6 17 8) :test #'(lambda (x y) (= x (- y 4)))) 2) (deftest mismatch-list.10 (mismatch '(1 2 3 4) '(10 11 7 123) :test-not #'(lambda (x y) (= x (- y 4)))) 2) (deftest mismatch-list.11 (mismatch '(1 2 3 4) '(5 6 17 8) :key #'evenp) nil) (deftest mismatch-list.12 (mismatch '(1 2 3 4) '(5 6 12 8) :key 'oddp) 2) (deftest mismatch-list.13 (mismatch '(1 2 3 4) '(1 2 3 4) :test 'eql) nil) (deftest mismatch-list.14 (mismatch '(1 2 3 4) '(5 6 7 8) :test-not 'eql) nil) (deftest mismatch-list.15 (mismatch '(a b c d e f g h i j k) '(a b c c e f g h z j k)) 3) (deftest mismatch-list.16 (mismatch '(a b c d e f g h i j k) '(a b c c y f g h z j k) :from-end t) 9) (deftest mismatch-list.17 (mismatch '(a b c) '(a b c a b c d) :from-end t) 3) (deftest mismatch-list.18 (mismatch '(a b c a b c d) '(a b c) :from-end t) 7) (deftest mismatch-list.19 (mismatch '(1 1 1) '(2 2 2 2 2 1 2 2) :from-end t :test-not 'eql) 1) (deftest mismatch-list.20 (mismatch '(1 1 1 1 1 1 1) '(2 3 3) :from-end t :key #'evenp) 5) (deftest mismatch-list.21 (mismatch '(1 1 1) '(2 2 2 2 2 1 2 2) :from-end t :test-not #'equal) 1) (deftest mismatch-list.22 (mismatch '(1 1 1 1 1 1 1) '(2 3 3) :from-end t :key 'evenp) 5) ;;; tests on vectors (deftest mismatch-vector.1 (mismatch #() #(a b c)) 0) (deftest mismatch-vector.2 (mismatch #(a b c d) #()) 0) (deftest mismatch-vector.3 (mismatch #(a b c) #(a b c)) nil) (deftest mismatch-vector.4 (mismatch #(a b c) #(a b d)) 2) (deftest mismatch-vector.5 (mismatch #(a b c) #(b c) :start1 1) nil) (deftest mismatch-vector.6 (mismatch #(a b c d) #(z b c e) :start1 1 :start2 1) 3) (deftest mismatch-vector.7 (mismatch #(a b c d) #(z b c e) :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-vector.8 (mismatch #(1 2 3 4) #(5 6 7 8) :test #'(lambda (x y) (= x (- y 4)))) nil) (deftest mismatch-vector.9 (mismatch #(1 2 3 4) #(5 6 17 8) :test #'(lambda (x y) (= x (- y 4)))) 2) (deftest mismatch-vector.10 (mismatch #(1 2 3 4) #(10 11 7 123) :test-not #'(lambda (x y) (= x (- y 4)))) 2) (deftest mismatch-vector.11 (mismatch #(1 2 3 4) #(5 6 17 8) :key #'evenp) nil) (deftest mismatch-vector.12 (mismatch #(1 2 3 4) #(5 6 12 8) :key 'oddp) 2) (deftest mismatch-vector.13 (mismatch #(1 2 3 4) #(1 2 3 4) :test 'eql) nil) (deftest mismatch-vector.14 (mismatch #(1 2 3 4) #(5 6 7 8) :test-not 'eql) nil) (deftest mismatch-vector.15 (mismatch #(a b c d e f g h i j k) #(a b c c e f g h z j k)) 3) (deftest mismatch-vector.16 (mismatch #(a b c d e f g h i j k) #(a b c c y f g h z j k) :from-end t) 9) (deftest mismatch-vector.17 (mismatch #(a b c) #(a b c a b c d) :from-end t) 3) (deftest mismatch-vector.18 (mismatch #(a b c a b c d) #(a b c) :from-end t) 7) (deftest mismatch-vector.19 (mismatch #(1 1 1) #(2 2 2 2 2 1 2 2) :from-end t :test-not 'eql) 1) (deftest mismatch-vector.20 (mismatch #(1 1 1 1 1 1 1) #(2 3 3) :from-end t :key #'evenp) 5) (deftest mismatch-vector.21 (mismatch #(1 1 1) #(2 2 2 2 2 1 2 2) :from-end t :test-not #'equal) 1) (deftest mismatch-vector.22 (mismatch #(1 1 1 1 1 1 1) #(2 3 3) :from-end t :key 'evenp) 5) (deftest mismatch-vector.23 (let ((a (make-array '(9) :initial-contents '(1 2 3 4 5 6 7 8 9) :fill-pointer 5))) (values (mismatch '(1 2 3 4 5) a) (mismatch '(1 2 3 4 5) a :from-end t) (mismatch '(1 2 3 4) a) (mismatch '(1 2 3 4 5 6) a) (mismatch '(6 7 8 9) a :from-end t) (mismatch '(2 3 4 5) a :from-end t))) nil nil 4 5 4 0) (deftest mismatch-vector.24 (let ((m (make-array '(6) :initial-contents '(1 2 3 4 5 6) :fill-pointer 4)) (a '(1 2 3 4 5))) (list (mismatch m a) (mismatch m a :from-end t) (setf (fill-pointer m) 5) (mismatch m a) (mismatch m a :from-end t) (setf (fill-pointer m) 6) (mismatch m a) (mismatch m a :from-end t))) (4 4 5 nil nil 6 5 6)) ;;; tests on bit vectors (deftest mismatch-bit-vector.1 (mismatch "" #*111) 0) (deftest mismatch-bit-vector.1a (mismatch '() #*111) 0) (deftest mismatch-bit-vector.1b (mismatch "" '(1 1 1)) 0) (deftest mismatch-bit-vector.2 (mismatch #*1010 #*) 0) (deftest mismatch-bit-vector.2a (mismatch #*1010 '()) 0) (deftest mismatch-bit-vector.2b (mismatch '(1 0 1 0) #*) 0) (deftest mismatch-bit-vector.3 (mismatch #*101 #*101) nil) (deftest mismatch-bit-vector.4 (mismatch #*101 #*100) 2) (deftest mismatch-bit-vector.5 (mismatch #*101 #*01 :start1 1) nil) (deftest mismatch-bit-vector.6 (mismatch #*0110 #*0111 :start1 1 :start2 1) 3) (deftest mismatch-bit-vector.7 (mismatch #*0110 #*0111 :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-bit-vector.7a (mismatch '(0 1 1 0) #*0111 :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-bit-vector.7b (mismatch #*0110 '(0 1 1 1) :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-bit-vector.8 (mismatch #*1001 #*0110 :test #'(lambda (x y) (= x (- 1 y)))) nil) (deftest mismatch-bit-vector.8a (mismatch #*1001 '(5 4 4 5) :test #'(lambda (x y) (= x (- y 4)))) nil) (deftest mismatch-bit-vector.9 (mismatch #*1001 '(5 4 17 5) :test #'(lambda (x y) (= x (- y 4)))) 2) (deftest mismatch-bit-vector.9a (mismatch '(5 4 17 5) #*1001 :test #'(lambda (x y) (= y (- x 4)))) 2) (deftest mismatch-bit-vector.9b (mismatch #*0100 #*1001 :test #'(lambda (x y) (= x (- 1 y)))) 2) (deftest mismatch-bit-vector.10 (mismatch #*1001 '(10 11 4 123) :test-not #'(lambda (x y) (= x (- y 4)))) 2) (deftest mismatch-bit-vector.10a (mismatch #*1001 '(10 11 100 123) :test-not #'(lambda (x y) (= x (- y 4)))) nil) (deftest mismatch-bit-vector.11 (mismatch #*1010 '(5 6 17 8) :key #'evenp) nil) (deftest mismatch-bit-vector.11a (mismatch '(5 6 17 8) #*1010 :key #'evenp) nil) (deftest mismatch-bit-vector.11b (mismatch #*0101 #*1010 :key #'evenp :test-not 'eql) nil) (deftest mismatch-bit-vector.11c (mismatch '(5 6 17 8) #*10101 :key #'evenp) 4) (deftest mismatch-bit-vector.11d (mismatch '(5 6 17 8 100) #*1010 :key #'evenp) 4) (deftest mismatch-bit-vector.12 (mismatch #*1010 #*1000 :key 'oddp) 2) (deftest mismatch-bit-vector.12a (mismatch #*1010 '(5 6 8 8) :key 'oddp) 2) (deftest mismatch-bit-vector.12b (mismatch '(5 6 8 8) #*1010 :key 'oddp) 2) (deftest mismatch-bit-vector.13 (mismatch #*0001 #*0001 :test 'eql) nil) (deftest mismatch-bit-vector.14 (mismatch '#*10001 #*01110 :test-not 'eql) nil) (deftest mismatch-bit-vector.15 (mismatch #*00100010100 #*00110010000) 3) (deftest mismatch-bit-vector.16 (mismatch #*00100010100 #*00110010000 :from-end t) 9) (deftest mismatch-bit-vector.17 (mismatch #*001 #*0010010 :from-end t) 3) (deftest mismatch-bit-vector.18 (mismatch #*0010010 #*001 :from-end t) 7) (deftest mismatch-bit-vector.19 (mismatch #*000 #*11111011 :from-end t :test-not 'eql) 1) (deftest mismatch-bit-vector.20 (mismatch #*1111111 '(2 3 3) :from-end t :key #'evenp) 5) (deftest mismatch-bit-vector.21 (mismatch #*111 #*00000100 :from-end t :test-not #'equal) 1) (deftest mismatch-bit-vector.22 (mismatch #*1111111 '(2 3 3) :from-end t :key 'evenp) 5) (deftest mismatch-bit-vector.23 (let ((a (make-array '(9) :initial-contents #*001011000 :fill-pointer 5 :element-type 'bit))) (values (mismatch #*00101 a) (mismatch #*00101 a :from-end t) (mismatch #*0010 a) (mismatch #*001011 a) (mismatch #*1000 a :from-end t) (mismatch #*0010 a :from-end t))) nil nil 4 5 4 4) (deftest mismatch-bit-vector.24 (let ((m (make-array '(6) :initial-contents #*001011 :fill-pointer 4 :element-type 'bit)) (a #*00101)) (list (mismatch m a) (mismatch m a :from-end t) (setf (fill-pointer m) 5) (mismatch m a) (mismatch m a :from-end t) (setf (fill-pointer m) 6) (mismatch m a) (mismatch m a :from-end t))) (4 4 5 nil nil 6 5 5)) ;;; tests on strings (deftest mismatch-string.1 (mismatch "" "111") 0) (deftest mismatch-string.1a (mismatch '() "111") 0) (deftest mismatch-string.1b (mismatch "" '(1 1 1)) 0) (deftest mismatch-string.2 (mismatch "1010" "") 0) (deftest mismatch-string.2a (mismatch "1010" '()) 0) (deftest mismatch-string.2b (mismatch '(1 0 1 0) "") 0) (deftest mismatch-string.3 (mismatch "101" "101") nil) (deftest mismatch-string.4 (mismatch "101" "100") 2) (deftest mismatch-string.5 (mismatch "101" "01" :start1 1) nil) (deftest mismatch-string.6 (mismatch "0110" "0111" :start1 1 :start2 1) 3) (deftest mismatch-string.7 (mismatch "0110" "0111" :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-string.7a (mismatch '(#\0 #\1 #\1 #\0) "0111" :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-string.7b (mismatch "0110" '(#\0 #\1 #\1 #\1) :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-string.8 (mismatch "1001" "0110" :test #'(lambda (x y) (eql x (if (eql y #\0) #\1 #\0)))) nil) (deftest mismatch-string.8a (mismatch "1001" '(5 4 4 5) :test #'(lambda (x y) (setq x (read-from-string (string x))) (= x (- y 4)))) nil) (deftest mismatch-string.9 (mismatch "1001" '(5 4 17 5) :test #'(lambda (x y) (setq x (read-from-string (string x))) (= x (- y 4)))) 2) (deftest mismatch-string.9a (mismatch '(5 4 17 5) "1001" :test #'(lambda (x y) (setq y (read-from-string (string y))) (= y (- x 4)))) 2) (deftest mismatch-string.9b (mismatch "0100" "1001" :test #'(lambda (x y) (eql x (if (eql y #\0) #\1 #\0)))) 2) (deftest mismatch-string.10 (mismatch "1001" "0049" :test-not #'(lambda (x y) (setq x (read-from-string (string x))) (setq y (read-from-string (string y))) (eql x (- y 4)))) 2) (deftest mismatch-string.10a (mismatch "1001" "3333" :test-not #'(lambda (x y) (setq x (read-from-string (string x))) (setq y (read-from-string (string y))) (eql x (- y 4)))) nil) (deftest mismatch-string.11 (mismatch "1010" "5678" :key #'evendigitp) nil) (deftest mismatch-string.11a (mismatch "5678" "1010" :key #'odddigitp) nil) (deftest mismatch-string.11b (mismatch "0101" "1010" :key #'evendigitp :test-not 'eql) nil) (deftest mismatch-string.11c (mismatch "5678" "10101" :key #'evendigitp) 4) (deftest mismatch-string.11d (mismatch "56122" "1010" :key #'evendigitp) 4) (deftest mismatch-string.11e (mismatch "0101" '(#\1 #\0 #\1 #\0) :key #'evendigitp :test-not 'eql) nil) (deftest mismatch-string.12 (mismatch "1010" "1000" :key 'odddigitp) 2) (deftest mismatch-string.12a (mismatch "1010" "5688" :key 'odddigitp) 2) (deftest mismatch-string.12b (mismatch '(#\5 #\6 #\8 #\8) "1010" :key 'odddigitp) 2) (deftest mismatch-string.13 (mismatch "0001" "0001" :test 'eql) nil) (deftest mismatch-string.14 (mismatch "10001" "01110" :test-not 'eql) nil) (deftest mismatch-string.15 (mismatch "00100010100" "00110010000") 3) (deftest mismatch-string.16 (mismatch "00100010100" "00110010000" :from-end t) 9) (deftest mismatch-string.17 (mismatch "001" "0010010" :from-end t) 3) (deftest mismatch-string.18 (mismatch "0010010" "001" :from-end t) 7) (deftest mismatch-string.19 (mismatch "000" "11111011" :from-end t :test-not 'eql) 1) (deftest mismatch-string.20 (mismatch "1111111" "233" :from-end t :key #'evendigitp) 5) (deftest mismatch-string.20a (mismatch "1111111" '(#\2 #\3 #\3) :from-end t :key #'evendigitp) 5) (deftest mismatch-string.21 (mismatch "111" "00000100" :from-end t :test-not #'equal) 1) (deftest mismatch-string.22 (mismatch "1111111" "233" :from-end t :key 'evendigitp) 5) (deftest mismatch-string.23 (let ((a (make-array '(9) :initial-contents "123456789" :fill-pointer 5 :element-type 'character))) (values (mismatch "12345" a) (mismatch "12345" a :from-end t) (mismatch "1234" a) (mismatch "123456" a) (mismatch "6789" a :from-end t) (mismatch "2345" a :from-end t))) nil nil 4 5 4 0) (deftest mismatch-string.24 (let ((m (make-array '(6) :initial-contents "123456" :fill-pointer 4 :element-type 'character)) (a "12345")) (list (mismatch m a) (mismatch m a :from-end t) (setf (fill-pointer m) 5) (mismatch m a) (mismatch m a :from-end t) (setf (fill-pointer m) 6) (mismatch m a) (mismatch m a :from-end t))) (4 4 5 nil nil 6 5 6)) ;;; Keyword tests (deftest mismatch.allow-other-keys.1 (mismatch "1234" "1244" :allow-other-keys t :bad t) 2) (deftest mismatch.allow-other-keys.2 (mismatch "1234" "1244" :bad t :allow-other-keys t) 2) (deftest mismatch.allow-other-keys.3 (mismatch "1234" "1244" :bad t :allow-other-keys t :allow-other-keys nil) 2) (deftest mismatch.allow-other-keys.4 (mismatch "1234" "1244" :allow-other-keys t :bad t :allow-other-keys nil) 2) (deftest mismatch.allow-other-keys.5 (mismatch "1234" "1244" :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest mismatch.keywords.6 (mismatch "1234" "1244" :test #'equal :test (complement #'equal)) 2) (deftest mismatch.allow-other-keys.7 (mismatch "1234" "1244" :bad t :allow-other-keys t :test (complement #'equal)) 0) ;;; Order of evaluation (deftest mismatch.order.1 (let ((i 0) a b) (values (mismatch (progn (setf a (incf i)) "abcd") (progn (setf b (incf i)) "abzd")) i a b)) 2 2 1 2) (deftest mismatch.order.2 (let ((i 0) a b c d e f g h j) (values (mismatch (progn (setf a (incf i)) "abcdef") (progn (setf b (incf i)) "abcdef") :key (progn (setf c (incf i)) #'identity) :test (progn (setf d (incf i)) #'equal) :start1 (progn (setf e (incf i)) 1) :start2 (progn (setf f (incf i)) 1) :end1 (progn (setf g (incf i)) 4) :end2 (progn (setf h (incf i)) 4) :from-end (setf j (incf i))) i a b c d e f g h j)) nil 9 1 2 3 4 5 6 7 8 9) (deftest mismatch.order.3 (let ((i 0) a b c d e f g h j) (values (mismatch (progn (setf a (incf i)) "abcdef") (progn (setf b (incf i)) "abcdef") :from-end (setf c (incf i)) :end2 (progn (setf d (incf i)) 4) :end1 (progn (setf e (incf i)) 4) :start2 (progn (setf f (incf i)) 1) :start1 (progn (setf g (incf i)) 1) :test (progn (setf h (incf i)) #'equal) :key (progn (setf j (incf i)) #'identity)) i a b c d e f g h j)) nil 9 1 2 3 4 5 6 7 8 9) ;;; Error cases (deftest mismatch.error.1 (classify-error (mismatch)) program-error) (deftest mismatch.error.2 (classify-error (mismatch nil)) program-error) (deftest mismatch.error.3 (classify-error (mismatch nil nil :bad t)) program-error) (deftest mismatch.error.4 (classify-error (mismatch nil nil :bad t :allow-other-keys nil)) program-error) (deftest mismatch.error.5 (classify-error (mismatch nil nil :key)) program-error) (deftest mismatch.error.6 (classify-error (mismatch nil nil 1 2)) program-error) (deftest mismatch.error.7 (classify-error (mismatch '(a b) '(a b) :test #'identity)) program-error) (deftest mismatch.error.8 (classify-error (mismatch '(a b) '(a b) :test-not #'identity)) program-error) (deftest mismatch.error.9 (classify-error (mismatch '(a b) '(a b) :key #'car)) type-error) (deftest mismatch.error.10 (classify-error (mismatch '(a b) '(a b) :key #'cons)) program-error) gcl/ansi-tests/multiple-value-bind.lsp000066400000000000000000000026701242227143400203220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 23:16:23 2002 ;;;; Contains: Tests for MULTIPLE-VALUE-BIND (in-package :cl-test) (deftest multiple-value-bind.1 (multiple-value-bind (x y z) (values 1 2 3) (declare (type integer x)) (declare (type integer y)) (declare (type integer z)) (list z y x)) (3 2 1)) (deftest multiple-value-bind.2 (multiple-value-bind (x y z) (values 1 2 3) (let ((x 4)) (list x y z))) (4 2 3)) (deftest multiple-value-bind.3 (multiple-value-bind (x y z) (values 1 2 3 4 5 6) (list x y z)) (1 2 3)) (deftest multiple-value-bind.4 (multiple-value-bind (x y z) (values 1 2) (list x y z)) (1 2 nil)) (deftest multiple-value-bind.5 (multiple-value-bind () (values 1 2) (values 'a 'b 'c)) a b c) (deftest multiple-value-bind.6 (multiple-value-bind (x y z) (values) (list x y z)) (nil nil nil)) (deftest multiple-value-bind.7 (let ((z 0) x y) (declare (special z)) (values (flet ((%x () (symbol-value 'x)) (%y () (symbol-value 'y)) (%z () (symbol-value 'z))) (multiple-value-bind (x y z) (values 1 2 3) (declare (special x y)) (list (%x) (%y) (%z)))) x y z)) (1 2 0) nil nil 0) ;;; (deftest multiple-value-bind.error.1 ;;; (classify-error (multiple-value-bind)) ;;; program-error) ;;; ;;; (deftest multiple-value-bind.error.2 ;;; (classify-error (multiple-value-bind (a b c))) ;;; program-error) gcl/ansi-tests/multiple-value-call.lsp000066400000000000000000000016171242227143400203210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 23:35:07 2002 ;;;; Contains: Tests of MULTIPLE-VALUE-CALL, MULTIPLE-VALUE-LIST (in-package :cl-test) (deftest multiple-value-call.1 (multiple-value-call #'+ (values 1 2) (values) 3 (values 4 5 6)) 21) (deftest multiple-value-call.2 (multiple-value-call 'list) nil) (deftest multiple-value-call.3 (multiple-value-call 'list (floor 13 4)) (3 1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftest multiple-value-list.1 (multiple-value-list (values)) nil) (deftest multiple-value-list.2 (multiple-value-list (values 'a)) (a)) (deftest multiple-value-list.3 (multiple-value-list (values 'a 'b)) (a b)) (deftest multiple-value-list.4 (not (loop for i from 0 below (min multiple-values-limit 100) for x = (make-list i :initial-element 'a) always (equal x (multiple-value-list (values-list x))))) nil) gcl/ansi-tests/multiple-value-list.lsp000066400000000000000000000014371242227143400203610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 17 06:38:07 2003 ;;;; Contains: Tests of MULTIPLE-VALUE-LIST (in-package :cl-test) (deftest multiple-value-list.1 (multiple-value-list 'a) (a)) (deftest multiple-value-list.2 (multiple-value-list (values)) nil) (deftest multiple-value-list.3 (multiple-value-list (values 'a 'b 'c 'd 'e)) (a b c d e)) (deftest multiple-value-list.4 (multiple-value-list (values (values 'a 'b 'c 'd 'e))) (a)) (deftest multiple-value-list.order.1 (let ((i 0)) (values (multiple-value-list (incf i)) i)) (1) 1) #| (deftest multiple-value-list.error.1 (classify-error (multiple-value-list)) program-error) (deftest multiple-value-list.error.2 (classify-error (multiple-value-list 'a 'b)) program-error) |# gcl/ansi-tests/multiple-value-prog1.lsp000066400000000000000000000026701242227143400204360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 06:48:02 2002 ;;;; Contains: Tests for MULTIPLE-VALUE-PROG1 (in-package :cl-test) (deftest multiple-value-prog1.1 (multiple-value-prog1 nil) nil) (deftest multiple-value-prog1.2 (multiple-value-prog1 '(a b c)) (a b c)) (deftest multiple-value-prog1.3 (multiple-value-prog1 (values-list '(a b c))) a b c) (deftest multiple-value-prog1.4 (multiple-value-prog1 (values))) (deftest multiple-value-prog1.5 (let ((x 0) (y 0)) (multiple-value-prog1 (values x y) (incf x) (incf y 2))) 0 0) (deftest multiple-value-prog1.6 (let ((x 0) (y 0)) (multiple-value-call #'list (multiple-value-prog1 (values x y) (incf x) (incf y 2)) x y)) (0 0 1 2)) (deftest multiple-value-prog1.7 (let ((x 0) (y 0)) (multiple-value-call #'list (multiple-value-prog1 (values (incf x) y) (incf x x) (incf y 10)) x y)) (1 0 2 10)) (deftest multiple-value-prog1.8 (let* ((n (min 100 multiple-values-limit))) (not-mv (loop for i from 0 below n for x = (make-int-list i) always (equalt (multiple-value-list (eval `(multiple-value-prog1 (values-list (quote ,(copy-seq x))) nil))) x)))) nil) (deftest multiple-value-prog1.9 (let ((x 0) (y 0)) (values (block foo (multiple-value-prog1 (values (incf x) (incf y 2)) (return-from foo 'a))) x y)) a 1 2) gcl/ansi-tests/multiple-value-setq.lsp000066400000000000000000000046751242227143400203710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 07:00:57 2002 ;;;; Contains: Tests of MULTIPLE-VALUE-SETQ (in-package :cl-test) (deftest multiple-value-setq.1 (let ((x 1) (y 2)) (values (multiple-value-list (multiple-value-setq (x y) (values 3 4))) x y)) (3) 3 4) (deftest multiple-value-setq.2 (let (x) (multiple-value-setq (x) (values 1 2)) x) 1) (deftest multiple-value-setq.3 (let (x) (symbol-macrolet ((y x)) (multiple-value-setq (y) (values 1 2)) x)) 1) (deftest multiple-value-setq.4 (let ((x (list nil))) (symbol-macrolet ((y (car x))) (multiple-value-setq (y) (values 1 2)) x)) (1)) ;;; test of order of evaluation ;;; The (INCF I) should be evaluated before the assigned form I. (deftest multiple-value-setq.5 (let ((i 0) (x (list nil))) (symbol-macrolet ((y (car (progn (incf i) x)))) (multiple-value-setq (y) i)) x) (1)) (deftest multiple-value-setq.6 (let ((x (list nil)) z) (symbol-macrolet ((y (car x))) (multiple-value-setq (y z) (values 1 2))) (values x z)) (1) 2) (deftest multiple-value-setq.7 (let ((x (list nil)) (z (list nil))) (symbol-macrolet ((y (car x)) (w (car z))) (multiple-value-setq (y w) (values 1 2))) (values x z)) (1) (2)) ;;; Another order of evaluation tests, this time with two ;;; symbol macro arguments (deftest multiple-value-setq.8 (let ((x (list nil)) (z (list nil)) (i 0)) (symbol-macrolet ((y (car (progn (incf i 3) x))) (w (car (progn (incf i i) z)))) (multiple-value-setq (y w) (values i 10))) (values x z)) (6) (10)) (deftest multiple-value-setq.9 (let (x) (values (multiple-value-setq (x x) (values 1 2)) x)) 1 2) (deftest multiple-value-setq.10 (let (x) (values (multiple-value-setq (x x) (values 1)) x)) 1 nil) (deftest multiple-value-setq.11 (let ((x 1) (y 2) (z 3)) (multiple-value-setq (x y z) (values)) (values x y z)) nil nil nil) (deftest multiple-value-setq.12 (let ((n (min 100 multiple-values-limit)) (vars nil) (result nil)) (loop for i from 1 below n for form = (progn (push (gensym) vars) (push i result) `(let ,vars (and (eql (multiple-value-setq ,vars (values-list (quote ,result))) ,(car result)) (equal ,(make-list-expr vars) (quote ,result))))) unless (eval form) collect (list i form))) nil) gcl/ansi-tests/nil.lsp000066400000000000000000000011651242227143400152230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 06:32:46 2002 ;;;; Contains: Tests for NIL (in-package :cl-test) (deftest nil.1 (loop for x in *universe* thereis (subtypep (type-of x) nil)) nil) (deftest nil.2 (loop for x in *universe* unless (subtypep nil (type-of x)) collect (type-of x)) nil) (deftest nil.3 (not-mv (constantp nil)) nil) (deftest nil.4 (car nil) nil) (deftest nil.5 (cdr nil) nil) (deftest nil.6 (eval nil) nil) (deftest nil.7 (symbol-value nil) nil) (deftest nil.8 (eqt nil 'nil) t) ;;; NIL is, of course, present in many other files gcl/ansi-tests/not-and-null.lsp000066400000000000000000000016731242227143400167550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 06:38:33 2002 ;;;; Contains: Tests of NOT and NULL (in-package :cl-test) (deftest null.1 (null nil) t) (deftest null.2 (null t) nil) (deftest null.3 (some #'(lambda (x) (and x (null x))) *universe*) nil) (deftest null.4 (not (some #'null `(1 a 1.2 "a" #\w (a) ,*terminal-io* #'car (make-array '(10))))) t) (deftest null.error.1 (classify-error (null)) program-error) (deftest null.error.2 (classify-error (null nil nil)) program-error) (deftest not.1 (not nil) t) (deftest not.2 (not t) nil) (deftest not.3 (some #'(lambda (x) (and x (not x))) *universe*) nil) (deftest not.4 (not (some #'not `(1 a 1.2 "a" #\w (a) ,*terminal-io* #'car (make-array '(10))))) t) (deftest not.error.1 (classify-error (not)) program-error) (deftest not.error.2 (classify-error (not nil nil)) program-error) gcl/ansi-tests/notany.lsp000066400000000000000000000053331242227143400157520ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 07:14:14 2002 ;;;; Contains: Tests for NOTANY (in-package :cl-test) (deftest notany.1 (not-mv (notany #'identity nil)) nil) (deftest notany.2 (not-mv (notany #'identity #())) nil) (deftest notany.3 (let ((count 0)) (values (notany #'(lambda (x) (incf count) (if (>= x 10) x nil)) '(1 2 4 13 5 1)) count)) nil 4) (deftest notany.4 (not-mv (notany #'/= '(1 2 3 4) '(1 2 3 4 5))) nil) (deftest notany.5 (not-mv (notany #'/= '(1 2 3 4 5) '(1 2 3 4))) nil) (deftest notany.6 (notany #'/= '(1 2 3 4 5) '(1 2 3 4 6)) nil) (deftest notany.7 (not-mv (notany #'(lambda (x y) (and x y)) '(nil t t nil t) #(t nil nil t nil nil))) nil) (deftest notany.8 (let* ((x '(1)) (args (list x))) (not (loop for i from 2 below (1- (min 100 call-arguments-limit)) do (push x args) always (apply #'notany #'/= args)))) nil) (deftest notany.9 (not-mv (notany #'zerop #*11111111111111)) nil) (deftest notany.10 (not-mv (notany #'zerop #*)) nil) (deftest notany.11 (notany #'zerop #*1111111011111) nil) (deftest notany.12 (not-mv (notany #'(lambda (x) (not (eql x #\a))) "aaaaaaaa")) nil) (deftest notany.13 (not-mv (notany #'(lambda (x) (eql x #\a)) "")) nil) (deftest notany.14 (notany #'(lambda (x) (not (eql x #\a))) "aaaaaabaaaa") nil) (deftest notany.15 (not-mv (notany 'null '(1 2 3 4))) nil) (deftest notany.16 (notany 'null '(1 2 3 nil 5)) nil) (deftest notany.order.1 (let ((i 0) a b) (values (not (notany (progn (setf a (incf i)) 'null) (progn (setf b (incf i)) '(a b c)))) i a b)) nil 2 1 2) ;;; Error cases (deftest notany.error.1 (classify-error (notany 1 '(a b c))) type-error) (deftest notany.error.2 (classify-error (notany #\a '(a b c))) type-error) (deftest notany.error.3 (classify-error (notany #() '(a b c))) type-error) (deftest notany.error.4 (classify-error (notany #'null 'a)) type-error) (deftest notany.error.5 (classify-error (notany #'null 100)) type-error) (deftest notany.error.6 (classify-error (notany #'null 'a)) type-error) (deftest notany.error.7 (classify-error (notany #'eq () 'a)) type-error) (deftest notany.error.8 (classify-error (notany)) program-error) (deftest notany.error.9 (classify-error (notany #'null)) program-error) (deftest notany.error.10 (classify-error (locally (notany 1 '(a b c)) t)) type-error) (deftest notany.error.11 (classify-error (notany #'cons '(a b c))) program-error) (deftest notany.error.12 (classify-error (notany #'cons '(a b c) '(1 2 4) '(g h j))) program-error) (deftest notany.error.13 (classify-error (notany #'car '(a b c))) type-error)gcl/ansi-tests/notevery.lsp000066400000000000000000000054151242227143400163160ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 07:20:12 2002 ;;;; Contains: Tests for NOTEVERY (in-package :cl-test) (deftest notevery.1 (notevery #'identity nil) nil) (deftest notevery.2 (notevery #'identity #()) nil) (deftest notevery.3 (let ((count 0)) (values (not (notevery #'(lambda (x) (incf count) (< x 10)) '(1 2 4 13 5 1))) count)) nil 4) (deftest notevery.4 (notevery #'= '(1 2 3 4) '(1 2 3 4 5)) nil) (deftest notevery.5 (notevery #'= '(1 2 3 4 5) '(1 2 3 4)) nil) (deftest notevery.6 (not-mv (notevery #'= '(1 2 3 4 5) '(1 2 3 4 6))) nil) (deftest notevery.7 (notevery #'(lambda (x y) (or x y)) '(nil t t nil t) #(t nil t t nil nil)) nil) (deftest notevery.8 (let ((x '(1)) (args nil)) (not (loop for i from 1 below (1- (min 100 call-arguments-limit)) do (push x args) always (not (apply #'notevery #'= args))))) nil) (deftest notevery.9 (notevery #'zerop #*000000000000) nil) (deftest notevery.10 (notevery #'zerop #*) nil) (deftest notevery.11 (not-mv (notevery #'zerop #*0000010000)) nil) (deftest notevery.12 (notevery #'(lambda (x) (eql x #\a)) "aaaaaaaa") nil) (deftest notevery.13 (notevery #'(lambda (x) (eql x #\a)) "") nil) (deftest notevery.14 (not-mv (notevery #'(lambda (x) (eql x #\a)) "aaaaaabaaaa")) nil) (deftest notevery.15 (not-mv (notevery 'null '(nil nil t nil))) nil) (deftest notevery.16 (notevery 'null '(nil nil nil nil)) nil) (deftest notevery.order.1 (let ((i 0) a b) (values (notevery (progn (setf a (incf i)) #'identity) (progn (setf b (incf i)) '(a b c d))) i a b)) nil 2 1 2) ;;; Error cases (deftest notevery.error.1 (classify-error (notevery 1 '(a b c))) type-error) (deftest notevery.error.2 (classify-error (notevery #\a '(a b c))) type-error) (deftest notevery.error.3 (classify-error (notevery #() '(a b c))) type-error) (deftest notevery.error.4 (classify-error (notevery #'null 'a)) type-error) (deftest notevery.error.5 (classify-error (notevery #'null 100)) type-error) (deftest notevery.error.6 (classify-error (notevery #'null 'a)) type-error) (deftest notevery.error.7 (classify-error (notevery #'eq () 'a)) type-error) (deftest notevery.error.8 (classify-error (notevery)) program-error) (deftest notevery.error.9 (classify-error (notevery #'null)) program-error) (deftest notevery.error.10 (classify-error (locally (notevery 1 '(a b c)) t)) type-error) (deftest notevery.error.11 (classify-error (notevery #'cons '(a b c))) program-error) (deftest notevery.error.12 (classify-error (notevery #'cons '(a b c) '(1 2 4) '(g h j))) program-error) (deftest notevery.error.13 (classify-error (notevery #'car '(a b c))) type-error)gcl/ansi-tests/nreverse.lsp000066400000000000000000000050241242227143400162700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 21 00:04:57 2002 ;;;; Contains: Tests for NREVERSE (in-package :cl-test) (deftest nreverse-list.1 (nreverse nil) nil) (deftest nreverse-list.2 (let ((x (copy-seq '(a b c)))) (nreverse x)) (c b a)) (deftest nreverse-vector.1 (nreverse #()) #()) (deftest nreverse-vector.2 (let ((x (copy-seq #(a b c d e)))) (nreverse x)) #(e d c b a)) (deftest nreverse-nonsimple-vector.1 (let ((x (make-array 0 :fill-pointer t :adjustable t))) (nreverse x)) #()) (deftest nreverse-nonsimple-vector.2 (let* ((x (make-array 5 :initial-contents '(1 2 3 4 5) :fill-pointer t :adjustable t)) (y (nreverse x))) (values y (equalt (type-of x) (type-of y)))) #(5 4 3 2 1) t) (deftest nreverse-nonsimple-vector.3 (let* ((x (make-array 10 :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 5)) (y (nreverse x))) (values y (equalt (type-of x) (type-of y)))) #(5 4 3 2 1) t) (deftest nreverse-bit-vector.1 (nreverse #*) #*) (deftest nreverse-bit-vector.2 (let ((x (copy-seq #*000110110110))) (nreverse x)) #*011011011000) (deftest nreverse-bit-vector.3 (let* ((x (make-array 10 :initial-contents '(0 0 0 1 1 0 1 0 1 0) :fill-pointer 5 :element-type 'bit)) (y (nreverse x))) y) #*11000) (deftest nreverse-string.1 (nreverse "") "") (deftest nreverse-string.2 (let ((x (copy-seq "000110110110"))) (nreverse x)) "011011011000") (deftest nreverse-string.3 (let* ((x (make-array 10 :initial-contents "abcdefghij" :fill-pointer 5 :element-type 'character)) (y (nreverse x))) y) "edcba") (deftest nreverse-string.4 (let* ((x (make-array 10 :initial-contents "abcdefghij" :fill-pointer 5 :element-type 'base-char)) (y (nreverse x))) y) "edcba") (deftest nreverse.order.1 (let ((i 0)) (values (nreverse (progn (incf i) (list 'a 'b 'c 'd))) i)) (d c b a) 1) (deftest nreverse.error.1 (classify-error (nreverse 'a)) type-error) (deftest nreverse.error.2 (classify-error (nreverse #\a)) type-error) (deftest nreverse.error.3 (classify-error (nreverse 10)) type-error) (deftest nreverse.error.4 (classify-error (nreverse 0.3)) type-error) (deftest nreverse.error.5 (classify-error (nreverse 10/3)) type-error) (deftest nreverse.error.6 (classify-error (nreverse)) program-error) (deftest nreverse.error.7 (classify-error (nreverse nil nil)) program-error) (deftest nreverse.error.8 (classify-error (locally (nreverse 'a) t)) type-error) gcl/ansi-tests/nstring-capitalize.lsp000066400000000000000000000057411242227143400202540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 3 21:38:49 2002 ;;;; Contains: Tests for NSTRING-CAPITALIZE (in-package :cl-test) (deftest nstring-capitalize.1 (let* ((s (copy-seq "abCd")) (s2 (nstring-capitalize s))) (values (eqt s s2) s)) t "Abcd") (deftest nstring-capitalize.2 (let* ((s (copy-seq "0adA2Cdd3wXy")) (s2 (nstring-capitalize s))) (values (eqt s s2) s)) t "0ada2cdd3wxy") (deftest nstring-capitalize.3 (let* ((s (copy-seq "1a")) (s2 (nstring-capitalize s))) (values (eqt s s2) s)) t "1a") (deftest nstring-capitalize.4 (let* ((s (copy-seq "a1a")) (s2 (nstring-capitalize s))) (values (eqt s s2) s)) t "A1a") (deftest nstring-capitalize.7 (let ((s "ABCDEF")) (loop for i from 0 to 5 collect (nstring-capitalize (copy-seq s) :start i))) ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) (deftest nstring-capitalize.8 (let ((s "ABCDEF")) (loop for i from 0 to 5 collect (nstring-capitalize (copy-seq s) :start i :end nil))) ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) (deftest nstring-capitalize.9 (let ((s "ABCDEF")) (loop for i from 0 to 6 collect (nstring-capitalize (copy-seq s) :end i))) ("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef")) (deftest nstring-capitalize.10 (let ((s "ABCDEF")) (loop for i from 0 to 5 collect (loop for j from i to 6 collect (nstring-capitalize (copy-seq s) :start i :end j)))) (("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") ("ABCDEF" "ABCDEF" "ABcDEF" "ABcdEF" "ABcdeF" "ABcdef") ("ABCDEF" "ABCDEF" "ABCdEF" "ABCdeF" "ABCdef") ("ABCDEF" "ABCDEF" "ABCDeF" "ABCDef") ("ABCDEF" "ABCDEF" "ABCDEf") ("ABCDEF" "ABCDEF"))) (deftest nstring-capitalize.order.1 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (nstring-capitalize (progn (setf a (incf i)) s) :start (progn (setf b (incf i)) 1) :end (progn (setf c (incf i)) 4)) i a b c)) "aBcdef" 3 1 2 3) (deftest nstring-capitalize.order.2 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (nstring-capitalize (progn (setf a (incf i)) s) :end (progn (setf b (incf i)) 4) :start (progn (setf c (incf i)) 1)) i a b c)) "aBcdef" 3 1 2 3) ;;; Error cases (deftest nstring-capitalize.error.1 (classify-error (nstring-capitalize)) program-error) (deftest nstring-capitalize.error.2 (classify-error (nstring-capitalize (copy-seq "abc") :bad t)) program-error) (deftest nstring-capitalize.error.3 (classify-error (nstring-capitalize (copy-seq "abc") :start)) program-error) (deftest nstring-capitalize.error.4 (classify-error (nstring-capitalize (copy-seq "abc") :bad t :allow-other-keys nil)) program-error) (deftest nstring-capitalize.error.5 (classify-error (nstring-capitalize (copy-seq "abc") :end)) program-error) (deftest nstring-capitalize.error.6 (classify-error (nstring-capitalize (copy-seq "abc") 1 2)) program-error) gcl/ansi-tests/nstring-downcase.lsp000066400000000000000000000061761242227143400177350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 3 21:33:16 2002 ;;;; Contains: Tests for NSTRING-DOWNCASE (in-package :cl-test) (deftest nstring-downcase.1 (let* ((s (copy-seq "A")) (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "a") (deftest nstring-downcase.2 (let* ((s (copy-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz") (deftest nstring-downcase.3 (let* ((s (copy-seq "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") (deftest nstring-downcase.6 (let* ((s (make-array 6 :element-type 'character :initial-contents '(#\A #\B #\C #\D #\E #\F))) (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "abcdef") (deftest nstring-downcase.7 (let* ((s (make-array 6 :element-type 'standard-char :initial-contents '(#\A #\B #\7 #\D #\E #\F))) (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "ab7def") ;; Tests with :start, :end (deftest nstring-downcase.8 (let ((s "ABCDEF")) (loop for i from 0 to 6 collect (nstring-downcase (copy-seq s) :start i))) ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) (deftest nstring-downcase.9 (let ((s "ABCDEF")) (loop for i from 0 to 6 collect (nstring-downcase (copy-seq s) :start i :end nil))) ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) (deftest nstring-downcase.10 (let ((s "ABCDE")) (loop for i from 0 to 4 collect (loop for j from i to 5 collect (string-invertcase (nstring-downcase (copy-seq s) :start i :end j))))) (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") ("abcde" "abCde" "abCDe" "abCDE") ("abcde" "abcDe" "abcDE") ("abcde" "abcdE"))) (deftest nstring-downcase.order.1 (let ((i 0) a b c (s (copy-seq "ABCDEF"))) (values (nstring-downcase (progn (setf a (incf i)) s) :start (progn (setf b (incf i)) 1) :end (progn (setf c (incf i)) 4)) i a b c)) "AbcdEF" 3 1 2 3) (deftest nstring-downcase.order.2 (let ((i 0) a b c (s (copy-seq "ABCDEF"))) (values (nstring-downcase (progn (setf a (incf i)) s) :end (progn (setf b (incf i)) 4) :start (progn (setf c (incf i)) 1)) i a b c)) "AbcdEF" 3 1 2 3) ;;; Error cases (deftest nstring-downcase.error.1 (classify-error (nstring-downcase)) program-error) (deftest nstring-downcase.error.2 (classify-error (nstring-downcase (copy-seq "abc") :bad t)) program-error) (deftest nstring-downcase.error.3 (classify-error (nstring-downcase (copy-seq "abc") :start)) program-error) (deftest nstring-downcase.error.4 (classify-error (nstring-downcase (copy-seq "abc") :bad t :allow-other-keys nil)) program-error) (deftest nstring-downcase.error.5 (classify-error (nstring-downcase (copy-seq "abc") :end)) program-error) (deftest nstring-downcase.error.6 (classify-error (nstring-downcase (copy-seq "abc") 1 2)) program-error) gcl/ansi-tests/nstring-upcase.lsp000066400000000000000000000060441242227143400174040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 3 21:12:40 2002 ;;;; Contains: Tests for NSTRING-UPCASE (in-package :cl-test) (deftest nstring-upcase.1 (let* ((s (copy-seq "a")) (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "A") (deftest nstring-upcase.2 (let* ((s (copy-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ") (deftest nstring-upcase.3 (let* ((s (copy-seq "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") (deftest nstring-upcase.6 (let* ((s (make-array 6 :element-type 'character :initial-contents '(#\a #\b #\c #\d #\e #\f))) (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "ABCDEF") (deftest nstring-upcase.7 (let* ((s (make-array 6 :element-type 'standard-char :initial-contents '(#\a #\b #\7 #\d #\e #\f))) (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "AB7DEF") ;; Tests with :start, :end (deftest nstring-upcase.8 (let ((s "abcdef")) (loop for i from 0 to 6 collect (nstring-upcase (copy-seq s) :start i))) ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef")) (deftest nstring-upcase.9 (let ((s "abcdef")) (loop for i from 0 to 6 collect (nstring-upcase (copy-seq s) :start i :end nil))) ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef")) (deftest nstring-upcase.10 (let ((s "abcde")) (loop for i from 0 to 4 collect (loop for j from i to 5 collect (nstring-upcase (copy-seq s) :start i :end j)))) (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") ("abcde" "abCde" "abCDe" "abCDE") ("abcde" "abcDe" "abcDE") ("abcde" "abcdE"))) (deftest nstring-upcase.order.1 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (nstring-upcase (progn (setf a (incf i)) s) :start (progn (setf b (incf i)) 1) :end (progn (setf c (incf i)) 4)) i a b c)) "aBCDef" 3 1 2 3) (deftest nstring-upcase.order.2 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (nstring-upcase (progn (setf a (incf i)) s) :end (progn (setf b (incf i)) 4) :start (progn (setf c (incf i)) 1)) i a b c)) "aBCDef" 3 1 2 3) ;;; Error cases (deftest nstring-upcase.error.1 (classify-error (nstring-upcase)) program-error) (deftest nstring-upcase.error.2 (classify-error (nstring-upcase (copy-seq "abc") :bad t)) program-error) (deftest nstring-upcase.error.3 (classify-error (nstring-upcase (copy-seq "abc") :start)) program-error) (deftest nstring-upcase.error.4 (classify-error (nstring-upcase (copy-seq "abc") :bad t :allow-other-keys nil)) program-error) (deftest nstring-upcase.error.5 (classify-error (nstring-upcase (copy-seq "abc") :end)) program-error) (deftest nstring-upcase.error.6 (classify-error (nstring-upcase (copy-seq "abc") 1 2)) program-error) gcl/ansi-tests/nsubstitute-if-not.lsp000066400000000000000000000574061242227143400202350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 31 19:00:55 2002 ;;;; Contains: Tests for NSUBSTITUTE-IF-NOT (in-package :cl-test) (deftest nsubstitute-if-not-list.1 (nsubstitute-if-not 'b 'identity nil) nil) (deftest nsubstitute-if-not-list.2 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x) x) (b b b c)) (deftest nsubstitute-if-not-list.3 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count nil)) (b b b c)) (deftest nsubstitute-if-not-list.4 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2)) (b b b c)) (deftest nsubstitute-if-not-list.5 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1)) (b b a c)) (deftest nsubstitute-if-not-list.6 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0)) (a b a c)) (deftest nsubstitute-if-not-list.7 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1)) (a b a c)) (deftest nsubstitute-if-not-list.8 (nsubstitute-if-not 'b (is-not-eq-p 'a) nil :from-end t) nil) (deftest nsubstitute-if-not-list.9 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t)) (b b b c)) (deftest nsubstitute-if-not-list.10 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil)) (b b b c)) (deftest nsubstitute-if-not-list.11 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t)) (b b b c)) (deftest nsubstitute-if-not-list.12 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t)) (a b b c)) (deftest nsubstitute-if-not-list.13 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t)) (a b a c)) (deftest nsubstitute-if-not-list.14 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t)) (a b a c)) (deftest nsubstitute-if-not-list.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-not-list.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-not-list.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) (equal y (nconc (make-list i :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-if-not-list.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) (equal y (nconc (make-list (- j c) :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) ;;; Tests on vectors (deftest nsubstitute-if-not-vector.1 (let ((x #())) (nsubstitute-if-not 'b (is-not-eq-p 'a) x)) #()) (deftest nsubstitute-if-not-vector.2 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x)) #(b b b c)) (deftest nsubstitute-if-not-vector.3 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count nil) x) #(b b b c)) (deftest nsubstitute-if-not-vector.4 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2)) #(b b b c)) (deftest nsubstitute-if-not-vector.5 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1)) #(b b a c)) (deftest nsubstitute-if-not-vector.6 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0)) #(a b a c)) (deftest nsubstitute-if-not-vector.7 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1)) #(a b a c)) (deftest nsubstitute-if-not-vector.8 (let ((x #())) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t)) #()) (deftest nsubstitute-if-not-vector.9 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t)) #(b b b c)) (deftest nsubstitute-if-not-vector.10 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil)) #(b b b c)) (deftest nsubstitute-if-not-vector.11 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t)) #(b b b c)) (deftest nsubstitute-if-not-vector.12 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t)) #(a b b c)) (deftest nsubstitute-if-not-vector.13 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t)) #(a b a c)) (deftest nsubstitute-if-not-vector.14 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t)) #(a b a c)) (deftest nsubstitute-if-not-vector.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-not-vector.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-not-vector.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-if-not-vector.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-vector (make-array (- j c) :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest nsubstitute-if-not-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x))) result) #(z b z c b)) (deftest nsubstitute-if-not-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :from-end t))) result) #(z b z c b)) (deftest nsubstitute-if-not-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :count 1))) result) #(z b a c b)) (deftest nsubstitute-if-not-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :from-end t :count 1))) result) #(a b z c b)) ;;; Tests on strings (deftest nsubstitute-if-not-string.1 (let ((x "")) (nsubstitute-if-not #\b (is-not-eq-p #\a) x)) "") (deftest nsubstitute-if-not-string.2 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x)) "bbbc") (deftest nsubstitute-if-not-string.3 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count nil)) "bbbc") (deftest nsubstitute-if-not-string.4 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 2)) "bbbc") (deftest nsubstitute-if-not-string.5 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 1)) "bbac") (deftest nsubstitute-if-not-string.6 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 0)) "abac") (deftest nsubstitute-if-not-string.7 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count -1)) "abac") (deftest nsubstitute-if-not-string.8 (let ((x "")) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :from-end t)) "") (deftest nsubstitute-if-not-string.9 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :from-end t)) "bbbc") (deftest nsubstitute-if-not-string.10 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :from-end t :count nil)) "bbbc") (deftest nsubstitute-if-not-string.11 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 2 :from-end t)) "bbbc") (deftest nsubstitute-if-not-string.12 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 1 :from-end t)) "abbc") (deftest nsubstitute-if-not-string.13 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 0 :from-end t)) "abac") (deftest nsubstitute-if-not-string.14 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count -1 :from-end t)) "abac") (deftest nsubstitute-if-not-string.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-if-not-string.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :from-end t))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-if-not-string.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 (+ i c)) :initial-element #\a))))))) t) (deftest nsubstitute-if-not-string.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-string (make-array (- j c) :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest nsubstitute-if-not-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x))) result) "zbzcb") (deftest nsubstitute-if-not-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :from-end t))) result) "zbzcb") (deftest nsubstitute-if-not-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :count 1))) result) "zbacb") (deftest nsubstitute-if-not-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :from-end t :count 1))) result) "abzcb") ;;; Tests on bit-vectors (deftest nsubstitute-if-not-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eq-p 1) x))) result) #*) (deftest nsubstitute-if-not-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x))) result) #*) (deftest nsubstitute-if-not-bit-vector.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eq-p 1) x))) result) #*000000) (deftest nsubstitute-if-not-bit-vector.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x))) result) #*111111) (deftest nsubstitute-if-not-bit-vector.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :start 1))) result) #*011111) (deftest nsubstitute-if-not-bit-vector.6 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :start 2 :end nil))) result) #*010000) (deftest nsubstitute-if-not-bit-vector.7 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :end 4))) result) #*111101) (deftest nsubstitute-if-not-bit-vector.8 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :end nil))) result) #*000000) (deftest nsubstitute-if-not-bit-vector.9 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :end 3))) result) #*000101) (deftest nsubstitute-if-not-bit-vector.10 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :start 2 :end 4))) result) #*010001) (deftest nsubstitute-if-not-bit-vector.11 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :start 2 :end 4))) result) #*011101) (deftest nsubstitute-if-not-bit-vector.12 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 1))) result) #*110101) (deftest nsubstitute-if-not-bit-vector.13 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 0))) result) #*010101) (deftest nsubstitute-if-not-bit-vector.14 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count -1))) result) #*010101) (deftest nsubstitute-if-not-bit-vector.15 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 1 :from-end t))) result) #*010111) (deftest nsubstitute-if-not-bit-vector.16 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 0 :from-end t))) result) #*010101) (deftest nsubstitute-if-not-bit-vector.17 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count -1 :from-end t))) result) #*010101) (deftest nsubstitute-if-not-bit-vector.18 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count nil))) result) #*111111) (deftest nsubstitute-if-not-bit-vector.19 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count nil :from-end t))) result) #*111111) (deftest nsubstitute-if-not-bit-vector.20 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*0000000000) (x (copy-seq orig)) (y (nsubstitute-if-not 1 (is-not-eq-p 0) x :start i :end j :count c))) (equalp y (concatenate 'simple-bit-vector (make-list i :initial-element 0) (make-list c :initial-element 1) (make-list (- 10 (+ i c)) :initial-element 0))))))) t) (deftest nsubstitute-if-not-bit-vector.21 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*1111111111) (x (copy-seq orig)) (y (nsubstitute-if-not 0 (is-not-eq-p 1) x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-bit-vector (make-list (- j c) :initial-element 1) (make-list c :initial-element 0) (make-list (- 10 j) :initial-element 1))))))) t) ;;; More tests (deftest nsubstitute-if-not-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) result) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-if-not-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car :start 1 :end 5))) result) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-if-not-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) result) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-if-not-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car :start 1 :end 5))) result) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-if-not-string.24 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit))) result) "a1a2342a15") (deftest nsubstitute-if-not-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) result) "01a2342015") (deftest nsubstitute-if-not-bit-vector.26 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 1) x :key #'1+))) result) #*11111111111111111) (deftest nsubstitute-if-not-bit-vector.27 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 1) x :key #'1+ :start 1 :end 10))) result) #*01111111111010110) (deftest nsubstitute-if-not-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if-not 1 #'onep x))) result) #*11111) (deftest nsubstitute-if-not-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if-not 1 #'onep x :from-end t))) result) #*11111) (deftest nsubstitute-if-not-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if-not 1 #'onep x :count 1))) result) #*11011) (deftest nsubstitute-if-not-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if-not 1 #'onep x :from-end t :count 1))) result) #*01111) (deftest nsubstitute-if-not.order.1 (let ((i 0) a b c d e f g h) (values (nsubstitute-if-not (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'identity) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :count (progn (setf d (incf i)) 2) :start (progn (setf e (incf i)) 0) :end (progn (setf f (incf i)) 7) :key (progn (setf g (incf i)) #'identity) :from-end (setf h (incf i)) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 4 5 6 7 8) (deftest nsubstitute-if-not.order.2 (let ((i 0) a b c d e f g h) (values (nsubstitute-if-not (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'identity) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :from-end (setf h (incf i)) :key (progn (setf g (incf i)) #'identity) :end (progn (setf f (incf i)) 7) :start (progn (setf e (incf i)) 0) :count (progn (setf d (incf i)) 2) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 8 7 6 5 4) ;;; Keyword tests (deftest nsubstitute-if-not.allow-other-keys.1 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.2 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.3 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :allow-other-keys nil :bad t) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.4 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t :allow-other-keys nil) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.5 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :key #'1-) (1 a a a 1 a a)) (deftest nsubstitute-if-not.keywords.6 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) (1 a a a 1 a a)) (deftest nsubstitute-if-not.allow-other-keys.7 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t :allow-other-keys nil) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.8 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) (a a 0 a a 0 a)) ;;; Error cases (deftest nsubstitute-if-not.error.1 (classify-error (nsubstitute-if-not)) program-error) (deftest nsubstitute-if-not.error.2 (classify-error (nsubstitute-if-not 'a)) program-error) (deftest nsubstitute-if-not.error.3 (classify-error (nsubstitute-if-not 'a #'null)) program-error) (deftest nsubstitute-if-not.error.4 (classify-error (nsubstitute-if-not 'a #'null nil 'bad t)) program-error) (deftest nsubstitute-if-not.error.5 (classify-error (nsubstitute-if-not 'a #'null nil 'bad t :allow-other-keys nil)) program-error) (deftest nsubstitute-if-not.error.6 (classify-error (nsubstitute-if-not 'a #'null nil :key)) program-error) (deftest nsubstitute-if-not.error.7 (classify-error (nsubstitute-if-not 'a #'null nil 1 2)) program-error) (deftest nsubstitute-if-not.error.8 (classify-error (nsubstitute-if-not 'a #'cons (list 'a 'b 'c))) program-error) (deftest nsubstitute-if-not.error.9 (classify-error (nsubstitute-if-not 'a #'car (list 'a 'b 'c))) type-error) (deftest nsubstitute-if-not.error.10 (classify-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) :key #'car)) type-error) (deftest nsubstitute-if-not.error.11 (classify-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) :key #'cons)) program-error) gcl/ansi-tests/nsubstitute-if.lsp000066400000000000000000000547021242227143400174330ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 31 18:56:41 2002 ;;;; Contains: Tests for NSUBSTITUTE-IF (in-package :cl-test) (deftest nsubstitute-if-list.1 (nsubstitute-if 'b 'identity nil) nil) (deftest nsubstitute-if-list.2 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x) x) (b b b c)) (deftest nsubstitute-if-list.3 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count nil)) (b b b c)) (deftest nsubstitute-if-list.4 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2)) (b b b c)) (deftest nsubstitute-if-list.5 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1)) (b b a c)) (deftest nsubstitute-if-list.6 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0)) (a b a c)) (deftest nsubstitute-if-list.7 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1)) (a b a c)) (deftest nsubstitute-if-list.8 (nsubstitute-if 'b (is-eq-p 'a) nil :from-end t) nil) (deftest nsubstitute-if-list.9 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t)) (b b b c)) (deftest nsubstitute-if-list.10 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t :count nil)) (b b b c)) (deftest nsubstitute-if-list.11 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2 :from-end t)) (b b b c)) (deftest nsubstitute-if-list.12 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1 :from-end t)) (a b b c)) (deftest nsubstitute-if-list.13 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0 :from-end t)) (a b a c)) (deftest nsubstitute-if-list.14 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1 :from-end t)) (a b a c)) (deftest nsubstitute-if-list.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j))) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-list.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-list.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) (equal y (nconc (make-list i :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-if-list.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) (equal y (nconc (make-list (- j c) :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) ;;; Tests on vectors (deftest nsubstitute-if-vector.1 (let ((x #())) (nsubstitute-if 'b (is-eq-p 'a) x)) #()) (deftest nsubstitute-if-vector.2 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x)) #(b b b c)) (deftest nsubstitute-if-vector.3 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count nil) x) #(b b b c)) (deftest nsubstitute-if-vector.4 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2)) #(b b b c)) (deftest nsubstitute-if-vector.5 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1)) #(b b a c)) (deftest nsubstitute-if-vector.6 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0)) #(a b a c)) (deftest nsubstitute-if-vector.7 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1)) #(a b a c)) (deftest nsubstitute-if-vector.8 (let ((x #())) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t)) #()) (deftest nsubstitute-if-vector.9 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t)) #(b b b c)) (deftest nsubstitute-if-vector.10 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t :count nil)) #(b b b c)) (deftest nsubstitute-if-vector.11 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2 :from-end t)) #(b b b c)) (deftest nsubstitute-if-vector.12 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1 :from-end t)) #(a b b c)) (deftest nsubstitute-if-vector.13 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0 :from-end t)) #(a b a c)) (deftest nsubstitute-if-vector.14 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1 :from-end t)) #(a b a c)) (deftest nsubstitute-if-vector.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-vector.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-vector.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-if-vector.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-vector (make-array (- j c) :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest nsubstitute-if-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if 'z (is-eql-p 'a) x))) result) #(z b z c b)) (deftest nsubstitute-if-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if 'z (is-eql-p 'a) x :from-end t))) result) #(z b z c b)) (deftest nsubstitute-if-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if 'z (is-eql-p 'a) x :count 1))) result) #(z b a c b)) (deftest nsubstitute-if-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if 'z (is-eql-p 'a) x :from-end t :count 1))) result) #(a b z c b)) ;;; Tests on strings (deftest nsubstitute-if-string.1 (let ((x "")) (nsubstitute-if #\b (is-eq-p #\a) x)) "") (deftest nsubstitute-if-string.2 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x)) "bbbc") (deftest nsubstitute-if-string.3 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count nil)) "bbbc") (deftest nsubstitute-if-string.4 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 2)) "bbbc") (deftest nsubstitute-if-string.5 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 1)) "bbac") (deftest nsubstitute-if-string.6 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 0)) "abac") (deftest nsubstitute-if-string.7 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count -1)) "abac") (deftest nsubstitute-if-string.8 (let ((x "")) (nsubstitute-if #\b (is-eq-p #\a) x :from-end t)) "") (deftest nsubstitute-if-string.9 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :from-end t)) "bbbc") (deftest nsubstitute-if-string.10 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :from-end t :count nil)) "bbbc") (deftest nsubstitute-if-string.11 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 2 :from-end t)) "bbbc") (deftest nsubstitute-if-string.12 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 1 :from-end t)) "abbc") (deftest nsubstitute-if-string.13 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 0 :from-end t)) "abac") (deftest nsubstitute-if-string.14 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count -1 :from-end t)) "abac") (deftest nsubstitute-if-string.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-if-string.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j :from-end t))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-if-string.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j :count c))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 (+ i c)) :initial-element #\a))))))) t) (deftest nsubstitute-if-string.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-string (make-array (- j c) :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest nsubstitute-if-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if #\z (is-eql-p #\a) x))) result) "zbzcb") (deftest nsubstitute-if-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if #\z (is-eql-p #\a) x :from-end t))) result) "zbzcb") (deftest nsubstitute-if-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if #\z (is-eql-p #\a) x :count 1))) result) "zbacb") (deftest nsubstitute-if-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if #\z (is-eql-p #\a) x :from-end t :count 1))) result) "abzcb") ;;; Tests on bit-vectors (deftest nsubstitute-if-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eq-p 1) x))) result) #*) (deftest nsubstitute-if-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x))) result) #*) (deftest nsubstitute-if-bit-vector.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eq-p 1) x))) result) #*000000) (deftest nsubstitute-if-bit-vector.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x))) result) #*111111) (deftest nsubstitute-if-bit-vector.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :start 1))) result) #*011111) (deftest nsubstitute-if-bit-vector.6 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eq-p 1) x :start 2 :end nil))) result) #*010000) (deftest nsubstitute-if-bit-vector.7 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :end 4))) result) #*111101) (deftest nsubstitute-if-bit-vector.8 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eq-p 1) x :end nil))) result) #*000000) (deftest nsubstitute-if-bit-vector.9 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eq-p 1) x :end 3))) result) #*000101) (deftest nsubstitute-if-bit-vector.10 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eq-p 1) x :start 2 :end 4))) result) #*010001) (deftest nsubstitute-if-bit-vector.11 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :start 2 :end 4))) result) #*011101) (deftest nsubstitute-if-bit-vector.12 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count 1))) result) #*110101) (deftest nsubstitute-if-bit-vector.13 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count 0))) result) #*010101) (deftest nsubstitute-if-bit-vector.14 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count -1))) result) #*010101) (deftest nsubstitute-if-bit-vector.15 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count 1 :from-end t))) result) #*010111) (deftest nsubstitute-if-bit-vector.16 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count 0 :from-end t))) result) #*010101) (deftest nsubstitute-if-bit-vector.17 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count -1 :from-end t))) result) #*010101) (deftest nsubstitute-if-bit-vector.18 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count nil))) result) #*111111) (deftest nsubstitute-if-bit-vector.19 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count nil :from-end t))) result) #*111111) (deftest nsubstitute-if-bit-vector.20 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*0000000000) (x (copy-seq orig)) (y (nsubstitute-if 1 (is-eq-p 0) x :start i :end j :count c))) (equalp y (concatenate 'simple-bit-vector (make-list i :initial-element 0) (make-list c :initial-element 1) (make-list (- 10 (+ i c)) :initial-element 0))))))) t) (deftest nsubstitute-if-bit-vector.21 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*1111111111) (x (copy-seq orig)) (y (nsubstitute-if 0 (is-eq-p 1) x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-bit-vector (make-list (- j c) :initial-element 1) (make-list c :initial-element 0) (make-list (- 10 j) :initial-element 1))))))) t) ;;; More tests (deftest nsubstitute-if-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car))) result) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-if-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car :start 1 :end 5))) result) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-if-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car))) result) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-if-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car :start 1 :end 5))) result) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-if-string.24 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute-if #\a (is-eq-p #\1) x :key #'nextdigit))) result) "a1a2342a15") (deftest nsubstitute-if-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute-if #\a (is-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) result) "01a2342015") (deftest nsubstitute-if-bit-vector.26 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 1) x :key #'1+))) result) #*11111111111111111) (deftest nsubstitute-if-bit-vector.27 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 1) x :key #'1+ :start 1 :end 10))) result) #*01111111111010110) (deftest nsubstitute-if-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if 1 #'zerop x))) result) #*11111) (deftest nsubstitute-if-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if 1 #'zerop x :from-end t))) result) #*11111) (deftest nsubstitute-if-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if 1 #'zerop x :count 1))) result) #*11011) (deftest nsubstitute-if-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if 1 #'zerop x :from-end t :count 1))) result) #*01111) (deftest nsubstitute-if.order.1 (let ((i 0) a b c d e f g h) (values (nsubstitute-if (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'null) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :count (progn (setf d (incf i)) 2) :start (progn (setf e (incf i)) 0) :end (progn (setf f (incf i)) 7) :key (progn (setf g (incf i)) #'identity) :from-end (setf h (incf i)) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 4 5 6 7 8) (deftest nsubstitute-if.order.2 (let ((i 0) a b c d e f g h) (values (nsubstitute-if (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'null) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :from-end (setf h (incf i)) :key (progn (setf g (incf i)) #'identity) :end (progn (setf f (incf i)) 7) :start (progn (setf e (incf i)) 0) :count (progn (setf d (incf i)) 2) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 8 7 6 5 4) ;;; Keyword tests (deftest nsubstitute-if.allow-other-keys.1 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) (1 2 a 3 1 a 3)) (deftest nsubstitute-if.allow-other-keys.2 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) (1 2 a 3 1 a 3)) (deftest nsubstitute-if.allow-other-keys.3 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :allow-other-keys nil :bad t) (1 2 a 3 1 a 3)) (deftest nsubstitute-if.allow-other-keys.4 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest nsubstitute-if.allow-other-keys.5 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :key #'1-) (a 2 0 3 a 0 3)) (deftest nsubstitute-if.keywords.6 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) (a 2 0 3 a 0 3)) (deftest nsubstitute-if.allow-other-keys.7 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest nsubstitute-if.allow-other-keys.8 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) (1 2 a 3 1 a 3)) ;;; Error cases (deftest nsubstitute-if.error.1 (classify-error (nsubstitute-if)) program-error) (deftest nsubstitute-if.error.2 (classify-error (nsubstitute-if 'a)) program-error) (deftest nsubstitute-if.error.3 (classify-error (nsubstitute-if 'a #'null)) program-error) (deftest nsubstitute-if.error.4 (classify-error (nsubstitute-if 'a #'null nil 'bad t)) program-error) (deftest nsubstitute-if.error.5 (classify-error (nsubstitute-if 'a #'null nil 'bad t :allow-other-keys nil)) program-error) (deftest nsubstitute-if.error.6 (classify-error (nsubstitute-if 'a #'null nil :key)) program-error) (deftest nsubstitute-if.error.7 (classify-error (nsubstitute-if 'a #'null nil 1 2)) program-error) (deftest nsubstitute-if.error.8 (classify-error (nsubstitute-if 'a #'cons (list 'a 'b 'c))) program-error) (deftest nsubstitute-if.error.9 (classify-error (nsubstitute-if 'a #'car (list 'a 'b 'c))) type-error) (deftest nsubstitute-if.error.10 (classify-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) :key #'car)) type-error) (deftest nsubstitute-if.error.11 (classify-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) :key #'cons)) program-error) gcl/ansi-tests/nsubstitute.lsp000066400000000000000000000646071242227143400170440ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 31 16:56:48 2002 ;;;; Contains: Tests for NSUBSTITUTE (in-package :cl-test) (deftest nsubstitute-list.1 (nsubstitute 'b 'a nil) nil) (deftest nsubstitute-list.2 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x) x) (b b b c)) (deftest nsubstitute-list.3 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count nil)) (b b b c)) (deftest nsubstitute-list.4 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 2)) (b b b c)) (deftest nsubstitute-list.5 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 1)) (b b a c)) (deftest nsubstitute-list.6 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 0)) (a b a c)) (deftest nsubstitute-list.7 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count -1)) (a b a c)) (deftest nsubstitute-list.8 (nsubstitute 'b 'a nil :from-end t) nil) (deftest nsubstitute-list.9 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :from-end t)) (b b b c)) (deftest nsubstitute-list.10 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :from-end t :count nil)) (b b b c)) (deftest nsubstitute-list.11 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 2 :from-end t)) (b b b c)) (deftest nsubstitute-list.12 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 1 :from-end t)) (a b b c)) (deftest nsubstitute-list.13 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 0 :from-end t)) (a b a c)) (deftest nsubstitute-list.14 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count -1 :from-end t)) (a b a c)) (deftest nsubstitute-list.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j))) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-list.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j :from-end t))) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-list.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j :count c))) (equal y (nconc (make-list i :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-list.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) (equal y (nconc (make-list (- j c) :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest nsubstitute-list.19 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) result) (1 2 x x x x x 8 9)) (deftest nsubstitute-list.20 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) result) (1 2 x 4 5 6 7 8 9)) (deftest nsubstitute-list.21 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) :from-end t))) result) (1 2 3 4 5 6 7 x 9)) (deftest nsubstitute-list.22 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) result) (1 2 x 4 5 6 7 8 9)) (deftest nsubstitute-list.23 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) :from-end t))) result) (1 2 3 4 5 6 7 x 9)) ;;; Tests on vectors (deftest nsubstitute-vector.1 (let ((x #())) (values (nsubstitute 'b 'a x) x)) #() #()) (deftest nsubstitute-vector.2 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x)) #(b b b c)) (deftest nsubstitute-vector.3 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count nil) x) #(b b b c)) (deftest nsubstitute-vector.4 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 2)) #(b b b c)) (deftest nsubstitute-vector.5 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 1)) #(b b a c)) (deftest nsubstitute-vector.6 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 0)) #(a b a c)) (deftest nsubstitute-vector.7 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count -1)) #(a b a c)) (deftest nsubstitute-vector.8 (let ((x #())) (nsubstitute 'b 'a x :from-end t)) #()) (deftest nsubstitute-vector.9 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :from-end t)) #(b b b c)) (deftest nsubstitute-vector.10 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :from-end t :count nil)) #(b b b c)) (deftest nsubstitute-vector.11 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 2 :from-end t)) #(b b b c)) (deftest nsubstitute-vector.12 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 1 :from-end t)) #(a b b c)) (deftest nsubstitute-vector.13 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 0 :from-end t)) #(a b a c)) (deftest nsubstitute-vector.14 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count -1 :from-end t)) #(a b a c)) (deftest nsubstitute-vector.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-vector.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j :from-end t))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-vector.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j :count c))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-vector.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-vector (make-array (- j c) :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest nsubstitute-vector.19 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) result) #(1 2 x x x x x 8 9)) (deftest nsubstitute-vector.20 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) result) #(1 2 x 4 5 6 7 8 9)) (deftest nsubstitute-vector.21 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) :from-end t))) result) #(1 2 3 4 5 6 7 x 9)) (deftest nsubstitute-vector.22 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) result) #(1 2 x 4 5 6 7 8 9)) (deftest nsubstitute-vector.23 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) :from-end t))) result) #(1 2 3 4 5 6 7 x 9)) (deftest nsubstitute-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute 'z 'a x))) result) #(z b z c b)) (deftest nsubstitute-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute 'z 'a x :from-end t))) result) #(z b z c b)) (deftest nsubstitute-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute 'z 'a x :count 1))) result) #(z b a c b)) (deftest nsubstitute-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute 'z 'a x :from-end t :count 1))) result) #(a b z c b)) ;;; Tests on strings (deftest nsubstitute-string.1 (let ((x "")) (nsubstitute #\b #\a x)) "") (deftest nsubstitute-string.2 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x)) "bbbc") (deftest nsubstitute-string.3 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count nil)) "bbbc") (deftest nsubstitute-string.4 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 2)) "bbbc") (deftest nsubstitute-string.5 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 1)) "bbac") (deftest nsubstitute-string.6 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 0)) "abac") (deftest nsubstitute-string.7 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count -1)) "abac") (deftest nsubstitute-string.8 (let ((x "")) (nsubstitute #\b #\a x :from-end t)) "") (deftest nsubstitute-string.9 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :from-end t)) "bbbc") (deftest nsubstitute-string.10 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :from-end t :count nil)) "bbbc") (deftest nsubstitute-string.11 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 2 :from-end t)) "bbbc") (deftest nsubstitute-string.12 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 1 :from-end t)) "abbc") (deftest nsubstitute-string.13 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 0 :from-end t)) "abac") (deftest nsubstitute-string.14 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count -1 :from-end t)) "abac") (deftest nsubstitute-string.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute #\x #\a x :start i :end j))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-string.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute #\x #\a x :start i :end j :from-end t))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-string.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute #\x #\a x :start i :end j :count c))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 (+ i c)) :initial-element #\a))))))) t) (deftest nsubstitute-string.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute #\x #\a x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-string (make-array (- j c) :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest nsubstitute-string.19 (let* ((orig "123456789") (x (copy-seq orig)) (result (nsubstitute #\x #\5 x :test #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (<= (abs (- a b)) 2))))) result) "12xxxxx89") (deftest nsubstitute-string.20 (let* ((orig "123456789") (x (copy-seq orig)) (c -4) (result (nsubstitute #\x #\5 x :test #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c 2) (= (+ b c) a))))) result) "12x456789") (deftest nsubstitute-string.21 (let* ((orig "123456789") (x (copy-seq orig)) (c 5) (result (nsubstitute #\x #\9 x :test #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c -2) (= (+ b c) a)) :from-end t))) result) "1234567x9") (deftest nsubstitute-string.22 (let* ((orig "123456789") (x (copy-seq orig)) (c -4) (result (nsubstitute #\x #\5 x :test-not #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c 2) (/= (+ b c) a))))) result) "12x456789") (deftest nsubstitute-string.23 (let* ((orig "123456789") (x (copy-seq orig)) (c 5) (result (nsubstitute #\x #\9 x :test-not #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c -2) (/= (+ b c) a)) :from-end t))) result) "1234567x9") (deftest nsubstitute-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute #\z #\a x))) result) "zbzcb") (deftest nsubstitute-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute #\z #\a x :from-end t))) result) "zbzcb") (deftest nsubstitute-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute #\z #\a x :count 1))) result) "zbacb") (deftest nsubstitute-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute #\z #\a x :from-end t :count 1))) result) "abzcb") ;;; Tests on bit-vectors (deftest nsubstitute-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute 0 1 x))) result) #*) (deftest nsubstitute-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute 1 0 x))) result) #*) (deftest nsubstitute-bit-vector.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 0 1 x))) result) #*000000) (deftest nsubstitute-bit-vector.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x))) result) #*111111) (deftest nsubstitute-bit-vector.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :start 1))) result) #*011111) (deftest nsubstitute-bit-vector.6 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 0 1 x :start 2 :end nil))) result) #*010000) (deftest nsubstitute-bit-vector.7 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :end 4))) result) #*111101) (deftest nsubstitute-bit-vector.8 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 0 1 x :end nil))) result) #*000000) (deftest nsubstitute-bit-vector.9 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 0 1 x :end 3))) result) #*000101) (deftest nsubstitute-bit-vector.10 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 0 1 x :start 2 :end 4))) result) #*010001) (deftest nsubstitute-bit-vector.11 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :start 2 :end 4))) result) #*011101) (deftest nsubstitute-bit-vector.12 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count 1))) result) #*110101) (deftest nsubstitute-bit-vector.13 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count 0))) result) #*010101) (deftest nsubstitute-bit-vector.14 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count -1))) result) #*010101) (deftest nsubstitute-bit-vector.15 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count 1 :from-end t))) result) #*010111) (deftest nsubstitute-bit-vector.16 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count 0 :from-end t))) result) #*010101) (deftest nsubstitute-bit-vector.17 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count -1 :from-end t))) result) #*010101) (deftest nsubstitute-bit-vector.18 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count nil))) result) #*111111) (deftest nsubstitute-bit-vector.19 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count nil :from-end t))) result) #*111111) (deftest nsubstitute-bit-vector.20 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*0000000000) (x (copy-seq orig)) (y (nsubstitute 1 0 x :start i :end j :count c))) (equalp y (concatenate 'simple-bit-vector (make-list i :initial-element 0) (make-list c :initial-element 1) (make-list (- 10 (+ i c)) :initial-element 0))))))) t) (deftest nsubstitute-bit-vector.21 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*1111111111) (x (copy-seq orig)) (y (nsubstitute 0 1 x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-bit-vector (make-list (- j c) :initial-element 1) (make-list c :initial-element 0) (make-list (- 10 j) :initial-element 1))))))) t) (deftest nsubstitute-bit-vector.22 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) result) #*0111110101) (deftest nsubstitute-bit-vector.23 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) (not (and (<= 2 c 5) (= a b))))))) result) #*0111110101) (deftest nsubstitute-bit-vector.24 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) :from-end t))) result) #*0101011111) (deftest nsubstitute-bit-vector.25 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) (not (and (<= 2 c 5) (= a b)))) :from-end t))) result) #*0101011111) ;;;; additional tests (deftest nsubstitute-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car))) result) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) result) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-list.26 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eql)))) result) ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest nsubstitute-list.27 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eql))) result) ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest nsubstitute-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car))) result) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) result) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-vector.26 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eql)))) result) #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest nsubstitute-vector.27 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eql))) result) #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest nsubstitute-string.24 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute #\a #\1 x :key #'nextdigit))) result) "a1a2342a15") (deftest nsubstitute-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) result) "01a2342015") (deftest nsubstitute-string.26 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute #\a #\1 x :key #'nextdigit :test (complement #'eql)))) result) "0a0aaaa0aa") (deftest nsubstitute-string.27 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute #\a #\1 x :key #'nextdigit :test-not #'eql))) result) "0a0aaaa0aa") (deftest nsubstitute-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute 1 0 x))) result) #*11111) (deftest nsubstitute-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute 1 0 x :from-end t))) result) #*11111) (deftest nsubstitute-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute 1 0 x :count 1))) result) #*11011) (deftest nsubstitute-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute 1 0 x :from-end t :count 1))) result) #*01111) (deftest nsubstitute.order.1 (let ((i 0) a b c d e f g h) (values (nsubstitute (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) nil) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :count (progn (setf d (incf i)) 2) :start (progn (setf e (incf i)) 0) :end (progn (setf f (incf i)) 7) :key (progn (setf g (incf i)) #'identity) :from-end (setf h (incf i)) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 4 5 6 7 8) (deftest nsubstitute.order.2 (let ((i 0) a b c d e f g h) (values (nsubstitute (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) nil) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :from-end (setf h (incf i)) :key (progn (setf g (incf i)) #'identity) :end (progn (setf f (incf i)) 7) :start (progn (setf e (incf i)) 0) :count (progn (setf d (incf i)) 2) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 8 7 6 5 4) ;;; Keyword tests (deftest nsubstitute.allow-other-keys.1 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) (1 2 a 3 1 a 3)) (deftest nsubstitute.allow-other-keys.2 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) (1 2 a 3 1 a 3)) (deftest nsubstitute.allow-other-keys.3 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :allow-other-keys nil :bad t) (1 2 a 3 1 a 3)) (deftest nsubstitute.allow-other-keys.4 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest nsubstitute.allow-other-keys.5 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :key #'1-) (a 2 0 3 a 0 3)) (deftest nsubstitute.keywords.6 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) (a 2 0 3 a 0 3)) (deftest nsubstitute.allow-other-keys.7 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest nsubstitute.allow-other-keys.8 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys nil) (1 2 a 3 1 a 3)) ;;; Error cases (deftest nsubstitute.error.1 (classify-error (nsubstitute)) program-error) (deftest nsubstitute.error.2 (classify-error (nsubstitute 'a)) program-error) (deftest nsubstitute.error.3 (classify-error (nsubstitute 'a 'b)) program-error) (deftest nsubstitute.error.4 (classify-error (nsubstitute 'a 'b nil 'bad t)) program-error) (deftest nsubstitute.error.5 (classify-error (nsubstitute 'a 'b nil 'bad t :allow-other-keys nil)) program-error) (deftest nsubstitute.error.6 (classify-error (nsubstitute 'a 'b nil :key)) program-error) (deftest nsubstitute.error.7 (classify-error (nsubstitute 'a 'b nil 1 2)) program-error) (deftest nsubstitute.error.8 (classify-error (nsubstitute 'a 'b (list 'a 'b 'c) :test #'identity)) program-error) (deftest nsubstitute.error.9 (classify-error (nsubstitute 'a 'b (list 'a 'b 'c) :test-not #'identity)) program-error) (deftest nsubstitute.error.10 (classify-error (nsubstitute 'a 'b (list 'a 'b 'c) :key #'cons)) program-error) (deftest nsubstitute.error.11 (classify-error (nsubstitute 'a 'b (list 'a 'b 'c) :key #'car)) type-error) gcl/ansi-tests/nth-value.lsp000066400000000000000000000013261242227143400163430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 08:24:14 2002 ;;;; Contains: Tests of NTH-VALUE (in-package :cl-test) (deftest nth-value.1 (nth-value 0 'a) a) (deftest nth-value.2 (nth-value 1 'a) nil) (deftest nth-value.3 (nth-value 0 (values)) nil) (deftest nth-value.4 (loop for i from 0 to 19 collect (nth-value i (values 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm 'n 'o 'p 'q 'r 's))) (a b c d e f g h i j k l m n o p q r s nil)) (deftest nth-value.5 (nth-value 100 'a) nil) (deftest nth-value.order.1 (let ((i 0) x y) (values (nth-value (progn (setf x (incf i)) 3) (progn (setf y (incf i)) (values 'a 'b 'c 'd 'e 'f 'g))) i x y)) d 2 1 2) gcl/ansi-tests/or.lsp000066400000000000000000000010561242227143400150600ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 07:29:27 2002 ;;;; Contains: Tests of OR (in-package :cl-test) (deftest or.1 (or) nil) (deftest or.2 (or nil) nil) (deftest or.3 (or 'a) a) (deftest or.4 (or (values 'a 'b 'c)) a b c) (deftest or.5 (or (values))) (deftest or.6 (or (values t nil) 'a) t) (deftest or.7 (or nil (values 'a 'b 'c)) a b c) (deftest or.8 (let ((x 0)) (values (or t (incf x)) x)) t 0) (deftest or.9 (or (values nil 1 2) (values 1 nil 2)) 1 nil 2) gcl/ansi-tests/packages-00.lsp000066400000000000000000000013271242227143400164340ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:07:31 1998 ;;;; Contains: Package test code (common code) (in-package :cl-test) (declaim (optimize (safety 3))) (defpackage "A" (:use) (:nicknames "Q") (:export "FOO")) (defpackage "B" (:use "A") (:export "BAR")) (defpackage "DS1" (:use) (:intern "C" "D") (:export "A" "B")) (defpackage "DS2" (:use) (:intern "E" "F") (:export "G" "H" "A")) (defpackage "DS3" (:shadow "B") (:shadowing-import-from "DS1" "A") (:use "DS1" "DS2") (:export "A" "B" "G" "I" "J" "K") (:intern "L" "M")) (defpackage "DS4" (:shadowing-import-from "DS1" "B") (:use "DS1" "DS3") (:intern "X" "Y" "Z") (:import-from "DS2" "F")) gcl/ansi-tests/packages-01.lsp000066400000000000000000000036521242227143400164400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:49:34 1998 ;;;; Contains: Package test code, part 01 (in-package :cl-test) (declaim (optimize (safety 3))) ;; Test find-symbol, with the various combinations of ;; package designators (deftest find-symbol.1 (find-symbol "aBmAchb1c") nil nil) (deftest find-symbol.2 (find-symbol "aBmAchb1c" "CL") nil nil) (deftest find-symbol.3 (find-symbol "aBmAchb1c" "COMMON-LISP") nil nil) (deftest find-symbol.4 (find-symbol "aBmAchb1c" "KEYWORD") nil nil) (deftest find-symbol.5 (find-symbol "aBmAchb1c" "COMMON-LISP-USER") nil nil) (deftest find-symbol.6 (find-symbol (string '#:car) "CL") car :external) (deftest find-symbol.7 (find-symbol (string '#:car) "COMMON-LISP") car :external) (deftest find-symbol.8 (values (find-symbol (string '#:car) "COMMON-LISP-USER")) car #| :inherited |# ) (deftest find-symbol.9 (find-symbol (string '#:car) "CL-TEST") car :inherited) (deftest find-symbol.10 (find-symbol (string '#:test) "KEYWORD") :test :external) (deftest find-symbol.11 (find-symbol (string '#:find-symbol.11) "CL-TEST") find-symbol.11 :internal) (deftest find-symbol.12 (find-symbol "FOO" #\A) A::FOO :external) (deftest find-symbol.13 (progn (intern "X" (find-package "A")) (find-symbol "X" #\A)) A::X :internal) (deftest find-symbol.14 (find-symbol "FOO" #\B) A::FOO :inherited) (deftest find-symbol.15 (find-symbol "FOO" "B") A::FOO :inherited) (deftest find-symbol.16 (find-symbol "FOO" (find-package "B")) A::FOO :inherited) (deftest find-symbol.order.1 (let ((i 0) x y) (values (find-symbol (progn (setf x (incf i)) (string '#:car)) (progn (setf y (incf i)) "COMMON-LISP")) i x y)) car 2 1 2) (deftest find-symbol.error.1 (classify-error (find-symbol)) program-error) (deftest find-symbol.error.2 (classify-error (find-symbol "CAR" "CL" nil)) program-error)gcl/ansi-tests/packages-02.lsp000066400000000000000000000034551242227143400164420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:50:39 1998 ;;;; Contains: Package test code, aprt 02 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; find-package (deftest find-package.1 (let ((p (find-package "CL")) (p2 (find-package "COMMON-LISP"))) (and p p2 (eqt p p2))) t) (deftest find-package.2 (let ((p (find-package "CL-USER")) (p2 (find-package "COMMON-LISP-USER"))) (and p p2 (eqt p p2))) t) (deftest find-package.3 (let ((p (find-package "KEYWORD"))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.4 (let ((p (ignore-errors (find-package "A")))) (if (packagep p) t p)) t) (deftest find-package.5 (let ((p (ignore-errors (find-package #\A)))) (if (packagep p) t p)) t) (deftest find-package.6 (let ((p (ignore-errors (find-package "B")))) (if (packagep p) t p)) t) (deftest find-package.7 (let ((p (ignore-errors (find-package #\B)))) (if (packagep p) t p)) t) (deftest find-package.8 (let ((p (ignore-errors (find-package "Q"))) (p2 (ignore-errors (find-package "A")))) (and (packagep p) (packagep p2) (eqt p p2))) t) (deftest find-package.9 (let ((p (ignore-errors (find-package "A"))) (p2 (ignore-errors (find-package "B")))) (eqt p p2)) nil) (deftest find-package.10 (let ((p (ignore-errors (find-package #\Q))) (p2 (ignore-errors (find-package "Q")))) (and (packagep p) (eqt p p2))) t) (deftest find-package.11 (let* ((cl (find-package "CL")) (cl2 (find-package cl))) (and (packagep cl) (eqt cl cl2))) t) (deftest find-package.error.1 (classify-error (find-package)) program-error) (deftest find-package.error.2 (classify-error (find-package "CL" nil)) program-error) gcl/ansi-tests/packages-03.lsp000066400000000000000000000116711242227143400164420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:51:26 1998 ;;;; Contains: Package test code, part 03 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; list-all-packages ;; list-all-packages returns a list (deftest list-all-packages.1 (numberp (ignore-errors (list-length (list-all-packages)))) t) ;; The required packages are present (deftest list-all-packages.2 (subsetp (list (find-package "CL") (find-package "CL-USER") (find-package "KEYWORD") (find-package "A") (find-package "RT") (find-package "CL-TEST") (find-package "B")) (list-all-packages)) t) ;; The list returned has only packages in it (deftest list-all-packages.3 (notnot-mv (every #'packagep (list-all-packages))) t) ;; It returns a list of the same packages each time it is called (deftest list-all-packages.4 (let ((p1 (list-all-packages)) (p2 (list-all-packages))) (and (subsetp p1 p2) (subsetp p2 p1))) t) (deftest list-all-packages.error.1 (classify-error (list-all-packages nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-name (deftest package-name.1 (ignore-errors (package-name "A")) "A") (deftest package-name.2 (ignore-errors (package-name #\A)) "A") (deftest package-name.3 (ignore-errors (package-name "Q")) "A") (deftest package-name.4 (ignore-errors (package-name #\Q)) "A") (deftest package-name.5 (notnot-mv (member (classify-error (package-name "NOT-THERE")) '(type-error package-error))) t) (deftest package-name.6 (notnot-mv (member (classify-error (package-name #\*)) '(type-error package-error))) t) (deftest package-name.6a (notnot-mv (member (classify-error (locally (package-name #\*) t)) '(type-error package-error))) t) (deftest package-name.7 (package-name "CL") #.(string '#:common-lisp)) (deftest package-name.8 (package-name "COMMON-LISP") #.(string '#:common-lisp)) (deftest package-name.9 (package-name "COMMON-LISP-USER") #.(string '#:common-lisp-user)) (deftest package-name.10 (package-name "CL-USER") #.(string '#:common-lisp-user)) (deftest package-name.11 (package-name "KEYWORD") #.(string '#:keyword)) (deftest package-name.12 (package-name (find-package "CL")) #.(string '#:common-lisp)) (deftest package-name.13 (let* ((p (make-package "TEMP1")) (pname1 (package-name p))) (rename-package "TEMP1" "TEMP2") (let ((pname2 (package-name p))) (safely-delete-package p) (list pname1 pname2 (package-name p)))) ("TEMP1" "TEMP2" nil)) ;; (find-package (package-name p)) == p for any package p (deftest package-name.14 (loop for p in (list-all-packages) count (not (let ((name (package-name p))) (and (stringp name) (eqt (find-package name) p))))) 0) ;; package-name applied to a package's name ;; should return an equal string (deftest package-name.15 (loop for p in (list-all-packages) count (not (equal (package-name p) (ignore-errors (package-name (package-name p)))))) 0) (deftest package-name.error.1 (classify-error (package-name)) program-error) (deftest package-name.error.2 (classify-error (package-name "CL" nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-nicknames (deftest package-nicknames.1 (ignore-errors (package-nicknames "A")) ("Q")) (deftest package-nicknames.2 (ignore-errors (package-nicknames #\A)) ("Q")) (deftest package-nicknames.3 (ignore-errors (package-nicknames ':|A|)) ("Q")) (deftest package-nicknames.4 (ignore-errors (package-nicknames "B")) nil) (deftest package-nicknames.5 (ignore-errors (package-nicknames #\B)) nil) (deftest package-nicknames.6 (ignore-errors (package-nicknames '#:|B|)) nil) (deftest package-nicknames.7 (ignore-errors (subsetp '(#.(string '#:cl)) (package-nicknames "COMMON-LISP") :test #'string=)) t) (deftest package-nicknames.8 (ignore-errors (notnot (subsetp '(#.(string '#:cl-user)) (package-nicknames "COMMON-LISP-USER") :test #'string=))) t) (deftest package-nicknames.9 (classify-error (package-nicknames 10)) type-error) (deftest package-nicknames.9a (classify-error (locally (package-nicknames 10) t)) type-error) (deftest package-nicknames.10 (ignore-errors (package-nicknames (find-package "A"))) ("Q")) (deftest package-nicknames.11 (notnot-mv (member (classify-error (package-nicknames "NOT-A-PACKAGE-NAME")) '(type-error package-error))) t) ;; (find-package n) == p for each n in (package-nicknames p), ;; for any package p (deftest package-nicknames.12 (loop for p in (list-all-packages) sum (loop for nk in (package-nicknames p) count (not (and (stringp nk) (eqt p (find-package nk)))))) 0) (deftest package-nicknames.error.1 (classify-error (package-nicknames)) program-error) (deftest package-nicknames.error.2 (classify-error (package-nicknames "CL" nil)) program-error) gcl/ansi-tests/packages-04.lsp000066400000000000000000000026361242227143400164440ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:59:10 1998 ;;;; Contains: Package test code, part 04 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; intern (deftest intern.1 (progn (safely-delete-package "TEMP1") (let ((p (make-package "TEMP1")) (i 0) x y) (multiple-value-bind* (sym1 status1) (find-symbol "FOO" p) (intern (progn (setf x (incf i)) "FOO") (progn (setf y (incf i)) p)) (multiple-value-bind* (sym2 status2) (find-symbol "FOO" p) (and (eql i 2) (eql x 1) (eql y 2) (null sym1) (null status1) (string= (symbol-name sym2) "FOO") (eqt (symbol-package sym2) p) (eqt status2 :internal) (progn (delete-package p) t)))))) t) (deftest intern.2 (progn (safely-delete-package "TEMP1") (let ((p (make-package "TEMP1"))) (multiple-value-bind* (sym1 status1) (find-symbol "FOO" "TEMP1") (intern "FOO" "TEMP1") (multiple-value-bind* (sym2 status2) (find-symbol "FOO" p) (and (null sym1) (null status1) (string= (symbol-name sym2) "FOO") (eqt (symbol-package sym2) p) (eqt status2 :internal) (progn (delete-package p) t)))))) t) (deftest intern.error.1 (classify-error (intern)) program-error) (deftest intern.error.2 (classify-error (intern "X" "CL" nil)) program-error) gcl/ansi-tests/packages-05.lsp000066400000000000000000000050331242227143400164370ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:59:45 1998 ;;;; Contains: Package test code, part 05 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; export (deftest export.1 (let ((return-value nil)) (safely-delete-package "TEST1") (let ((p (make-package "TEST1"))) (let ((sym (intern "FOO" p)) (i 0) x y) (setf return-value (export (progn (setf x (incf i)) sym) (progn (setf y (incf i)) p))) (multiple-value-bind* (sym2 status) (find-symbol "FOO" p) (prog1 (and sym2 (eql i 2) (eql x 1) (eql y 2) (eqt (symbol-package sym2) p) (string= (symbol-name sym2) "FOO") (eqt sym sym2) (eqt status :external)) (delete-package p))))) return-value) t) (deftest export.2 (progn (safely-delete-package "TEST1") (let ((p (make-package "TEST1"))) (let ((sym (intern "FOO" p))) (export (list sym) p) (multiple-value-bind* (sym2 status) (find-symbol "FOO" p) (prog1 (and sym2 (eqt (symbol-package sym2) p) (string= (symbol-name sym2) "FOO") (eqt sym sym2) (eqt status :external)) (delete-package p)))))) t) (deftest export.3 (handler-case (progn (safely-delete-package "F") (make-package "F") (let ((sym (intern "FOO" "F"))) (export sym #\F) (delete-package "F") t)) (error (c) (safely-delete-package "F") c)) t) ;; ;; When a symbol not in a package is exported, export ;; should signal a correctable package-error asking the ;; user whether the symbol should be imported. ;; (deftest export.4 (handler-case (export 'b::bar "A") (package-error () 'package-error) (error (c) c)) package-error) ;; ;; Test that it catches an attempt to export a symbol ;; from a package that is used by another package that ;; is exporting a symbol with the same name. ;; (deftest export.5 (progn (safely-delete-package "TEST1") (safely-delete-package "TEST2") (make-package "TEST1") (make-package "TEST2" :use '("TEST1")) (export (intern "X" "TEST2") "TEST2") (prog1 (handler-case (let ((sym (intern "X" "TEST1"))) (handler-case (export sym "TEST1") (error (c) (format t "Caught error in EXPORT.5: ~A~%" c) 'caught))) (error (c) c)) (delete-package "TEST2") (delete-package "TEST1"))) caught) (deftest export.error.1 (classify-error (export)) program-error) (deftest export.error.2 (classify-error (export 'X "CL-TEST" NIL)) program-error) gcl/ansi-tests/packages-06.lsp000066400000000000000000000111421242227143400164360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:00:28 1998 ;;;; Contains: Package test code, part 06 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; rename-package (deftest rename-package.1 (block nil (safely-delete-package "TEST1") (safely-delete-package "TEST2") (let ((p (make-package "TEST1")) (i 0) x y) (unless (packagep p) (return nil)) (let ((p2 (rename-package (progn (setf x (incf i)) "TEST1") (progn (setf y (incf i)) "TEST2")))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (eql i 2) (eql x 1) (eql y 2) (equal (package-name p2) "TEST2")) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t))) t) (deftest rename-package.2 (block nil (safely-delete-package "TEST1") (safely-delete-package "TEST2") (safely-delete-package "TEST3") (safely-delete-package "TEST4") (safely-delete-package "TEST5") (let ((p (make-package "TEST1")) (nicknames (copy-list '("TEST3" "TEST4" "TEST5")))) (unless (packagep p) (return nil)) (let ((p2 (rename-package "TEST1" "TEST2" nicknames))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (equal (package-name p2) "TEST2") (null (set-exclusive-or nicknames (package-nicknames p2) :test #'equal))) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t))) t) (deftest rename-package.3 (block nil (safely-delete-package "TEST1") (safely-delete-package "TEST2") (let ((p (make-package "TEST1")) (nicknames (copy-list '(#\M #\N)))) (unless (packagep p) (return nil)) (let ((p2 (ignore-errors (rename-package "TEST1" "TEST2" nicknames)))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (equal (package-name p2) "TEST2") (equal (sort (copy-list (package-nicknames p2)) #'string<) (sort (mapcar #'(lambda (c) (make-string 1 :initial-element c)) nicknames) #'string<))) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t))) t) (deftest rename-package.4 (block nil (safely-delete-package "G") (safely-delete-package "TEST2") (let ((p (make-package "G")) (nicknames nil)) (unless (packagep p) (return nil)) (let ((p2 (ignore-errors (rename-package #\G "TEST2" nicknames)))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (equal (package-name p2) "TEST2") (null (set-exclusive-or nicknames (package-nicknames p2) :test #'equal))) (safely-delete-package p) (safely-delete-package p2) (return nil)) (ignore-errors (safely-delete-package p2)) t))) t) (deftest rename-package.5 (block nil (safely-delete-package "TEST1") (safely-delete-package "G") (let ((p (make-package "TEST1")) (nicknames nil)) (unless (packagep p) (return nil)) (let ((p2 (ignore-errors (rename-package "TEST1" #\G nicknames)))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (equal (package-name p2) "G") (null (set-exclusive-or nicknames (package-nicknames p2) :test #'equal))) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t))) t) (deftest rename-package.6 (block nil (safely-delete-package '|TEST1|) (safely-delete-package '|TEST2|) (safely-delete-package '|M|) (safely-delete-package '|N|) (let ((p (make-package '|TEST1|)) (nicknames (copy-list '(|M| |N|)))) (unless (packagep p) (return nil)) (let ((p2 (ignore-errors (rename-package '|TEST1| '|TEST2| nicknames)))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (equal (package-name p2) "TEST2") (equal (sort (copy-list (package-nicknames p2)) #'string<) (sort (mapcar #'symbol-name nicknames) #'string<))) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t))) t) (deftest rename-package.error.1 (classify-error (rename-package)) program-error) (deftest rename-package.error.2 (classify-error (rename-package "CL")) program-error) (deftest rename-package.error.3 (classify-error (rename-package "A" "XXXXX" NIL NIL)) program-error) gcl/ansi-tests/packages-07.lsp000066400000000000000000000136651242227143400164530ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:01:20 1998 ;;;; Contains: Package test code, part 07 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; shadow (deftest shadow.1 (prog1 (progn (safely-delete-package "TEST5") (safely-delete-package "TEST4") (handler-case (let* ((p1 (prog1 (make-package "TEST4") (export (intern "A" "TEST4") "TEST4"))) (p2 (make-package "TEST5" :use '("TEST4"))) (r1 (package-shadowing-symbols "TEST4")) (r2 (package-shadowing-symbols "TEST5"))) (multiple-value-bind* (s1 kind1) (find-symbol "A" p1) (multiple-value-bind* (s2 kind2) (find-symbol "A" p2) (let ((r3 (shadow "A" p2))) (multiple-value-bind* (s3 kind3) (find-symbol "A" p2) (list (package-name p1) (package-name p2) r1 r2 (symbol-name s1) (package-name (symbol-package s1)) kind1 (symbol-name s2) (package-name (symbol-package s2)) kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) kind3)))))) (error (c) c))) (safely-delete-package "TEST5") (safely-delete-package "TEST4")) ("TEST4" "TEST5" nil nil "A" "TEST4" :external "A" "TEST4" :inherited t "A" "TEST5" :internal)) (deftest shadow.2 (progn (safely-delete-package "H") (safely-delete-package "G") (handler-case (let* ((p1 (prog1 (make-package "G") (export (intern "A" "G") "G"))) (p2 (make-package "H" :use '("G"))) (r1 (package-shadowing-symbols "G")) (r2 (package-shadowing-symbols "H"))) (multiple-value-bind* (s1 kind1) (find-symbol "A" p1) (multiple-value-bind* (s2 kind2) (find-symbol "A" p2) (let ((r3 (shadow "A" "H"))) (multiple-value-bind* (s3 kind3) (find-symbol "A" p2) (prog1 (list (package-name p1) (package-name p2) r1 r2 (symbol-name s1) (package-name (symbol-package s1)) kind1 (symbol-name s2) (package-name (symbol-package s2)) kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) kind3) (safely-delete-package p2) (safely-delete-package p1) )))))) (error (c) (safely-delete-package "H") (safely-delete-package "G") c))) ("G" "H" nil nil "A" "G" :external "A" "G" :inherited t "A" "H" :internal)) ;; shadow in which the package is given ;; by a character (deftest shadow.3 (progn (safely-delete-package "H") (safely-delete-package "G") (handler-case (let* ((p1 (prog1 (make-package "G") (export (intern "A" "G") "G"))) (p2 (make-package "H" :use '("G"))) (r1 (package-shadowing-symbols "G")) (r2 (package-shadowing-symbols "H"))) (multiple-value-bind* (s1 kind1) (find-symbol "A" p1) (multiple-value-bind* (s2 kind2) (find-symbol "A" p2) (let ((r3 (shadow "A" #\H))) (multiple-value-bind* (s3 kind3) (find-symbol "A" p2) (prog1 (list (package-name p1) (package-name p2) r1 r2 (symbol-name s1) (package-name (symbol-package s1)) kind1 (symbol-name s2) (package-name (symbol-package s2)) kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) kind3) (safely-delete-package p2) (safely-delete-package p1) )))))) (error (c) (safely-delete-package "H") (safely-delete-package "G") c))) ("G" "H" nil nil "A" "G" :external "A" "G" :inherited t "A" "H" :internal)) ;; shadow on an existing internal symbol returns the existing symbol (deftest shadow.4 (prog1 (handler-case (progn (safely-delete-package :G) (make-package :G) (let ((s1 (intern "X" :G))) (shadow "X" :G) (multiple-value-bind* (s2 kind) (find-symbol "X" :G) (list (eqt s1 s2) (symbol-name s2) (package-name (symbol-package s2)) kind)))) (error (c) c)) (safely-delete-package "G")) (t "X" "G" :internal)) ;; shadow of an existing shadowed symbol returns the symbol (deftest shadow.5 (prog1 (handler-case (progn (safely-delete-package :H) (safely-delete-package :G) (make-package :G) (export (intern "X" :G) :G) (make-package :H :use '("G")) (shadow "X" :H) (multiple-value-bind* (s1 kind1) (find-symbol "X" :H) (shadow "X" :H) (multiple-value-bind* (s2 kind2) (find-symbol "X" :H) (list (eqt s1 s2) kind1 kind2)))) (error (c) c)) (safely-delete-package :H) (safely-delete-package :G)) (t :internal :internal)) ;; Shadow several names simultaneously (deftest shadow.6 (prog1 (handler-case (progn (safely-delete-package :G) (make-package :G) (shadow '("X" "Y" |Z|) :G) (let ((results (append (multiple-value-list (find-symbol "X" :G)) (multiple-value-list (find-symbol "Y" :G)) (multiple-value-list (find-symbol "Z" :G)) nil))) (list (symbol-name (first results)) (second results) (symbol-name (third results)) (fourth results) (symbol-name (fifth results)) (sixth results) (length (package-shadowing-symbols :G))))) (error (c) c)) (safely-delete-package :G)) ("X" :internal "Y" :internal "Z" :internal 3)) ;; Same, but shadow character string designators (deftest shadow.7 (prog1 (handler-case (let ((i 0) x y) (safely-delete-package :G) (make-package :G) (shadow (progn (setf x (incf i)) '(#\X #\Y)) (progn (setf y (incf i)) :G)) (let ((results (append (multiple-value-list (find-symbol "X" :G)) (multiple-value-list (find-symbol "Y" :G)) nil))) (list i x y (symbol-name (first results)) (second results) (symbol-name (third results)) (fourth results) (length (package-shadowing-symbols :G))))) (error (c) c)) (safely-delete-package :G)) (2 1 2 "X" :internal "Y" :internal 2)) (deftest shadow.error.1 (classify-error (shadow)) program-error) (deftest shadow.error.2 (classify-error (shadow "X" "CL-USER" nil)) program-error) gcl/ansi-tests/packages-08.lsp000066400000000000000000000072601242227143400164460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:01:58 1998 ;;;; Contains: Package test code, part 08 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; delete-package ;; check return value of delete-package, and check ;; that package-name is nil on the deleted package object (deftest delete-package.1 (progn (safely-delete-package :test1) (let ((p (make-package :test1 :use nil))) (list (notnot (delete-package :test1)) (notnot (packagep p)) (package-name p)))) (t t nil)) (deftest delete-package.2 (progn (safely-delete-package :test1) (let ((p (make-package :test1 :use nil))) (list (notnot (delete-package :test1)) (notnot (packagep p)) (delete-package p)))) (t t nil)) ;; Check that deletion of different package designators works (deftest delete-package.3 (progn (safely-delete-package "X") (make-package "X") (handler-case (notnot (delete-package "X")) (error (c) c))) t) (deftest delete-package.4 (progn (safely-delete-package "X") (make-package "X") (handler-case (notnot (delete-package #\X)) (error (c) c))) t) ;;; PFD 10/14/02 -- These tests are broken again. I suspect ;;; some sort of interaction with the test harness. ;;; PFD 01.18.03 This test is working, but suspicious. (deftest delete-package.5 (prog (P1 S1 P2 S2 P3) (safely-delete-package "P3") (safely-delete-package "P2") (safely-delete-package "P1") (setq P1 (make-package "P1" :use ())) (setq S1 (intern "S1" P1)) (export S1 "P1") (setq P2 (make-package "P2" :use '("P1"))) (setq S2 (intern "S2" P2)) (export S1 P2) (export S2 "P2") (setf P3 (make-package "P3" :use '("P2"))) ;; Delete the P2 package, catching the continuable ;; error and deleting the package (handler-bind ((package-error #'(lambda (c) (let ((r (find-restart 'continue c))) (and r (invoke-restart r)))))) (delete-package P2)) (unless (and (equal (package-name P1) "P1") (null (package-name P2)) (equal (package-name P3) "P3")) (return 'fail1)) (unless (eqt (symbol-package S1) P1) (return 'fail2)) (unless (equal (prin1-to-string S1) "P1:S1") (return 'fail3)) (unless (equal (multiple-value-list (find-symbol "S1" P3)) '(nil nil)) (return 'fail4)) (unless (equal (multiple-value-list (find-symbol "S2" P3)) '(nil nil)) (return 'fail5)) (unless (and (null (package-used-by-list P1)) (null (package-used-by-list P3))) (return 'fail6)) (unless (and (packagep P1) (packagep P2) (packagep P3)) (return 'fail7)) (unless (and (null (package-use-list P1)) (null (package-use-list P3))) (return 'fail8)) (safely-delete-package P3) (safely-delete-package P1) (return t)) t) ;; deletion of a nonexistent package should cause a continuable ;; package-error (same comments for delete-package.5 apply ;; here as well) ;;; PFD 10/14/02 -- These tests are broken again. I suspect ;;; some sort of interaction with the test harness. ;;; PFD 01.18.03 This test is working, but suspicious. (deftest delete-package.6 (progn (safely-delete-package "TEST-20)") (handler-bind ((package-error #'(lambda (c) (let ((r (find-restart 'continue c))) (and r (invoke-restart r)))))) (and (not (delete-package "TEST-20")) t))) t) (deftest delete-package.error.1 (classify-error (delete-package)) program-error) (deftest delete-package.error.2 (progn (unless (find-package "TEST-DPE2") (make-package "TEST-DPE2" :use nil)) (classify-error (delete-package "TEST-DPE2" nil))) program-error) gcl/ansi-tests/packages-09.lsp000066400000000000000000000215451242227143400164510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:02:43 1998 ;;;; Contains: Package test code, part 09 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; make-package ;; Test basic make-package, using string, symbol and character ;; package-designators (deftest make-package.1 (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1")))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.2 (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1|)))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.3 (progn (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X)))) (prog1 (and (packagep p) (equalt (package-name p) "X") (equalt (package-nicknames p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) ;; Same, but with a null :use list (deftest make-package.4 (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use nil)))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.5 (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use nil)))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.6 (progn (safely-delete-package #\X) (let ((p (make-package #\X))) (prog1 (and (packagep p) (equalt (package-name p) "X") (equalt (package-nicknames p) nil) ;; (equalt (package-use-list p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) ;; Same, but use the A package (deftest make-package.7 (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use '("A"))))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.7a (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use '(#:|A|))))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.7b (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use '(#\A))))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.8 (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '("A"))))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.8a (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#:|A|))))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.8b (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#\A))))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.9 (progn (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '("A"))))) (prog1 (and (packagep p) (equalt (package-name p) "X") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.9a (progn (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '(#:|A|))))) (prog1 (and (packagep p) (equalt (package-name p) "X") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.9b (progn (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '(#\A))))) (prog1 (and (packagep p) (equalt (package-name p) "X") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) ;; make-package with nicknames (deftest make-package.10 (progn (safely-delete-package "TEST1") (let ((p (make-package "TEST1" :nicknames '("F")))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) '("F")) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.11 (progn (safely-delete-package '#:|TEST1|) (let ((p (make-package '#:|TEST1| :nicknames '(#:|G|)))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) '("G")) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.12 (progn (safely-delete-package '#:|TEST1|) (let ((p (make-package '#:|TEST1| :nicknames '(#\G)))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) '("G")) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.13 (progn (safely-delete-package #\X) (let ((p (make-package #\X :nicknames '("F" #\G #:|H|)))) (prog1 (and (packagep p) (equalt (package-name p) "X") (null (set-exclusive-or (package-nicknames p) '("F" "G" "H") :test #'equal)) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) ;; Signal a continuable error if the package or any nicknames ;; exist as packages or nicknames of packages (deftest make-package.error.1 (handle-non-abort-restart (make-package "A")) success) (deftest make-package.error.2 (handle-non-abort-restart (make-package "Q")) success) (deftest make-package.error.3 (handle-non-abort-restart (safely-delete-package "TEST1") (make-package "TEST1" :nicknames '("A"))) success) (deftest make-package.error.4 (handle-non-abort-restart (safely-delete-package "TEST1") (make-package "TEST1" :nicknames '("Q"))) success) (deftest make-package.error.5 (classify-error (make-package)) program-error) (deftest make-package.error.6 (progn (safely-delete-package "MPE6") (classify-error (make-package "MPE6" :bad t))) program-error) (deftest make-package.error.7 (progn (safely-delete-package "MPE7") (classify-error (make-package "MPE7" :nicknames))) program-error) (deftest make-package.error.8 (progn (safely-delete-package "MPE8") (classify-error (make-package "MPE8" :use))) program-error) (deftest make-package.error.9 (progn (safely-delete-package "MPE9") (classify-error (make-package "MPE9" 'bad t))) program-error) (deftest make-package.error.10 (progn (safely-delete-package "MPE10") (classify-error (make-package "MPE10" 1 2))) program-error) (deftest make-package.error.11 (progn (safely-delete-package "MPE11") (classify-error (make-package "MPE11" 'bad t :allow-other-keys nil))) program-error) gcl/ansi-tests/packages-10.lsp000066400000000000000000000057241242227143400164420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:03:36 1998 ;;;; Contains: Package test code, part 10 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; with-package-iterator (deftest with-package-iterator.1 (with-package-iterator-internal (list (find-package "COMMON-LISP-USER"))) t) (deftest with-package-iterator.2 (with-package-iterator-external (list (find-package "COMMON-LISP-USER"))) t) (deftest with-package-iterator.3 (with-package-iterator-inherited (list (find-package "COMMON-LISP-USER"))) t) (deftest with-package-iterator.4 (with-package-iterator-all (list (find-package "COMMON-LISP-USER"))) t) ;;; Should test on some packages containing shadowed symbols, ;;; multiple inheritance (deftest with-package-iterator.5 (with-package-iterator-all '("A")) t) (deftest with-package-iterator.6 (with-package-iterator-all '(#:|A|)) t) (deftest with-package-iterator.7 (with-package-iterator-all '(#\A)) t) (deftest with-package-iterator.8 (with-package-iterator-internal (list (find-package "A"))) t) (deftest with-package-iterator.9 (with-package-iterator-external (list (find-package "A"))) t) (deftest with-package-iterator.10 (with-package-iterator-inherited (list (find-package "A"))) t) ;;; Check that if no access symbols are provided, a program error is ;;; raised #| (deftest with-package-iterator.11 (handler-case (progn (test-with-package-iterator (list (find-package "COMMON-LISP-USER"))) nil) (program-error () t) (error (c) c)) t) |# ;;; Paul Werkowski" pointed out that ;;; that test is broken. Here's a version of the replacement ;;; he suggested. ;; ;;; I'm not sure if this is correct either; it depends on ;;; whether with-package-iterator should signal the error ;;; at macro expansion time or at run time. ;; ;;; PFD 01-18-03: I should rewrite this to use CLASSIFY-ERROR, which ;;; uses EVAL to avoid that problem. (deftest with-package-iterator.11 (handler-case (macroexpand-1 '(with-package-iterator (x "COMMON-LISP-USER"))) (program-error () t) (error (c) c)) t) ;;; Apply to all packages (deftest with-package-iterator.12 (loop for p in (list-all-packages) count (handler-case (progn (format t "Package ~S~%" p) (not (with-package-iterator-internal (list p)))) (error (c) (format "Error ~S on package ~A~%" c p) t))) 0) (deftest with-package-iterator.13 (loop for p in (list-all-packages) count (handler-case (progn (format t "Package ~S~%" p) (not (with-package-iterator-external (list p)))) (error (c) (format "Error ~S on package ~A~%" c p) t))) 0) (deftest with-package-iterator.14 (loop for p in (list-all-packages) count (handler-case (progn (format t "Package ~S~%" p) (not (with-package-iterator-inherited (list p)))) (error (c) (format t "Error ~S on package ~S~%" c p) t))) 0) gcl/ansi-tests/packages-11.lsp000066400000000000000000000065221242227143400164400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:04:19 1998 ;;;; Contains: Package test code, part 11 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; unexport (deftest unexport.1 (progn (safely-delete-package "X") (let* ((p (make-package "X" :use nil)) (r (export (intern "X" p) p)) (i 0) x y) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (unexport (progn (setf x (incf i)) sym1) (progn (setf y (incf i)) p)) (multiple-value-bind* (sym2 access2) (find-symbol "X" p) (and (eqt r t) (eql i 2) (eql x 1) (eql y 2) (eqt sym1 sym2) (eqt access1 :external) (eqt access2 :internal) (equal (symbol-name sym1) "X") t))))) t) (deftest unexport.2 (progn (safely-delete-package "X") (let* ((p (make-package "X" :use nil)) (r (export (intern "X" p) p))) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (unexport (list sym1) "X") (multiple-value-bind* (sym2 access2) (find-symbol "X" p) (and (eqt sym1 sym2) (eqt r t) (eqt access1 :external) (eqt access2 :internal) (equal (symbol-name sym1) "X") t))))) t) (deftest unexport.3 (progn (safely-delete-package "X") (let* ((p (make-package "X" :use nil)) (r1 (export (intern "X" p) p)) (r2 (export (intern "Y" p) p))) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (multiple-value-bind* (sym1a access1a) (find-symbol "Y" p) (unexport (list sym1 sym1a) '#:|X|) (multiple-value-bind* (sym2 access2) (find-symbol "X" p) (multiple-value-bind* (sym2a access2a) (find-symbol "Y" p) (and (eqt sym1 sym2) (eqt sym1a sym2a) (eqt r1 t) (eqt r2 t) (eqt access1 :external) (eqt access2 :internal) (eqt access1a :external) (eqt access2a :internal) (equal (symbol-name sym1) "X") (equal (symbol-name sym1a) "Y") t))))))) t) (deftest unexport.4 (progn (safely-delete-package "X") (let* ((p (make-package "X" :use nil)) (r (export (intern "X" p) p))) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (unexport (list sym1) #\X) (multiple-value-bind* (sym2 access2) (find-symbol "X" p) (and (eqt sym1 sym2) (eqt r t) (eqt access1 :external) (eqt access2 :internal) (equal (symbol-name sym1) "X") t))))) t) ;; Check that it signals a package error when unexporting ;; an inaccessible symbol (deftest unexport.5 (classify-error (progn (when (find-package "X") (delete-package "X")) (unexport 'a (make-package "X" :use nil)) nil)) package-error) ;; Check that internal symbols are left alone (deftest unexport.6 (progn (when (find-package "X") (delete-package "X")) (let ((p (make-package "X" :use nil))) (let* ((sym (intern "FOO" p)) (r (unexport sym p))) (multiple-value-bind* (sym2 access) (find-symbol "FOO" p) (and (eqt r t) (eqt access :internal) (eqt sym sym2) (equal (symbol-name sym) "FOO") t))))) t) (deftest unexport.error.1 (classify-error (unexport)) program-error) (deftest unexport.error.2 (classify-error (unexport 'xyz "CL-TEST" nil)) program-error) gcl/ansi-tests/packages-12.lsp000066400000000000000000000147321242227143400164430ustar00rootroot00000000000000();-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:04:56 1998 ;;;; Contains: Package test code, part 12 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; unintern ;; Simple unintern of an internal symbol, package explicitly ;; given as a package object (deftest unintern.1 (progn (safely-delete-package "H") (prog1 (let ((p (make-package "H")) (i 0) x y) (intern "FOO" p) (multiple-value-bind* (sym access) (find-symbol "FOO" p) (and (eqt access :internal) (unintern (progn (setf x (incf i)) sym) (progn (setf y (incf i)) p)) (eql i 2) (eql x 1) (eql y 2) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (safely-delete-package "H"))) t) ;; Simple unintern, package taken from the *PACKAGES* ;; special variable (should this have unwind protect?) (deftest unintern.2 (progn (safely-delete-package "H") (prog1 (let ((*PACKAGE* (make-package "H"))) (declare (special *PACKAGE*)) (intern "FOO") (multiple-value-bind* (sym access) (find-symbol "FOO") (and (eqt access :internal) (unintern sym) (null (symbol-package sym)) (not (find-symbol "FOO"))))) (safely-delete-package "H"))) t) ;; Simple unintern, package given as string (deftest unintern.3 (progn (safely-delete-package "H") (prog1 (let ((p (make-package "H"))) (intern "FOO" p) (multiple-value-bind* (sym access) (find-symbol "FOO" p) (and (eqt access :internal) (unintern sym "H") (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (safely-delete-package "H"))) t) ;; Simple unintern, package given as symbol (deftest unintern.4 (progn (safely-delete-package "H") (prog1 (let ((p (make-package "H"))) (intern "FOO" p) (multiple-value-bind* (sym access) (find-symbol "FOO" p) (and (eqt access :internal) (unintern sym '#:|H|) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (safely-delete-package "H"))) t) ;; Simple unintern, package given as character (deftest unintern.5 (handler-case (progn (safely-delete-package "H") (prog1 (let ((p (make-package "H"))) (intern "FOO" p) (multiple-value-bind* (sym access) (find-symbol "FOO" p) (and (eqt access :internal) (unintern sym #\H) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (safely-delete-package "H"))) (error (c) c)) t) ;; Test more complex examples of unintern ;; Unintern an external symbol that is also inherited (deftest unintern.6 (handler-case (progn (safely-delete-package "H") (safely-delete-package "G") (make-package "G") (export (intern "FOO" "G") "G") (make-package "H" :use '("G")) (export (intern "FOO" "H") "H") ;; At this point, G:FOO is also an external ;; symbol of H. (multiple-value-bind* (sym1 access1) (find-symbol "FOO" "H") (and sym1 (eqt access1 :external) (equal "FOO" (symbol-name sym1)) (eqt (find-package "G") (symbol-package sym1)) (unintern sym1 "H") (multiple-value-bind* (sym2 access2) (find-symbol "FOO" "H") (and (eqt sym1 sym2) (eqt (symbol-package sym1) (find-package "G")) (eqt access2 :inherited)))))) (error (c) c)) t) ;; unintern a symbol that is shadowing another symbol (deftest unintern.7 (block failed (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G")) (ph (make-package "H" :use (list pg)))) (handler-case (shadow "FOO" ph) (error (c) (return-from failed (list :shadow-error c)))) (export (intern "FOO" pg) pg) ;; At this point, H::FOO shadows G:FOO (multiple-value-bind* (sym1 access1) (find-symbol "FOO" ph) (and sym1 (eqt (symbol-package sym1) ph) (eqt access1 :internal) (equal (list sym1) (package-shadowing-symbols ph)) (unintern sym1 ph) (multiple-value-bind* (sym2 access2) (find-symbol "FOO" ph) (and (not (eqt sym1 sym2)) (eqt access2 :inherited) (null (symbol-package sym1)) (eqt (symbol-package sym2) pg))))))) t) ;; Error situation: when the symbol is uninterned, creates ;; a name conflict from two used packages (deftest unintern.8 (block failed (safely-delete-package "H") (safely-delete-package "G1") (safely-delete-package "G2") (let* ((pg1 (make-package "G1")) (pg2 (make-package "G2")) (ph (make-package "H" :use (list pg1 pg2)))) (handler-case (shadow "FOO" ph) (error (c) (return-from failed (list :shadow-error c)))) (let ((gsym1 (intern "FOO" pg1)) (gsym2 (intern "FOO" pg2))) (export gsym1 pg1) (export gsym2 pg2) (multiple-value-bind* (sym1 access1) (find-symbol "FOO" ph) (and (equal (list sym1) (package-shadowing-symbols ph)) (not (eqt sym1 gsym1)) (not (eqt sym1 gsym2)) (eqt (symbol-package sym1) ph) (eqt access1 :internal) (equal (symbol-name sym1) "FOO") (handler-case (progn (unintern sym1 ph) nil) (error (c) (format t "Properly threw an error: ~S~%" c) t))))))) t) ;; Now, inherit the same symbol through two intermediate ;; packages. No error should occur when the shadowing ;; is removed (deftest unintern.9 (block failed (safely-delete-package "H") (safely-delete-package "G1") (safely-delete-package "G2") (safely-delete-package "G3") (let* ((pg3 (make-package "G3")) (pg1 (make-package "G1" :use (list pg3))) (pg2 (make-package "G2" :use (list pg3))) (ph (make-package "H" :use (list pg1 pg2)))) (handler-case (shadow "FOO" ph) (error (c) (return-from failed (list :shadow-error c)))) (let ((gsym (intern "FOO" pg3))) (export gsym pg3) (export gsym pg1) (export gsym pg2) (multiple-value-bind* (sym access) (find-symbol "FOO" ph) (and (equal (list sym) (package-shadowing-symbols ph)) (not (eqt sym gsym)) (equal (symbol-name sym) "FOO") (equal (symbol-package sym) ph) (eqt access :internal) (handler-case (and (unintern sym ph) (multiple-value-bind* (sym2 access2) (find-symbol "FOO" ph) (and (eqt gsym sym2) (eqt access2 :inherited)))) (error (c) c))))))) t) (deftest unintern.error.1 (classify-error (unintern)) program-error) (deftest unintern.error.2 (classify-error (unintern '#:x "CL-TEST" nil)) program-error) gcl/ansi-tests/packages-13.lsp000066400000000000000000000023461242227143400164420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:06:03 1998 ;;;; Contains: Package test code, part 13 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; in-package (deftest in-package.1 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package "A"))) (and (eqt p2 (find-package "A")) (eqt *package* p2)))) t) (deftest in-package.2 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package |A|))) (and (eqt p2 (find-package "A")) (eqt *package* p2)))) t) (deftest in-package.3 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package :|A|))) (and (eqt p2 (find-package "A")) (eqt *package* p2)))) t) (deftest in-package.4 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package #\A))) (and (eqt p2 (find-package "A")) (eqt *package* p2)))) t) (deftest in-package.5 (let ((*package* *package*)) (declare (special *package*)) (safely-delete-package "H") (handler-case (eval '(in-package "H")) (package-error () 'package-error) (error (c) c))) package-error) gcl/ansi-tests/packages-14.lsp000066400000000000000000000134031242227143400164370ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:06:48 1998 ;;;; Contains: Package test code, part 14 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; unuse-package (deftest unuse-package.1 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G"))) (i 0) x y) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (unuse-package (progn (setf x (incf i)) pg) (progn (setf y (incf i)) ph)) (eql i 2) (eql x 1) (eql y 2) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.2 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (unuse-package "G" ph) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.3 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (unuse-package :|G| ph) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.4 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (ignore-errors (unuse-package #\G ph)) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.5 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (unuse-package (list pg) ph) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.6 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (unuse-package (list "G") ph) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.7 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (unuse-package (list :|G|) ph) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.8 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (ignore-errors (unuse-package (list #\G) ph)) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) ;; Now test with multiple packages (deftest unuse-package.9 (progn (dolist (p '("H1" "H2" "G1" "G2" "G3")) (safely-delete-package p)) (let* ((pg1 (make-package "G1" :use nil)) (pg2 (make-package "G2" :use nil)) (pg3 (make-package "G3" :use nil)) (ph1 (make-package "H1" :use (list pg1 pg2 pg3))) (ph2 (make-package "H2" :use (list pg1 pg2 pg3)))) (let ((pubg1 (sort-package-list (package-used-by-list pg1))) (pubg2 (sort-package-list (package-used-by-list pg2))) (pubg3 (sort-package-list (package-used-by-list pg3))) (puh1 (sort-package-list (package-use-list ph1))) (puh2 (sort-package-list (package-use-list ph2)))) (prog1 (and (= (length (remove-duplicates (list pg1 pg2 pg3 ph1 ph2))) 5) (equal (list ph1 ph2) pubg1) (equal (list ph1 ph2) pubg2) (equal (list ph1 ph2) pubg3) (equal (list pg1 pg2 pg3) puh1) (equal (list pg1 pg2 pg3) puh2) (unuse-package (list pg1 pg3) ph1) (equal (package-use-list ph1) (list pg2)) (equal (package-used-by-list pg1) (list ph2)) (equal (package-used-by-list pg3) (list ph2)) (equal (sort-package-list (package-use-list ph2)) (list pg1 pg2 pg3)) (equal (sort-package-list (package-used-by-list pg2)) (list ph1 ph2)) t) (dolist (p '("H1" "H2" "G1" "G2" "G3")) (safely-delete-package p)))))) t) (deftest unuse-package.error.1 (classify-error (unuse-package)) program-error) (deftest unuse-package.error.2 (progn (safely-delete-package "UPE2A") (safely-delete-package "UPE2") (make-package "UPE2" :use ()) (make-package "UPE2A" :use '("UPE2")) (classify-error (unuse-package "UPE2" "UPE2A" nil))) program-error) gcl/ansi-tests/packages-15.lsp000066400000000000000000000137401242227143400164440ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:08:41 1998 ;;;; Contains: Package test code, part 15 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; use-package (deftest use-package.1 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use nil)) (sym1 (intern "FOO" pg)) (i 0) x y) (and (eqt (export sym1 pg) t) (null (package-used-by-list pg)) (null (package-used-by-list ph)) (null (package-use-list pg)) (null (package-use-list ph)) (eqt (use-package (progn (setf x (incf i)) pg) (progn (setf y (incf i)) ph)) t) ;; "H" will use "G" (eql i 2) (eql x 1) (eql y 2) (multiple-value-bind (sym2 access) (find-symbol "FOO" ph) (and (eqt access :inherited) (eqt sym1 sym2))) (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (null (package-use-list pg)) (null (package-used-by-list ph)) (eqt (unuse-package pg ph) t) (null (find-symbol "FOO" ph))))) t) (deftest use-package.2 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use nil)) (sym1 (intern "FOO" pg))) (and (eqt (export sym1 pg) t) (null (package-used-by-list pg)) (null (package-used-by-list ph)) (null (package-use-list pg)) (null (package-use-list ph)) (eqt (use-package "G" "H") t) ;; "H" will use "G" (multiple-value-bind (sym2 access) (find-symbol "FOO" ph) (and (eqt access :inherited) (eqt sym1 sym2))) (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (null (package-use-list pg)) (null (package-used-by-list ph)) (eqt (unuse-package pg ph) t) (null (find-symbol "FOO" ph))))) t) (deftest use-package.3 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use nil)) (sym1 (intern "FOO" pg))) (and (eqt (export sym1 pg) t) (null (package-used-by-list pg)) (null (package-used-by-list ph)) (null (package-use-list pg)) (null (package-use-list ph)) (eqt (use-package '#:|G| '#:|H|) t) ;; "H" will use "G" (multiple-value-bind (sym2 access) (find-symbol "FOO" ph) (and (eqt access :inherited) (eqt sym1 sym2))) (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (null (package-use-list pg)) (null (package-used-by-list ph)) (eqt (unuse-package pg ph) t) (null (find-symbol "FOO" ph))))) t) (deftest use-package.4 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use nil)) (sym1 (intern "FOO" pg))) (and (eqt (export sym1 pg) t) (null (package-used-by-list pg)) (null (package-used-by-list ph)) (null (package-use-list pg)) (null (package-use-list ph)) (eqt (ignore-errors (use-package #\G #\H)) t) ;; "H" will use "G" (multiple-value-bind (sym2 access) (find-symbol "FOO" ph) (and (eqt access :inherited) (eqt sym1 sym2))) (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (null (package-use-list pg)) (null (package-used-by-list ph)) (eqt (unuse-package pg ph) t) (null (find-symbol "FOO" ph))))) t) ;; use lists of packages (deftest use-package.5 (let ((pkgs '("H" "G1" "G2" "G3")) (vars '("FOO1" "FOO2" "FOO3"))) (dolist (p pkgs) (safely-delete-package p) (make-package p :use nil)) (and (every (complement #'package-use-list) pkgs) (every (complement #'package-used-by-list) pkgs) (every #'(lambda (v p) (export (intern v p) p)) vars (cdr pkgs)) (progn (dolist (p (cdr pkgs)) (intern "MINE" p)) (eqt (use-package (cdr pkgs) (car pkgs)) t)) (every #'(lambda (v p) (eqt (find-symbol v p) (find-symbol v (car pkgs)))) vars (cdr pkgs)) (null (find-symbol "MINE" (car pkgs))) (every #'(lambda (p) (equal (package-used-by-list p) (list (find-package (car pkgs))))) (cdr pkgs)) (equal (sort-package-list (package-use-list (car pkgs))) (mapcar #'find-package (cdr pkgs))) (every (complement #'package-use-list) (cdr pkgs)) (null (package-used-by-list (car pkgs))))) t) ;; Circular package use (deftest use-package.6 (progn (safely-delete-package "H") (safely-delete-package "G") (let ((pg (make-package "G")) (ph (make-package "H")) sym1 sym2 sym3 sym4 a1 a2 a3 a4) (prog1 (and (export (intern "X" pg) pg) (export (intern "Y" ph) ph) (use-package pg ph) (use-package ph pg) (progn (multiple-value-setq (sym1 a1) (find-symbol "X" pg)) (multiple-value-setq (sym2 a2) (find-symbol "Y" ph)) (multiple-value-setq (sym3 a3) (find-symbol "Y" pg)) (multiple-value-setq (sym4 a4) (find-symbol "X" ph)) (and (eqt a1 :external) (eqt a2 :external) (eqt a3 :inherited) (eqt a4 :inherited) (eqt sym1 sym4) (eqt sym2 sym3) (eqt (symbol-package sym1) pg) (eqt (symbol-package sym2) ph) (unuse-package pg ph) (unuse-package ph pg)))) (safely-delete-package pg) (safely-delete-package ph)))) t) ;; Also: need to check that *PACKAGE* is used as a default (deftest use-package.error.1 (classify-error (use-package)) program-error) (deftest use-package.error.2 (progn (safely-delete-package "UPE2A") (safely-delete-package "UPE2") (make-package "UPE2" :use ()) (make-package "UPE2A" :use ()) (classify-error (use-package "UPE2" "UPE2A" nil))) program-error) gcl/ansi-tests/packages-16.lsp000066400000000000000000000416701242227143400164500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:09:18 1998 ;;;; Contains: Package test code, part 16 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; defpackage ;; Test basic defpackage call, with no options ;; The use-list is implementation dependent, so ;; we don't examine it here. ;; Try several ways of specifying the package name. (deftest defpackage.1 (loop for n in '("H" #:|H| #\H) count (not (progn (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage ,n))))) (and (packagep p) (equal (package-name p) "H") ;; (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (null (documentation p t)) ))))) 0) ;; Test :nicknames option ;; Do not check use-list, because it is implementation dependent ;; Try several ways of specifying a nickname. (deftest defpackage.2 (loop for n in '("I" #:|I| #\I) count (not (ignore-errors (progn (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:nicknames ,n "J")))))) (and (packagep p) (equal (package-name p) "H") ;; (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (sort (copy-list (package-nicknames p)) #'string<) '("I" "J")) (equal (package-shadowing-symbols p) nil) (null (documentation p t)) )))))) 0) ;; Test defpackage with documentation option ;; Do not check use-list, because it is implementation dependent (deftest defpackage.3 (progn (safely-delete-package "H") (ignore-errors (let ((p (eval '(defpackage "H" (:documentation "This is a doc string"))))) (and (packagep p) (equal (package-name p) "H") ;; (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) ;; The spec says implementations are free to discard ;; documentations, so this next form was wrong. ;; Instead, we'll just computation DOCUMENTATION ;; and throw away the value. ;; (equal (documentation p t) "This is a doc string") (progn (documentation p t) t) )))) t) ;; Check use argument ;; Try several ways of specifying the package to be used (deftest defpackage.4 (loop for n in '("A" :|A| #\A) count (not (ignore-errors (progn (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:use ,n)))))) (and (packagep p) (equal (package-name p) "H") (equal (package-use-list p) (list (find-package "A"))) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (eql (num-symbols-in-package p) (num-external-symbols-in-package "A")) (equal (documentation p t) nil) )))))) 0) ;; Test defpackage shadow option, and null use (deftest defpackage.5 (progn (safely-delete-package "H") (ignore-errors (let ((p (ignore-errors (eval `(defpackage "H" (:use) (:shadow "foo")))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (eql (num-symbols-in-package p) 1) (multiple-value-bind* (sym access) (find-symbol "foo" p) (and (eqt access :internal) (equal (symbol-name sym) "foo") (equal (symbol-package sym) p) (equal (package-shadowing-symbols p) (list sym)))) (equal (documentation p t) nil) ))))) (t t t t t t t t)) ;; Test defpackage shadow and null use, with several ways ;; of specifying the name of the shadowed symbol (deftest defpackage.6 (loop for s in '(:|f| #\f) collect (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:use) (:shadow ,s)))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (eql (num-symbols-in-package p) 1) (multiple-value-bind* (sym access) (find-symbol "f" p) (and (eqt access :internal) (equal (symbol-name sym) "f") (equal (symbol-package sym) p) (equal (package-shadowing-symbols p) (list sym)))) (equal (documentation p t) nil) ))))) ((t t t t t t t t) (t t t t t t t t))) ;; Testing defpackage with shadowing-import-from. ;; Test several ways of specifying the symbol name (deftest defpackage.7 (progn (safely-delete-package "H") (safely-delete-package "G") (let ((pg (make-package "G" :use nil))) ;; Populate package G with several symbols (export (intern "A" pg) pg) (export (intern "foo" pg) pg) (intern "bar" pg) ;; Do test with several ways of specifying the ;; shadowing-imported symbol (loop for n in '("A" :|A| #\A) collect (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:use) (:shadowing-import-from "G" ,n)))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (eql (num-symbols-in-package p) 1) (multiple-value-bind* (sym access) (find-symbol "A" p) (and (eqt access :internal) (equal (symbol-name sym) "A") (equal (symbol-package sym) pg) (equal (package-shadowing-symbols p) (list sym)))) (equal (documentation p t) nil) ))))))) ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t))) ;; Test import-from option ;; Test for each way of specifying the imported symbol name, ;; and for each way of specifying the package name from which ;; the symbol is imported (deftest defpackage.8 (progn (safely-delete-package "H") (safely-delete-package "G") (let ((pg (eval '(defpackage "G" (:use) (:intern "A" "B" "C"))))) (loop for pn in '("G" #:|G| #\G) collect (loop for n in '("B" #:|B| #\B) collect (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:use) (:import-from ,pn ,n "A")))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (eql (num-symbols-in-package p) 2) (multiple-value-bind* (sym access) (find-symbol "A" p) (and (eqt access :internal) (equal (symbol-name sym) "A") (equal (symbol-package sym) pg))) (multiple-value-bind* (sym access) (find-symbol "B" p) (and (eqt access :internal) (equal (symbol-name sym) "B") (equal (symbol-package sym) pg))) (equal (documentation p t) nil) )))))))) (((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)) ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)) ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)))) ;; Test defpackage with export option (deftest defpackage.9 (progn (loop for n in '("Z" #:|Z| #\Z) collect (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:export "Q" ,n "R") (:use)))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (eql (num-symbols-in-package p) 3) (loop for s in '("Q" "Z" "R") do (unless (multiple-value-bind* (sym access) (find-symbol s p) (and (eqt access :external) (equal (symbol-name sym) s) (equal (symbol-package sym) p))) (return nil)) finally (return t)) )))))) ((t t t t t t t t)(t t t t t t t t)(t t t t t t t t))) ;; Test defpackage with the intern option (deftest defpackage.10 (progn (loop for n in '("Z" #:|Z| #\Z) collect (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:intern "Q" ,n "R") (:use)))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (eql (num-symbols-in-package p) 3) (loop for s in '("Q" "Z" "R") do (unless (multiple-value-bind* (sym access) (find-symbol s p) (and (eqt access :internal) (equal (symbol-name sym) s) (equal (symbol-package sym) p))) (return nil)) finally (return t)) )))))) ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t))) ;; Test defpackage with size (deftest defpackage.11 (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval '(defpackage "H" (:use) (:size 0)))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (zerop (num-symbols-in-package p)))))) (t t t t t t t)) (deftest defpackage.12 (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval '(defpackage "H" (:use) (:size 10000)))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (zerop (num-symbols-in-package p)))))) (t t t t t t t)) ;; defpackage error handling ;; Repeated size field should cause a program-error (deftest defpackage.13 (progn (safely-delete-package "H") (classify-error (eval '(defpackage "H" (:use) (:size 10) (:size 20))))) program-error) ;; Repeated documentation field should cause a program-error (deftest defpackage.14 (progn (safely-delete-package "H") (classify-error (eval '(defpackage "H" (:use) (:documentation "foo") (:documentation "bar"))))) program-error) ;; When a nickname refers to an existing package or nickname, ;; signal a package-error (deftest defpackage.15 (progn (safely-delete-package "H") (classify-error (eval '(defpackage "H" (:use) (:nicknames "A"))))) package-error) (deftest defpackage.16 (progn (safely-delete-package "H") (classify-error (eval '(defpackage "H" (:use) (:nicknames "Q"))))) package-error) ;; Names in :shadow, :shadowing-import-from, :import-from, and :intern ;; must be disjoint, or a package-error is signalled. ;; :shadow and :shadowing-import-from (deftest defpackage.17 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (classify-error (eval '(defpackage "H" (:use) (:shadow "A") (:shadowing-import-from "G" "A"))))) program-error) ;; :shadow and :import-from (deftest defpackage.18 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (classify-error (eval '(defpackage "H" (:use) (:shadow "A") (:import-from "G" "A"))))) program-error) ;; :shadow and :intern (deftest defpackage.19 (progn (safely-delete-package "H") (classify-error (eval '(defpackage "H" (:use) (:shadow "A") (:intern "A"))))) program-error) ;; :shadowing-import-from and :import-from (deftest defpackage.20 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (classify-error (eval '(defpackage "H" (:use) (:shadowing-import-from "G" "A") (:import-from "G" "A"))))) program-error) ;; :shadowing-import-from and :intern (deftest defpackage.21 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (classify-error (eval '(defpackage "H" (:use) (:shadowing-import-from "G" "A") (:intern "A"))))) program-error) ;; :import-from and :intern (deftest defpackage.22 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (classify-error (eval '(defpackage "H" (:use) (:import-from "G" "A") (:intern "A"))))) program-error) ;; Names given to :export and :intern must be disjoint, ;; otherwise signal a program-error (deftest defpackage.23 (progn (safely-delete-package "H") (classify-error (eval '(defpackage "H" (:use) (:export "A") (:intern "A"))))) program-error) ;; :shadowing-import-from signals a correctable package-error ;; if the symbol is not accessible in the named package (deftest defpackage.24 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use))) (handle-non-abort-restart (eval '(defpackage "H" (:shadowing-import-from "G" "NOT-THERE"))))) success) ;; :import-from signals a correctable package-error if a symbol with ;; the indicated name is not accessible in the package indicated (deftest defpackage.25 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use))) (handle-non-abort-restart (eval '(defpackage "H" (:import-from "G" "NOT-THERE"))))) success) ;; A big test that combines all the options to defpackage (deftest defpackage.26 (ignore-errors (flet ((%do-it% (args) (safely-delete-package "H") (safely-delete-package "G1") (safely-delete-package "G2") (safely-delete-package "G3") (let ((pg1 (progn (format t "Making G1...~%") (eval '(defpackage "G1" (:use) (:export "A" "B" "C") (:intern "D" "E" "F"))))) (pg2 (progn (format t "Making G2...~%") (eval '(defpackage "G2" (:use) (:export "A" "D" "G") (:intern "E" "H" "I"))))) (pg3 (progn (format t "Making G3...~%") (eval '(defpackage "G3" (:use) (:export "J" "K" "L") (:intern "M" "N" "O")))))) (let ((p (eval (list* 'defpackage "H" (copy-tree args))))) (prog () (unless (packagep p) (return 1)) (unless (equal (package-name p) "H") (return 2)) (unless (equal (package-name pg1) "G1") (return 3)) (unless (equal (package-name pg2) "G2") (return 4)) (unless (equal (package-name pg3) "G3") (return 5)) (unless (equal (sort (copy-list (package-nicknames p)) #'string<) '("H1" "H2")) (return 6)) (unless (or (equal (package-use-list p) (list pg1 pg2)) (equal (package-use-list p) (list pg2 pg1))) (return 7)) (unless (equal (package-used-by-list pg1) (list p)) (return 8)) (unless (equal (package-used-by-list pg2) (list p)) (return 9)) (when (package-used-by-list pg3) (return 10)) (unless (equal (sort (mapcar #'symbol-name (package-shadowing-symbols p)) #'string<) '("A" "B")) (return 10)) (let ((num 11)) (unless (every #'(lambda (str acc pkg) (multiple-value-bind* (sym access) (find-symbol str p) (or (and (or (not acc) (equal (symbol-name sym) str)) (or (not acc) (equal (symbol-package sym) pkg)) (equal access acc) (incf num)) (progn (format t "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%" str acc pkg sym access) nil)))) (list "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O") (list :internal :internal :external :inherited nil nil :inherited :internal nil nil nil :external nil nil :internal) (list pg2 p pg1 pg2 nil nil pg2 p nil nil nil pg3 nil nil pg3)) (return num))) (return 'success)))))) (let ((args '((:nicknames "H1" "H2") (:use "G1" "G2") (:shadow "B") (:shadowing-import-from "G2" "A") (:import-from "G3" "L" "O") (:intern "D" "H") (:export "L" "C") (:size 20) (:documentation "A test package")))) (list (%do-it% args) (%do-it% (reverse args)))))) (success success)) gcl/ansi-tests/packages-17.lsp000066400000000000000000000062131242227143400164430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 19:20:29 1998 ;;;; Contains: Package test code, part 17 (in-package :cl-test) (declaim (optimize (safety 3))) (deftest do-symbols.1 (equalt (remove-duplicates (sort-symbols (let ((all nil)) (do-symbols (x "B" all) (push x all))))) (list (find-symbol "BAR" "B") (find-symbol "FOO" "A"))) t) ;; ;; Test up some test packages ;; (defun collect-symbols (pkg) (remove-duplicates (sort-symbols (let ((all nil)) (do-symbols (x pkg all) (push x all)))))) (defun collect-external-symbols (pkg) (remove-duplicates (sort-symbols (let ((all nil)) (do-external-symbols (x pkg all) (push x all)))))) (deftest do-symbols.2 (collect-symbols "DS1") (DS1:A DS1:B DS1::C DS1::D)) (deftest do-symbols.3 (collect-symbols "DS2") (DS2:A DS2::E DS2::F DS2:G DS2:H)) (deftest do-symbols.4 (collect-symbols "DS3") (DS1:A DS3:B DS2:G DS2:H DS3:I DS3:J DS3:K DS3::L DS3::M)) (deftest do-symbols.5 (remove-duplicates (collect-symbols "DS4") :test #'(lambda (x y) (and (eqt x y) (not (eqt x 'DS4::B))))) (DS1:A DS1:B DS2::F DS3:G DS3:I DS3:J DS3:K DS4::X DS4::Y DS4::Z)) (deftest do-external-symbols.1 (collect-external-symbols "DS1") (DS1:A DS1:B)) (deftest do-external-symbols.2 (collect-external-symbols "DS2") (DS2:A DS2:G DS2:H)) (deftest do-external-symbols.3 (collect-external-symbols "DS3") (DS1:A DS3:B DS2:G DS3:I DS3:J DS3:K)) (deftest do-external-symbols.4 (collect-external-symbols "DS4") ()) (deftest do-external-symbols.5 (equalt (collect-external-symbols "KEYWORD") (collect-symbols "KEYWORD")) t) ;; Test that do-symbols, do-external-symbols work without ;; a return value (and that the default return value is nil) (deftest do-symbols.6 (do-symbols (s "DS1") (declare (ignore s)) t) nil) (deftest do-external-symbols.6 (do-external-symbols (s "DS1") (declare (ignore s)) t) nil) ;; Test that do-symbols, do-external-symbols work without ;; a package being specified (deftest do-symbols.7 (let ((x nil) (*package* (find-package "DS1"))) (declare (special *package*)) (list (do-symbols (s) (push s x)) (sort-symbols x))) (nil (DS1:A DS1:B DS1::C DS1::D))) (deftest do-external-symbols.7 (let ((x nil) (*package* (find-package "DS1"))) (declare (special *package*)) (list (do-external-symbols (s) (push s x)) (sort-symbols x))) (nil (DS1:A DS1:B))) ;; Test that the tags work in the tagbody, ;; and that multiple statements work (deftest do-symbols.8 (handler-case (let ((x nil)) (list (do-symbols (s "DS1") (when (equalt (symbol-name s) "C") (go bar)) (push s x) (go foo) bar (push t x) foo) (sort-symbols x))) (error (c) c)) (NIL (DS1:A DS1:B DS1::D T))) (deftest do-external-symbols.8 (handler-case (let ((x nil)) (list (do-external-symbols (s "DS1") (when (equalt (symbol-name s) "A") (go bar)) (push s x) (go foo) bar (push t x) foo) (sort-symbols x))) (error (c) c)) (NIL (DS1:B T))) gcl/ansi-tests/packages-18.lsp000066400000000000000000000044721242227143400164510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:07:31 1998 ;;;; Contains: Package test code, part 18 (in-package :cl-test) (declaim (optimize (safety 3))) (declaim (special *universe*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; packagep, typep * 'package (deftest packagep.1 (loop for x in *universe* count (unless (eqt (not (packagep x)) (not (typep x 'package))) (format t "(packagep ~S) = ~S, (typep x 'package) = ~S~%" x (packagep x) x (typep x 'package)) t)) 0) ;;; *package* is always a package (deftest packagep.2 (not-mv (packagep *package*)) nil) (deftest packagep.error.1 (classify-error (packagep)) program-error) (deftest packagep.error.2 (classify-error (packagep nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-error (deftest package-error.1 (not (typep (make-condition 'package-error :package "CL") 'package-error)) nil) (deftest package-error.2 (not (typep (make-condition 'package-error :package (find-package "CL")) 'package-error)) nil) (deftest package-error.3 (subtypep* 'package-error 'error) t t) (deftest package-error.4 (not (typep (make-condition 'package-error :package (find-package '#:|CL|)) 'package-error)) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-error-package (deftest package-error-package.1 (eqt (find-package (package-error-package (make-condition 'package-error :package "CL"))) (find-package "CL")) t) (deftest package-error-package.2 (eqt (find-package (package-error-package (make-condition 'package-error :package (find-package "CL")))) (find-package "CL")) t) (deftest package-error-package.3 (eqt (find-package (package-error-package (make-condition 'package-error :package '#:|CL|))) (find-package "CL")) t) (deftest package-error-package.4 (eqt (find-package (package-error-package (make-condition 'package-error :package #\A))) (find-package "A")) t) (deftest package-error-package.error.1 (classify-error (package-error-package)) program-error) (deftest package-error-package.error.2 (classify-error (package-error-package (make-condition 'package-error :package #\A) nil)) program-error) gcl/ansi-tests/packages-19.lsp000066400000000000000000000027251242227143400164510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 5 17:22:49 1998 ;;;; Contains: Packages test code, part 19. Tests of the keyword package. ;;;; See also cl-symbols.lsp (for keywordp test cases) (in-package :cl-test) (declaim (optimize (safety 3))) ;; Check that each keyword satisfies keywordp (deftest keyword.1 (do-symbols (s "KEYWORD" t) (unless (keywordp s) (return (list s nil)))) t) ;; Every keyword is external (deftest keyword.2 (do-symbols (s "KEYWORD" t) (multiple-value-bind (s2 access) (find-symbol (symbol-name s) "KEYWORD") (unless (and (eqt s s2) (eqt access :external)) (return (list s2 access))))) t) ;; Every keyword evaluates to itself (deftest keyword.3 (do-symbols (s "KEYWORD" t) (unless (eqt s (eval s)) (return (list s (eval s))))) t) ;;; Other error tests (deftest package-shadowing-symbols.error.1 (classify-error (package-shadowing-symbols)) program-error) (deftest package-shadowing-symbols.error.2 (classify-error (package-shadowing-symbols "CL" nil)) program-error) (deftest package-use-list.error.1 (classify-error (package-use-list)) program-error) (deftest package-use-list.error.2 (classify-error (package-use-list "CL" nil)) program-error) (deftest package-used-by-list.error.1 (classify-error (package-used-by-list)) program-error) (deftest package-used-by-list.error.2 (classify-error (package-used-by-list "CL" nil)) program-error) gcl/ansi-tests/packages.lsp000066400000000000000000000012111242227143400162070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 6 00:32:56 2002 ;;;; Contains: Loader for files containing package tests (load "packages-00.lsp") (load "packages-01.lsp") (load "packages-02.lsp") (load "packages-03.lsp") (load "packages-04.lsp") (load "packages-05.lsp") (load "packages-06.lsp") (load "packages-07.lsp") (load "packages-08.lsp") (load "packages-09.lsp") (load "packages-10.lsp") (load "packages-11.lsp") (load "packages-12.lsp") (load "packages-13.lsp") (load "packages-14.lsp") (load "packages-15.lsp") (load "packages-16.lsp") (load "packages-17.lsp") (load "packages-18.lsp") (load "packages-19.lsp") gcl/ansi-tests/places.lsp000066400000000000000000000225531242227143400157140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 7 19:20:17 2002 ;;;; Contains: Tests of various kinds of places (section 5.1) (in-package :cl-test) ;;; Section 5.1.1.1 (deftest setf-order (let ((x (vector nil nil nil nil)) (i 0)) (setf (aref x (incf i)) (incf i)) (values x i)) #(nil 2 nil nil) 2) (deftest setf-order.2 (let ((x (vector nil nil nil nil)) (i 0)) (setf (aref x (incf i)) (incf i) (aref x (incf i)) (incf i 10)) (values x i)) #(nil 2 nil 13) 13) (deftest push-order (let ((x (vector nil nil nil nil)) (y (vector 'a 'b 'c 'd)) (i 1)) (push (aref y (incf i)) (aref x (incf i))) (values x y i)) #(nil nil nil (c)) #(a b c d) 3) (deftest pushnew-order (let ((x (vector nil nil nil nil)) (y (vector 'a 'b 'c 'd)) (i 1)) (pushnew (aref y (incf i)) (aref x (incf i))) (values x y i)) #(nil nil nil (c)) #(a b c d) 3) (deftest pushnew-order.2 (let ((x (vector nil nil nil nil nil)) (y (vector 'a 'b 'c 'd 'e)) (i 1)) (pushnew (aref y (incf i)) (aref x (incf i)) :test (progn (incf i) #'eql)) (values x y i)) #(nil nil nil (c) nil) #(a b c d e) 4) (deftest remf-order (let ((x (copy-seq #(nil :a :b))) (pa (vector (list :a 1) (list :b 2) (list :c 3) (list :d 4))) (i 0)) (values (not (remf (aref pa (incf i)) (aref x (incf i)))) pa)) nil #((:a 1) nil (:c 3) (:d 4))) (deftest incf-order (let ((x (copy-seq #(0 0 0 0 0))) (i 1)) (values (incf (aref x (incf i)) (incf i)) x i)) 3 #(0 0 3 0 0) 3) (deftest decf-order (let ((x (copy-seq #(0 0 0 0 0))) (i 1)) (values (decf (aref x (incf i)) (incf i)) x i)) -3 #(0 0 -3 0 0) 3) (deftest shiftf-order.1 (let ((x (vector 'a 'b 'c 'd 'e)) (i 2)) (values (shiftf (aref x (incf i)) (incf i)) x i)) d #(a b c 4 e) 4) (deftest shiftf-order.2 (let ((x (vector 'a 'b 'c 'd 'e 'f 'g 'h)) (i 2)) (values (shiftf (aref x (incf i)) (aref x (incf i)) (incf i)) x i)) d #(a b c e 5 f g h) 5) (deftest rotatef-order.1 (let ((x (vector 'a 'b 'c 'd 'e 'f)) (i 2)) (values (rotatef (aref x (incf i)) (aref x (incf i))) x i)) nil #(a b c e d f) 4) (deftest rotatef-order.2 (let ((x (vector 'a 'b 'c 'd 'e 'f)) (i 2)) (values (rotatef (aref x (incf i)) (aref x (incf i)) (aref x (incf i))) x i)) nil #(a b c e f d) 5) (deftest psetf-order (let ((x (vector nil nil nil nil)) (i 0)) (psetf (aref x (incf i)) (incf i)) (values x i)) #(nil 2 nil nil) 2) (deftest psetf-order.2 (let ((x (vector nil nil nil nil)) (i 0)) (psetf (aref x (incf i)) (incf i) (aref x (incf i)) (incf i 10)) (values x i)) #(nil 2 nil 13) 13) (deftest pop-order (let ((x (vector '(a b) '(c d) '(e f))) (i 0)) (values (pop (aref x (incf i))) x i)) c #((a b) (d) (e f)) 1) ;;; Section 5.1.2.1 (deftest setf-var (let ((x nil)) (setf x 'a) x) a) ;;; Section 5.1.2.2 ;;; See SETF forms at various accessor functions ;;; Section 5.1.2.3 (deftest setf-values.1 (let ((x nil) (y nil) (z nil)) (setf (values x y z) (values 1 2 3))) 1 2 3) (deftest setf-values.2 (let ((x nil) (y nil) (z nil)) (setf (values x y z) (values 1 2 3)) (values z y x)) 3 2 1) (deftest setf-values.3 (let ((x nil) (y nil) (z nil)) (setf (values x x x) (values 1 2 3)) x) 3) ;;; Test that the subplaces of a VALUES place can be ;;; complex, and that the various places' subforms are ;;; evaluated in the correct (left-to-right) order. (deftest setf-values.4 (let ((x (list 'a 'b))) (setf (values (car x) (cadr x)) (values 1 2)) x) (1 2)) (deftest setf-values.5 (let ((a (vector nil nil)) (i 0) x y z) (setf (values (aref a (progn (setf x (incf i)) 0)) (aref a (progn (setf y (incf i)) 1))) (progn (setf z (incf i)) (values 'foo 'bar))) (values a i x y z)) #(foo bar) 3 1 2 3) (deftest setf-values.6 (setf (values) (values))) ;;; Section 5.1.2.4 (deftest setf-the.1 (let ((x 1)) (setf (the integer x) 2) x) 2) (deftest setf-the.2 (let ((x (list 'a))) (values (setf (the symbol (car x)) 'b) x)) b (b)) ;;; Section 5.1.2.5 (deftest setf-apply.1 (let ((x (vector 0 1 2 3 4 5))) (setf (apply #'aref x '(0)) 10) x) #(10 1 2 3 4 5)) (deftest setf-apply.2 (let ((a (make-array '(2 2) :initial-contents '((0 0)(0 0))))) (setf (apply #'aref a 1 1 nil) 'a) (equalp a (make-array '(2 2) :initial-contents '((0 0)(0 a))))) t) (deftest setf-apply.3 (let ((bv (copy-seq #*0000000000))) (setf (apply #'bit bv 4 nil) 1) bv) #*0000100000) (deftest setf-apply.4 (let ((bv (copy-seq #*0000000000))) (setf (apply #'sbit bv 4 nil) 1) bv) #*0000100000) ;;; Section 5.1.2.6 (defun accessor-5-1-2-6-update-fn (x y) (setf (car x) y) y) (defsetf accessor-5-1-2-6 accessor-5-1-2-6-update-fn) (deftest setf-expander.1 (let ((x (list 1))) (values (setf (accessor-5-1-2-6 x) 2) (1+ (car x)))) 2 3) ;;; Section 5.1.2.7 (defmacro accessor-5-1-2-7 (x) `(car ,x)) (deftest setf-macro.1 (let ((x (list 1))) (values (setf (accessor-5-1-2-7 x) 2) (1+ (car x)))) 2 3) (defun accessor-5-1-2-7a-update-fn (x y) (declare (special *x*)) (setf (car x) y) (setf *x* 'boo) y) (defmacro accessor-5-1-2-7a (x) `(car ,x)) (defsetf accessor-5-1-2-7a accessor-5-1-2-7a-update-fn) ;; Test that the defsetf override the macro expansion (deftest setf-macro.2 (let ((x (list 1)) (*x* nil)) (declare (special *x*)) (values (setf (accessor-5-1-2-7a x) 2) *x* (1+ (car x)))) 2 boo 3) (defmacro accessor-5-1-2-7b (x) `(accessor-5-1-2-7 ,x)) ;; Test that the macroexpansion occurs more than once (deftest setf-macro.3 (let ((x (list 1))) (values (setf (accessor-5-1-2-7b x) 2) (1+ (car x)))) 2 3) ;; Macroexpansion from a macrolet (deftest setf-macro.4 (macrolet ((%m (y) `(car ,y))) (let ((x (list 1))) (values (setf (%m x) 2) (1+ (car x))))) 2 3) ;;; section 5.1.2.8 -- symbol macros (deftest setf-symbol-macro.1 (symbol-macrolet ((x y)) (let ((y nil)) (values (setf x 1) x y))) 1 1 1) ;;; Symbol macros in SETQs are treated as if the form were a SETF (deftest setf-symbol-macro.2 (symbol-macrolet ((x y)) (let ((y nil)) (values (setq x 1) x y))) 1 1 1) ;;; Tests that, being treated like SETF, this causes multiple values ;;; to be assigned to (values y z) (deftest setf-symbol-macro.3 (symbol-macrolet ((x (values y z))) (let ((y nil) (z nil)) (values (setq x (values 1 2)) x y z))) 1 1 1 2) (deftest setq.1 (setq) nil) (deftest setq.2 (let ((x 0) (y 0)) (values (setq x 1 y 2) x y)) 2 1 2) (deftest setq.3 (let ((x 0) (y 0)) (values (setq x (values 1 3) y (values 2 4)) x y)) 2 1 2) (deftest setq.4 (let (x) (setq x (values 1 2))) 1) (deftest setf.1 (setf) nil) (deftest setf.2 (let ((x 0) (y 0)) (values (setf x 1 y 2) x y)) 2 1 2) (deftest setf.3 (let ((x 0) (y 0)) (values (setf x (values 1 3) y (values 2 4)) x y)) 2 1 2) (deftest setf.4 (let (x) (setf x (values 1 2))) 1) ;;; Tests of PSETQ (deftest psetq.1 (psetq) nil) (deftest psetq.2 (let ((x 0)) (values (psetq x 1) x)) nil 1) (deftest psetq.3 (let ((x 0) (y 1)) (values (psetq x y y x) x y)) nil 1 0) (deftest psetq.4 (let ((x 0)) (values (symbol-macrolet ((x y)) (let ((y 1)) (psetq x 2) y)) x)) 2 0) (deftest psetq.5 (let ((w (list nil))) (values (symbol-macrolet ((x (car w))) (psetq x 2)) w)) nil (2)) (deftest psetq.6 (let ((c 0) x y) (psetq x (incf c) y (incf c)) (values c x y)) 2 1 2) ;;; The next test is a PSETQ that is equivalent to a PSETF ;;; See PSETF.7 for comments related to this test. (deftest psetq.7 (symbol-macrolet ((x (aref a (incf i))) (y (aref a (incf i)))) (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) (i 0)) (psetq x (aref a (incf i)) y (aref a (incf i))) (values a i))) #(0 2 2 4 4 5 6 7 8 9) 4) ;;; Tests of PSETF (deftest psetf.1 (psetf) nil) (deftest psetf.2 (let ((x 0)) (values (psetf x 1) x)) nil 1) (deftest psetf.3 (let ((x 0) (y 1)) (values (psetf x y y x) x y)) nil 1 0) (deftest psetf.4 (let ((x 0)) (values (symbol-macrolet ((x y)) (let ((y 1)) (psetf x 2) y)) x)) 2 0) (deftest psetf.5 (let ((w (list nil))) (values (symbol-macrolet ((x (car w))) (psetf x 2)) w)) nil (2)) (deftest psetf.6 (let ((c 0) x y) (psetf x (incf c) y (incf c)) (values c x y)) 2 1 2) ;;; According to the standard, the forms to be assigned and ;;; the subforms in the places to be assigned to are evaluated ;;; from left to right. Therefore, PSETF.7 and PSETF.8 should ;;; do the same thing to A as PSETF.9 does. ;;; (See the page for PSETF) (deftest psetf.7 (symbol-macrolet ((x (aref a (incf i))) (y (aref a (incf i)))) (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) (i 0)) (psetf x (aref a (incf i)) y (aref a (incf i))) (values a i))) #(0 2 2 4 4 5 6 7 8 9) 4) (deftest psetf.8 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) (i 0)) (psetf (aref a (incf i)) (aref a (incf i)) (aref a (incf i)) (aref a (incf i))) (values a i)) #(0 2 2 4 4 5 6 7 8 9) 4) (deftest psetf.9 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))) (psetf (aref a 1) (aref a 2) (aref a 3) (aref a 4)) a) #(0 2 2 4 4 5 6 7 8 9)) gcl/ansi-tests/position-if-not.lsp000066400000000000000000000325231242227143400175010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 24 07:10:05 2002 ;;;; Contains: Tests for POSITION-IF-NOT-NOT (in-package :cl-test) (deftest position-if-not-list.1 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-not-list.2 (position-if-not 'oddp '(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-not-list.3 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start 4) 5) (deftest position-if-not-list.4 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :from-end t) 7) (deftest position-if-not-list.5 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :from-end nil) 3) (deftest position-if-not-list.6 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start 4 :from-end t) 7) (deftest position-if-not-list.7 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :end nil) 3) (deftest position-if-not-list.8 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :end 3) nil) (deftest position-if-not-list.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-list.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-list.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j :key '1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-list.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j :key #'1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) ;;; Vector tests (deftest position-if-not-vector.1 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-not-vector.2 (position-if-not 'oddp #(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-not-vector.3 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start 4) 5) (deftest position-if-not-vector.4 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :from-end t) 7) (deftest position-if-not-vector.5 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :from-end nil) 3) (deftest position-if-not-vector.6 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start 4 :from-end t) 7) (deftest position-if-not-vector.7 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :end nil) 3) (deftest position-if-not-vector.8 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :end 3) nil) (deftest position-if-not-vector.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-vector.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-vector.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j :key '1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-vector.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j :key #'1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-vector.13 (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 a b c d e) :fill-pointer 5))) (values (position-if-not #'numberp a) (position-if-not #'symbolp a) (position-if-not #'numberp a :from-end t) (position-if-not #'symbolp a :from-end t))) nil 0 nil 4) ;;; Bit vector tests (deftest position-if-not-bit-vector.1 (position-if-not #'oddp #*111010101) 3) (deftest position-if-not-bit-vector.2 (position-if-not 'oddp #*111010101) 3) (deftest position-if-not-bit-vector.3 (position-if-not #'oddp #*111010101 :start 4) 5) (deftest position-if-not-bit-vector.4 (position-if-not #'oddp #*111010101 :from-end t) 7) (deftest position-if-not-bit-vector.5 (position-if-not #'oddp #*111010101 :from-end nil) 3) (deftest position-if-not-bit-vector.6 (position-if-not #'oddp #*111010101 :start 4 :from-end t) 7) (deftest position-if-not-bit-vector.7 (position-if-not #'oddp #*111010101 :end nil) 3) (deftest position-if-not-bit-vector.8 (position-if-not #'oddp #*111010101 :end 3) nil) (deftest position-if-not-bit-vector.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'oddp #*111010101 :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-bit-vector.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'oddp #*111010101 :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-bit-vector.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evenp #*111010101 :start i :end j :key #'1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-bit-vector.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evenp #*111010101 :start i :end j :key '1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-bit-vector.13 (let ((a (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) :fill-pointer 5 :element-type 'bit))) (values (position-if-not #'zerop a) (position-if-not (complement #'zerop) a) (position-if-not #'zerop a :from-end t) (position-if-not (complement #'zerop) a :from-end t))) 0 nil 4 nil) ;;; string tests (deftest position-if-not-string.1 (position-if-not #'odddigitp "131432189") 3) (deftest position-if-not-string.2 (position-if-not 'odddigitp "131432189") 3) (deftest position-if-not-string.3 (position-if-not #'odddigitp "131432189" :start 4) 5) (deftest position-if-not-string.4 (position-if-not #'odddigitp "131432189" :from-end t) 7) (deftest position-if-not-string.5 (position-if-not #'odddigitp "131432189" :from-end nil) 3) (deftest position-if-not-string.6 (position-if-not #'odddigitp "131432189" :start 4 :from-end t) 7) (deftest position-if-not-string.7 (position-if-not #'odddigitp "131432189" :end nil) 3) (deftest position-if-not-string.8 (position-if-not #'odddigitp "131432189" :end 3) nil) (deftest position-if-not-string.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'odddigitp "131432189" :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-string.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'odddigitp "131432189" :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-string.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evendigitp "131432183" :start i :end j :key #'nextdigit))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-string.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evendigitp "131432183" :start i :end j :key 'nextdigit :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-string.13 (let ((a (make-array '(10) :initial-contents "55555aaaaa" :fill-pointer 5 :element-type 'character))) (and (stringp a) (values (position-if-not #'digit-char-p a) (position-if-not (complement #'digit-char-p) a) (position-if-not #'digit-char-p a :from-end t) (position-if-not (complement #'digit-char-p) a :from-end t)))) nil 0 nil 4) (deftest position-if-not.order.1 (let ((i 0) a b c d e f) (values (position-if-not (progn (setf a (incf i)) (complement #'zerop)) (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) :from-end (setf c (incf i)) :start (progn (setf d (incf i)) 1) :end (progn (setf e (incf i)) 6) :key (progn (setf f (incf i)) #'1-)) i a b c d e f)) 4 6 1 2 3 4 5 6) (deftest position-if-not.order.2 (let ((i 0) a b c d e f) (values (position-if-not (progn (setf a (incf i)) (complement #'zerop)) (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) :key (progn (setf c (incf i)) #'1-) :end (progn (setf d (incf i)) 6) :start (progn (setf e (incf i)) 1) :from-end (setf f (incf i))) i a b c d e f)) 4 6 1 2 3 4 5 6) ;;; Keyword tests (deftest position-if-not.allow-other-keys.1 (position-if-not #'zerop '(0 0 3 2 0 1) :allow-other-keys t) 2) (deftest position-if-not.allow-other-keys.2 (position-if-not #'zerop '(0 0 3 2 0 1) :allow-other-keys nil) 2) (deftest position-if-not.allow-other-keys.3 (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t :bad t) 2) (deftest position-if-not.allow-other-keys.4 (position-if-not #'zerop '(0 0 1 2 3 0) :bad t :allow-other-keys t) 2) (deftest position-if-not.allow-other-keys.5 (position-if-not #'zerop '(0 0 1 2 3 0) :bad t :allow-other-keys t :key #'1-) 0) (deftest position-if-not.keywords.6 (position-if-not #'zerop '(0 0 1 2 3 0) :key #'1- :key #'identity) 0) (deftest position-if-not.allow-other-keys.7 (position-if-not #'zerop '(0 0 1 2 3 0) :bad t :allow-other-keys t :allow-other-keys nil) 2) (deftest position-if-not.allow-other-keys.8 (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t :bad t :allow-other-keys nil) 2) (deftest position-if-not.allow-other-keys.9 (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t :allow-other-keys nil :bad t) 2) ;;; Error tests (deftest position-if-not.error.1 (classify-error (position-if-not #'identity 'b)) type-error) (deftest position-if-not.error.2 (classify-error (position-if-not #'identity 10)) type-error) (deftest position-if-not.error.3 (classify-error (position-if-not 'null 1.4)) type-error) (deftest position-if-not.error.4 (classify-error (position-if-not 'identity '(a b c . d))) type-error) (deftest position-if-not.error.5 (classify-error (position-if-not)) program-error) (deftest position-if-not.error.6 (classify-error (position-if-not #'null)) program-error) (deftest position-if-not.error.7 (classify-error (position-if-not #'null nil :key)) program-error) (deftest position-if-not.error.8 (classify-error (position-if-not #'null nil 'bad t)) program-error) (deftest position-if-not.error.9 (classify-error (position-if-not #'null nil 'bad t :allow-other-keys nil)) program-error) (deftest position-if-not.error.10 (classify-error (position-if-not #'null nil 1 2)) program-error) (deftest position-if-not.error.11 (classify-error (locally (position-if-not #'identity 'b) t)) type-error) (deftest position-if-not.error.12 (classify-error (position-if-not #'cons '(a b c d))) program-error) (deftest position-if-not.error.13 (classify-error (position-if-not #'car '(a b c d))) type-error) (deftest position-if-not.error.14 (classify-error (position-if-not #'identity '(a b c d) :key #'cdr)) type-error) (deftest position-if-not.error.15 (classify-error (position-if-not #'identity '(a b c d) :key #'cons)) program-error) gcl/ansi-tests/position-if.lsp000066400000000000000000000311341242227143400167000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Aug 23 22:08:57 2002 ;;;; Contains: Tests for POSITION-IF (in-package :cl-test) (deftest position-if-list.1 (position-if #'evenp '(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-list.2 (position-if 'evenp '(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-list.3 (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start 4) 5) (deftest position-if-list.4 (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :from-end t) 7) (deftest position-if-list.5 (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :from-end nil) 3) (deftest position-if-list.6 (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start 4 :from-end t) 7) (deftest position-if-list.7 (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :end nil) 3) (deftest position-if-list.8 (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :end 3) nil) (deftest position-if-list.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-list.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-list.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j :key '1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-list.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j :key #'1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) ;;; Vector tests (deftest position-if-vector.1 (position-if #'evenp #(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-vector.2 (position-if 'evenp #(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-vector.3 (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start 4) 5) (deftest position-if-vector.4 (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :from-end t) 7) (deftest position-if-vector.5 (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :from-end nil) 3) (deftest position-if-vector.6 (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start 4 :from-end t) 7) (deftest position-if-vector.7 (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :end nil) 3) (deftest position-if-vector.8 (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :end 3) nil) (deftest position-if-vector.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-vector.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-vector.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j :key '1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-vector.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j :key #'1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-vector.13 (let ((a (make-array '(10) :initial-contents '(1 3 1 4 3 1 2 1 8 9) :fill-pointer 5))) (flet ((%f (x) (eql x 1))) (values (position-if #'%f a) (position-if #'%f a :from-end t)))) 0 2) ;;; Bit vector tests (deftest position-if-bit-vector.1 (position-if #'evenp #*111010101) 3) (deftest position-if-bit-vector.2 (position-if 'evenp #*111010101) 3) (deftest position-if-bit-vector.3 (position-if #'evenp #*111010101 :start 4) 5) (deftest position-if-bit-vector.4 (position-if #'evenp #*111010101 :from-end t) 7) (deftest position-if-bit-vector.5 (position-if #'evenp #*111010101 :from-end nil) 3) (deftest position-if-bit-vector.6 (position-if #'evenp #*111010101 :start 4 :from-end t) 7) (deftest position-if-bit-vector.7 (position-if #'evenp #*111010101 :end nil) 3) (deftest position-if-bit-vector.8 (position-if #'evenp #*111010101 :end 3) nil) (deftest position-if-bit-vector.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evenp #*111010101 :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-bit-vector.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evenp #*111010101 :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-bit-vector.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'oddp #*111010101 :start i :end j :key #'1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-bit-vector.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'oddp #*111010101 :start i :end j :key '1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-bit-vector.13 (let ((a (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) :fill-pointer 5 :element-type 'bit))) (values (position-if #'evenp a) (position-if #'evenp a :from-end 'foo) (position-if #'oddp a) (position-if #'oddp a :from-end 'foo))) nil nil 0 4) ;;; string tests (deftest position-if-string.1 (position-if #'evendigitp "131432189") 3) (deftest position-if-string.2 (position-if 'evendigitp "131432189") 3) (deftest position-if-string.3 (position-if #'evendigitp "131432189" :start 4) 5) (deftest position-if-string.4 (position-if #'evendigitp "131432189" :from-end t) 7) (deftest position-if-string.5 (position-if #'evendigitp "131432189" :from-end nil) 3) (deftest position-if-string.6 (position-if #'evendigitp "131432189" :start 4 :from-end t) 7) (deftest position-if-string.7 (position-if #'evendigitp "131432189" :end nil) 3) (deftest position-if-string.8 (position-if #'evendigitp "131432189" :end 3) nil) (deftest position-if-string.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evendigitp "131432189" :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-string.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evendigitp "131432189" :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-string.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'odddigitp "131432189" :start i :end j :key #'nextdigit))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-string.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'odddigitp "131432189" :start i :end j :key 'nextdigit :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-string.13 (flet ((%f (c) (eql c #\0)) (%g (c) (eql c #\1))) (let ((a (make-array '(10) :initial-contents "1111100000" :fill-pointer 5 :element-type 'character))) (values (position-if #'%f a) (position-if #'%f a :from-end 'foo) (position-if #'%g a) (position-if #'%g a :from-end 'foo)))) nil nil 0 4) (deftest position-if.order.1 (let ((i 0) a b c d e f) (values (position-if (progn (setf a (incf i)) #'zerop) (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) :from-end (setf c (incf i)) :start (progn (setf d (incf i)) 1) :end (progn (setf e (incf i)) 6) :key (progn (setf f (incf i)) #'1-)) i a b c d e f)) 4 6 1 2 3 4 5 6) (deftest position-if.order.2 (let ((i 0) a b c d e f) (values (position-if (progn (setf a (incf i)) #'zerop) (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) :key (progn (setf c (incf i)) #'1-) :end (progn (setf d (incf i)) 6) :start (progn (setf e (incf i)) 1) :from-end (setf f (incf i))) i a b c d e f)) 4 6 1 2 3 4 5 6) ;;; Keyword tests (deftest position-if.allow-other-keys.1 (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t) 2) (deftest position-if.allow-other-keys.2 (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys nil) 2) (deftest position-if.allow-other-keys.3 (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t :bad t) 2) (deftest position-if.allow-other-keys.4 (position-if #'zerop '(1 2 0 3 2 1) :bad t :allow-other-keys t) 2) (deftest position-if.allow-other-keys.5 (position-if #'zerop '(1 2 0 3 2 1) :bad t :allow-other-keys t :key #'1-) 0) (deftest position-if.keywords.6 (position-if #'zerop '(1 2 0 3 2 1) :key #'1- :key #'identity) 0) (deftest position-if.allow-other-keys.7 (position-if #'zerop '(1 2 0 3 2 1) :bad t :allow-other-keys t :allow-other-keys nil) 2) (deftest position-if.allow-other-keys.8 (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t :bad t :allow-other-keys nil) 2) (deftest position-if.allow-other-keys.9 (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t :allow-other-keys nil :bad t) 2) ;;; Error tests (deftest position-if.error.1 (classify-error (position-if #'identity 'b)) type-error) (deftest position-if.error.2 (classify-error (position-if #'identity 10)) type-error) (deftest position-if.error.3 (classify-error (position-if 'null 1.4)) type-error) (deftest position-if.error.4 (classify-error (position-if 'null '(a b c . d))) type-error) (deftest position-if.error.5 (classify-error (position-if)) program-error) (deftest position-if.error.6 (classify-error (position-if #'null)) program-error) (deftest position-if.error.7 (classify-error (position-if #'null nil :key)) program-error) (deftest position-if.error.8 (classify-error (position-if #'null nil 'bad t)) program-error) (deftest position-if.error.9 (classify-error (position-if #'null nil 'bad t :allow-other-keys nil)) program-error) (deftest position-if.error.10 (classify-error (position-if #'null nil 1 2)) program-error) (deftest position-if.error.11 (classify-error (locally (position-if #'identity 'b) t)) type-error) (deftest position-if.error.12 (classify-error (position-if #'cons '(a b c d))) program-error) (deftest position-if.error.13 (classify-error (position-if #'car '(a b c d))) type-error) (deftest position-if.error.14 (classify-error (position-if #'identity '(a b c d) :key #'cdr)) type-error) (deftest position-if.error.15 (classify-error (position-if #'identity '(a b c d) :key #'cons)) program-error) gcl/ansi-tests/position.lsp000066400000000000000000000424201242227143400163040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Aug 23 07:49:49 2002 ;;;; Contains: Tests for POSITION (in-package :cl-test) (deftest position-list.1 (position 'c '(a b c d e c a)) 2) (deftest position-list.2 (position 'c '(a b c d e c a) :from-end t) 5) (deftest position-list.3 (loop for i from 0 to 7 collect (position 'c '(a b c d e c a) :start i)) (2 2 2 5 5 5 nil nil)) (deftest position-list.4 (loop for i from 0 to 7 collect (position 'c '(a b c d e c a) :start i :end nil)) (2 2 2 5 5 5 nil nil)) (deftest position-list.5 (loop for i from 7 downto 0 collect (position 'c '(a b c d e c a) :end i)) (2 2 2 2 2 nil nil nil)) (deftest position-list.6 (loop for i from 0 to 7 collect (position 'c '(a b c d e c a) :start i :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-list.7 (loop for i from 0 to 7 collect (position 'c '(a b c d e c a) :start i :end nil :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-list.8 (loop for i from 7 downto 0 collect (position 'c '(a b c d e c a) :end i :from-end t)) (5 5 2 2 2 nil nil nil)) (deftest position-list.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position 'c '(a b c d e c a) :start i :end j))) ((nil nil 2 2 2 2 2) (nil 2 2 2 2 2) (2 2 2 2 2) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-list.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position 'c '(a b c d e c a) :start i :end j :from-end t))) ((nil nil 2 2 2 5 5) (nil 2 2 2 5 5) (2 2 2 5 5) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-list.11 (position 5 '(1 2 3 4 5 6 4 8) :key #'1+) 3) (deftest position-list.12 (position 5 '(1 2 3 4 5 6 4 8) :key '1+) 3) (deftest position-list.13 (position 5 '(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) 6) (deftest position-list.14 (position 'a '(a a b a c e d a f a) :test (complement #'eql)) 2) (deftest position-list.15 (position 'a '(a a b a c e d a f a) :test (complement #'eql) :from-end t) 8) (deftest position-list.16 (position 'a '(a a b a c e d a f a) :test-not #'eql) 2) (deftest position-list.17 (position 'a '(a a b a c e d a f a) :test-not 'eql :from-end t) 8) (deftest position-list.18 (position 'a '(a a b a c e d a f a) :test-not 'eql) 2) (deftest position-list.19 (position 'a '(a a b a c e d a f a) :test-not #'eql :from-end t) 8) (deftest position-list.20 (position 'a '(a a b a c e d a f a) :test-not #'eql) 2) (deftest position-list.21 (position 'a '(a a b a c e d a f a) :test #'eql :start 2) 3) (deftest position-list.22 (position 'a '(a a b a c e d a f a) :test #'eql :start 2 :end nil) 3) (deftest position-list.23 (position 'a '(a a b a c e d a f a) :test-not #'eql :start 0 :end 5) 2) (deftest position-list.24 (position 'a '(a a b a c e d a f a) :test-not #'eql :start 0 :end 5 :from-end t) 4) (deftest position-list.25 (position '(a b) '(a (b a) (a b c) (a b) (d e) f) :test #'equal) 3) (deftest position-list.26 (position 'a '((c) (b a) (a b c) (a b) (d e) f) :key #'car) 2) (deftest position-list.27 (position 'a '((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car :start 3) 4) (deftest position-list.28 (position 'a '((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car :start 2 :from-end t) 4) ;;; Tests on vectors (deftest position-vector.1 (position 'c #(a b c d e c a)) 2) (deftest position-vector.2 (position 'c #(a b c d e c a) :from-end t) 5) (deftest position-vector.3 (loop for i from 0 to 7 collect (position 'c #(a b c d e c a) :start i)) (2 2 2 5 5 5 nil nil)) (deftest position-vector.4 (loop for i from 0 to 7 collect (position 'c #(a b c d e c a) :start i :end nil)) (2 2 2 5 5 5 nil nil)) (deftest position-vector.5 (loop for i from 7 downto 0 collect (position 'c #(a b c d e c a) :end i)) (2 2 2 2 2 nil nil nil)) (deftest position-vector.6 (loop for i from 0 to 7 collect (position 'c #(a b c d e c a) :start i :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-vector.7 (loop for i from 0 to 7 collect (position 'c #(a b c d e c a) :start i :end nil :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-vector.8 (loop for i from 7 downto 0 collect (position 'c #(a b c d e c a) :end i :from-end t)) (5 5 2 2 2 nil nil nil)) (deftest position-vector.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position 'c #(a b c d e c a) :start i :end j))) ((nil nil 2 2 2 2 2) (nil 2 2 2 2 2) (2 2 2 2 2) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-vector.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position 'c #(a b c d e c a) :start i :end j :from-end t))) ((nil nil 2 2 2 5 5) (nil 2 2 2 5 5) (2 2 2 5 5) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-vector.11 (position 5 #(1 2 3 4 5 6 4 8) :key #'1+) 3) (deftest position-vector.12 (position 5 #(1 2 3 4 5 6 4 8) :key '1+) 3) (deftest position-vector.13 (position 5 #(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) 6) (deftest position-vector.14 (position 'a #(a a b a c e d a f a) :test (complement #'eql)) 2) (deftest position-vector.15 (position 'a #(a a b a c e d a f a) :test (complement #'eql) :from-end t) 8) (deftest position-vector.16 (position 'a #(a a b a c e d a f a) :test-not #'eql) 2) (deftest position-vector.17 (position 'a #(a a b a c e d a f a) :test-not 'eql :from-end t) 8) (deftest position-vector.18 (position 'a #(a a b a c e d a f a) :test-not 'eql) 2) (deftest position-vector.19 (position 'a #(a a b a c e d a f a) :test-not #'eql :from-end t) 8) (deftest position-vector.20 (position 'a #(a a b a c e d a f a) :test-not #'eql) 2) (deftest position-vector.21 (position 'a #(a a b a c e d a f a) :test #'eql :start 2) 3) (deftest position-vector.22 (position 'a #(a a b a c e d a f a) :test #'eql :start 2 :end nil) 3) (deftest position-vector.23 (position 'a #(a a b a c e d a f a) :test-not #'eql :start 0 :end 5) 2) (deftest position-vector.24 (position 'a #(a a b a c e d a f a) :test-not #'eql :start 0 :end 5 :from-end t) 4) (deftest position-vector.25 (position '(a b) #(a (b a) (a b c) (a b) (d e) f) :test #'equal) 3) (deftest position-vector.26 (position 'a #((c) (b a) (a b c) (a b) (d e) f) :key #'car) 2) (deftest position-vector.27 (position 'a #((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car :start 3) 4) (deftest position-vector.28 (position 'a #((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car :start 2 :from-end t) 4) (deftest position-vector.29 (position 'a (make-array '(10) :initial-contents '(b b b b b a a a a a) :fill-pointer 5)) nil) (deftest position-vector.30 (position 'a (make-array '(10) :initial-contents '(b b b b a a a a a a) :fill-pointer 5)) 4) (deftest position-vector.31 (position 'a (make-array '(10) :initial-contents '(b a b b a a a a a a) :fill-pointer 5) :from-end t) 4) ;;; tests on bit vectors (deftest position-bit-vector.1 (position 1 #*001001010100) 2) (deftest position-bit-vector.2 (position 1 #*001001010100 :from-end t) 9) (deftest position-bit-vector.3 (loop for i from 0 to 7 collect (position 1 #*0010010 :start i)) (2 2 2 5 5 5 nil nil)) (deftest position-bit-vector.4 (loop for i from 0 to 7 collect (position 1 #*0010010 :start i :end nil)) (2 2 2 5 5 5 nil nil)) (deftest position-bit-vector.5 (loop for i from 7 downto 0 collect (position 1 #*0010010 :end i)) (2 2 2 2 2 nil nil nil)) (deftest position-bit-vector.6 (loop for i from 0 to 7 collect (position 1 #*0010010 :start i :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-bit-vector.7 (loop for i from 0 to 7 collect (position 0 #*1101101 :start i :end nil :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-bit-vector.8 (loop for i from 7 downto 0 collect (position 0 #*1101101 :end i :from-end t)) (5 5 2 2 2 nil nil nil)) (deftest position-bit-vector.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position 1 #*0010010 :start i :end j))) ((nil nil 2 2 2 2 2) (nil 2 2 2 2 2) (2 2 2 2 2) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-bit-vector.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position 1 #*0010010 :start i :end j :from-end t))) ((nil nil 2 2 2 5 5) (nil 2 2 2 5 5) (2 2 2 5 5) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-bit-vector.11 (position 2 #*00010001010 :key #'1+) 3) (deftest position-bit-vector.12 (position 2 #*00010001010 :key '1+) 3) (deftest position-bit-vector.13 (position 2 #*0010001000 :key #'1+ :from-end t) 6) (deftest position-bit-vector.14 (position 0 #*0010111010 :test (complement #'eql)) 2) (deftest position-bit-vector.15 (position 0 #*0010111010 :test (complement #'eql) :from-end t) 8) (deftest position-bit-vector.16 (position 0 #*0010111010 :test-not #'eql) 2) (deftest position-bit-vector.17 (position 0 #*001011101 :test-not 'eql :from-end t) 8) (deftest position-bit-vector.18 (position 0 #*00101110 :test-not 'eql) 2) (deftest position-bit-vector.19 (position 0 #*00101110 :test-not #'eql :from-end t) 6) (deftest position-bit-vector.20 (position 0 #*00101110 :test-not #'eql) 2) (deftest position-bit-vector.21 (position 0 #*00101110 :test #'eql :start 2) 3) (deftest position-bit-vector.22 (position 0 #*00101110 :test #'eql :start 2 :end nil) 3) (deftest position-bit-vector.23 (position 0 #*00101110 :test-not #'eql :start 0 :end 5) 2) (deftest position-bit-vector.24 (position 0 #*00101110 :test-not #'eql :start 0 :end 5 :from-end t) 4) (deftest position-bit-vector.25 (position 2 #*1100001010 :key #'1+ :start 3) 6) (deftest position-bit-vector.27 (position 2 #*1100001010 :key #'1+ :start 2 :from-end t) 8) (deftest position-bit-vector.28 (position 0 (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) :element-type 'bit :fill-pointer 5)) nil) (deftest position-bit-vector.29 (position 0 (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) :element-type 'bit :fill-pointer 5) :from-end t) nil) (deftest position-bit-vector.30 (position 0 (make-array '(10) :initial-contents '(1 1 1 1 0 0 0 0 0 0) :element-type 'bit :fill-pointer 5)) 4) (deftest position-bit-vector.31 (position 0 (make-array '(10) :initial-contents '(0 1 0 1 0 0 0 0 0 0) :element-type 'bit :fill-pointer 5) :from-end t) 4) (deftest position-bit-vector.32 (position 0 (make-array '(10) :initial-contents '(1 0 1 1 0 0 0 0 0 0) :element-type 'bit :fill-pointer 5)) 1) ;;; strings (deftest position-string.1 (position #\c "abcdeca") 2) (deftest position-string.2 (position #\c "abcdeca" :from-end t) 5) (deftest position-string.3 (loop for i from 0 to 7 collect (position #\c "abcdeca" :start i)) (2 2 2 5 5 5 nil nil)) (deftest position-string.4 (loop for i from 0 to 7 collect (position #\c "abcdeca" :start i :end nil)) (2 2 2 5 5 5 nil nil)) (deftest position-string.5 (loop for i from 7 downto 0 collect (position #\c "abcdeca" :end i)) (2 2 2 2 2 nil nil nil)) (deftest position-string.6 (loop for i from 0 to 7 collect (position #\c "abcdeca" :start i :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-string.7 (loop for i from 0 to 7 collect (position #\c "abcdeca" :start i :end nil :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-string.8 (loop for i from 7 downto 0 collect (position #\c "abcdeca" :end i :from-end t)) (5 5 2 2 2 nil nil nil)) (deftest position-string.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position #\c "abcdeca" :start i :end j))) ((nil nil 2 2 2 2 2) (nil 2 2 2 2 2) (2 2 2 2 2) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-string.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position #\c "abcdeca" :start i :end j :from-end t))) ((nil nil 2 2 2 5 5) (nil 2 2 2 5 5) (2 2 2 5 5) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-string.11 (position 5 "12345648" :key #'(lambda (c) (1+ (read-from-string (string c))))) 3) (deftest position-string.13 (position 5 "12345648" :key #'(lambda (c) (1+ (read-from-string (string c)))) :from-end t) 6) (deftest position-string.14 (position #\a "aabacedafa" :test (complement #'eql)) 2) (deftest position-string.15 (position #\a "aabacedafa" :test (complement #'eql) :from-end t) 8) (deftest position-string.16 (position #\a "aabacedafa" :test-not #'eql) 2) (deftest position-string.17 (position #\a "aabacedafa" :test-not 'eql :from-end t) 8) (deftest position-string.18 (position #\a "aabacedafa" :test-not 'eql) 2) (deftest position-string.19 (position #\a "aabacedafa" :test-not #'eql :from-end t) 8) (deftest position-string.20 (position #\a "aabacedafa" :test-not #'eql) 2) (deftest position-string.21 (position #\a "aabacedafa" :test #'eql :start 2) 3) (deftest position-string.22 (position #\a "aabacedafa" :test #'eql :start 2 :end nil) 3) (deftest position-string.23 (position #\a "aabacedafa" :test-not #'eql :start 0 :end 5) 2) (deftest position-string.24 (position #\a "aabacedafa" :test-not #'eql :start 0 :end 5 :from-end t) 4) (deftest position-string.25 (position #\a (make-array '(10) :initial-contents "bbbbbaaaaa" :element-type 'character :fill-pointer 5)) nil) (deftest position-string.26 (position #\a (make-array '(10) :initial-contents "bbbbbaaaaa" :element-type 'character :fill-pointer 5) :from-end t) nil) (deftest position-string.27 (position #\a (make-array '(10) :initial-contents "bbbbaaaaaa" :element-type 'character :fill-pointer 5)) 4) (deftest position-string.28 (position #\a (make-array '(10) :initial-contents "babbaaaaaa" :element-type 'character :fill-pointer 5) :from-end t) 4) (deftest position.order.1 (let ((i 0) a b c d e f g) (values (position (progn (setf a (incf i)) 0) (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) :from-end (setf c (incf i)) :start (progn (setf d (incf i)) 1) :end (progn (setf e (incf i)) 6) :key (progn (setf f (incf i)) #'1-) :test (progn (setf g (incf i)) #'=) ) i a b c d e f g)) 4 7 1 2 3 4 5 6 7) (deftest position.order.2 (let ((i 0) a b c d e f g) (values (position (progn (setf a (incf i)) 0) (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) :test-not (progn (setf c (incf i)) #'/=) :key (progn (setf d (incf i)) #'1-) :end (progn (setf e (incf i)) 6) :start (progn (setf f (incf i)) 1) :from-end (setf g (incf i)) ) i a b c d e f g)) 4 7 1 2 3 4 5 6 7) ;;; Keyword tests (deftest position.allow-other-keys.1 (position 0 '(1 2 0 3 2 1) :allow-other-keys t) 2) (deftest position.allow-other-keys.2 (position 0 '(1 2 0 3 2 1) :allow-other-keys nil) 2) (deftest position.allow-other-keys.3 (position 0 '(1 2 0 3 2 1) :allow-other-keys t :bad t) 2) (deftest position.allow-other-keys.4 (position 0 '(1 2 0 3 2 1) :bad t :allow-other-keys t) 2) (deftest position.allow-other-keys.5 (position 0 '(1 2 0 3 2 1) :bad t :allow-other-keys t :key #'1-) 0) (deftest position.keywords.6 (position 0 '(1 2 0 3 2 1) :key #'1- :key #'identity) 0) (deftest position.allow-other-keys.7 (position 0 '(1 2 0 3 2 1) :bad t :allow-other-keys t :allow-other-keys nil) 2) (deftest position.allow-other-keys.8 (position 0 '(1 2 0 3 2 1) :allow-other-keys t :bad t :allow-other-keys nil) 2) (deftest position.allow-other-keys.9 (position 0 '(1 2 0 3 2 1) :allow-other-keys t :allow-other-keys nil :bad t) 2) ;;; Error tests (deftest position.error.1 (classify-error (position 'a 'b)) type-error) (deftest position.error.2 (classify-error (position 'a 10)) type-error) (deftest position.error.3 (classify-error (position 'a 1.4)) type-error) (deftest position.error.4 (classify-error (position 'e '(a b c . d))) type-error) (deftest position.error.5 (classify-error (position)) program-error) (deftest position.error.6 (classify-error (position 'a)) program-error) (deftest position.error.7 (classify-error (position 'a nil :key)) program-error) (deftest position.error.8 (classify-error (position 'a nil 'bad t)) program-error) (deftest position.error.9 (classify-error (position 'a nil 'bad t :allow-other-keys nil)) program-error) (deftest position.error.10 (classify-error (position 'a nil 1 2)) program-error) (deftest position.error.11 (classify-error (locally (position 'a 'b) t)) type-error) (deftest position.error.12 (classify-error (position 'b '(a b c d) :test #'identity)) program-error) (deftest position.error.13 (classify-error (position 'b '(a b c d) :test-not #'not)) program-error) (deftest position.error.14 (classify-error (position 'b '(a b c d) :key #'cdr)) type-error) (deftest position.error.15 (classify-error (position 'b '(a b c d) :key #'cons)) program-error) gcl/ansi-tests/prog.lsp000066400000000000000000000037521242227143400154140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 09:21:57 2002 ;;;; Contains: Tests of PROG (in-package :cl-test) (deftest prog.1 (prog ()) nil) (deftest prog.2 (prog () 'a) nil) (deftest prog.3 (prog () (return 'a)) a) (deftest prog.4 (prog () (return (values 1 2 3 4 5))) 1 2 3 4 5) (deftest prog.5 (let ((x 'a)) (prog ((x 'b) (y x)) (declare (type symbol x y)) (return (values x y)))) b a) (deftest prog.6 (let ((x 'a)) (prog (x) (setq x 'b)) x) a) (deftest prog.7 (prog ((i 1) (s 0)) (declare (type fixnum i s)) again (when (> i 10) (return s)) (incf s i) (incf i) (go again)) 55) (deftest prog.8 (let ((x 0)) (prog ((y (incf x)) (z (incf x))) (return (values x y z)))) 2 1 2) (deftest prog.9 (flet ((%f () (locally (declare (special z)) z))) (prog ((z 10)) (declare (special z)) (return (%f)))) 10) (deftest prog.10 (prog () (return (1+ (prog () (go end) done (return 1) end (go done)))) done (return 'bad)) 2) ;;; Tests of PROG* (deftest prog*.1 (prog* ()) nil) (deftest prog*.2 (prog* () 'a) nil) (deftest prog*.3 (prog* () (return 'a)) a) (deftest prog*.4 (prog* () (return (values 1 2 3 4 5))) 1 2 3 4 5) (deftest prog*.5 (let ((x 'a)) (prog* ((z x) (x 'b) (y x)) (declare (type symbol x y)) (return (values x y z)))) b b a) (deftest prog*.6 (let ((x 'a)) (prog* (x) (setq x 'b)) x) a) (deftest prog*.7 (prog* ((i 1) (s 0)) (declare (type fixnum i s)) again (when (> i 10) (return s)) (incf s i) (incf i) (go again)) 55) (deftest prog*.8 (let ((x 0)) (prog* ((y (incf x)) (z (incf x))) (return (values x y z)))) 2 1 2) (deftest prog*.9 (flet ((%f () (locally (declare (special z)) z))) (prog* ((z 10)) (declare (special z)) (return (%f)))) 10) (deftest prog*.10 (prog* () (return (1+ (prog* () (go end) done (return 1) end (go done)))) done (return 'bad)) 2) gcl/ansi-tests/prog1.lsp000066400000000000000000000006101242227143400154630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 09:37:14 2002 ;;;; Contains: Tests for PROG1 (in-package :cl-test) (deftest prog1.1 (prog1 'a) a) (deftest prog1.2 (prog1 'a 'b) a) (deftest prog1.3 (prog1 (values 'a 'b) 'c) a) (deftest prog1.4 (prog1 (values) 'c) nil) (deftest prog1.5 (let ((x 0)) (values (prog1 x (incf x)) x)) 0 1) gcl/ansi-tests/prog2.lsp000066400000000000000000000010501242227143400154630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 09:40:51 2002 ;;;; Contains: Tests for PROG2 (in-package :cl-test) (deftest prog2.1 (prog2 'a 'b) b) (deftest prog2.2 (prog2 'a 'b 'c) b) (deftest prog2.3 (prog2 'a (values) 'c) nil) (deftest prog2.4 (prog2 'a (values 'b 'd) 'c) b) (deftest prog2.5 (let ((x 0)) (values (prog2 (incf x) (incf x) (incf x)) x)) 2 3) (deftest prog2.6 (let ((x 1)) (values (prog2 (incf x (1+ x)) (incf x (+ 2 x)) (incf x 100)) x)) 8 108) gcl/ansi-tests/progn.lsp000066400000000000000000000010611242227143400155610ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 09:33:51 2002 ;;;; Contains: Tests of PROGN (in-package :cl-test) (deftest progn.1 (progn) nil) (deftest progn.2 (progn 'a) a) (deftest progn.3 (progn 'b 'a) a) (deftest progn.4 (let ((x 0)) (values (progn (incf x) x) x)) 1 1) (deftest progn.5 (progn (values))) (deftest progn.6 (progn (values 1 2) (values 'a 'b 'c 'd 'e)) a b c d e) (deftest progn.7 (let ((x 0)) (prog () (progn (go x) x 'a) (return 'bad) x (return 'good))) good) gcl/ansi-tests/progv.lsp000066400000000000000000000024221242227143400155730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 10:00:50 2002 ;;;; Contains: Tests for PROGV (in-package :cl-test) (deftest progv.1 (progv () () t) t) (deftest progv.2 (progv '(x) '(1) (not (not (boundp 'x)))) t) (deftest progv.3 (progv '(x) '(1) (symbol-value 'x)) 1) (deftest progv.4 (progv '(x) '(1) (locally (declare (special x)) x)) 1) (deftest progv.5 (let ((x 0)) (progv '(x) '(1) x)) 0) (deftest progv.6 (let ((x 0)) (declare (special x)) (progv '(x) () (boundp 'x))) nil) (deftest progv.6a (let ((x 0)) (declare (special x)) (progv '(x) () (setq x 1)) x) 0) (deftest progv.7 (progv '(x y z) '(1 2 3) (locally (declare (special x y z)) (values x y z))) 1 2 3) (deftest progv.8 (progv '(x y z) '(1 2 3 4 5 6 7 8) (locally (declare (special x y z)) (values x y z))) 1 2 3) (deftest progv.9 (let ((x 0)) (declare (special x)) (progv '(x y z w) '(1) (values (not (not (boundp 'x))) (boundp 'y) (boundp 'z) (boundp 'w)))) t nil nil nil) ;; forms are evaluated in order (deftest progv.10 (let ((x 0) (y 0) (c 0)) (progv (progn (setf x (incf c)) nil) (progn (setf y (incf c)) nil) (values x y c))) 1 2 2) gcl/ansi-tests/random-aux.lsp000066400000000000000000000047411242227143400165170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 8 06:56:15 2003 ;;;; Contains: Aux. functions and macros used for randomization (in-package :cl-test) (defun random-from-seq (seq) "Generate a random member of a sequence." (let ((len (length seq))) (assert (> len 0)) (elt seq (random len)))) (defmacro random-case (&body cases) (let ((len (length cases))) (assert (> len 0)) `(case (random ,len) ,@(loop for i from 0 for e in cases collect `(,i ,e)) (t (error "Can't happen?! (in random-case)~%"))))) (defmacro rcase (&body cases) "Usage: (RCASE (
+)+), where is a positive real indicating the relative probability of executing the associated implicit progn." (assert cases) (let* ((weights (mapcar #'car cases)) (cumulative-weights (let ((sum 0)) (loop for w in weights collect (incf sum w)))) (total (car (last cumulative-weights))) (r (gensym))) (assert (every #'plusp weights)) `(let ((,r (random ,total))) (cond ,@(loop for case in (butlast cases) for cw in cumulative-weights collect `((< ,r ,cw) ,@(cdr case))) (t ,@(cdar (last cases))))))) (defun random-nonnegative-real () (if (coin 3) (random-case (/ (random 10000) (1+ (random 1000))) (/ (random 1000000) (1+ (random 100000))) (/ (random 100000000) (1+ (random 10000000))) (/ (random 1000000000000) (1+ (random 10000000)))) (random (random-case 1000 100000 10000000 1000000000 (expt 2.0s0 (random 15)) (expt 2.0f0 (random 32)) (expt 2.0d0 (random 32)) (expt 2.0l0 (random 32)))))) (defun random-real () (if (coin) (random-nonnegative-real) (- (random-nonnegative-real)))) (defun random-fixnum () (+ (random (1+ (- most-positive-fixnum most-negative-fixnum))) most-negative-fixnum)) (defun random-from-interval (upper &optional (lower (- upper))) (+ (random (- upper lower)) lower)) (defun coin (&optional (n 2)) "Flip an n-sided coin." (eql (random n) 0)) ;;; Randomly permute a sequence (defun random-permute (seq) (setq seq (copy-seq seq)) (let ((len (length seq))) (loop for i from len downto 2 do (let ((r (random i))) (rotatef (elt seq r) (elt seq (1- i)))))) seq) (defun binomial-distribution-test (n fn) (let* ((count (loop repeat n count (funcall fn))) (sigma (/ (sqrt n) 2.0)) (bound (* sigma 6)) (expected (/ n 2.0))) (<= (- expected bound) count (+ expected bound)))) gcl/ansi-tests/random-int-form.lsp000066400000000000000000001771241242227143400174630ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Sep 10 18:03:52 2003 ;;;; Contains: Simple randon form generator/tester (in-package :cl-test) (compile-and-load "random-aux.lsp") ;;; ;;; This file contains a routine for generating random legal Common Lisp functions ;;; for differential testing. ;;; ;;; To run the random tests by themselves, start a lisp in the ansi-tests directory ;;; and do the following: ;;; (load "gclload1.lsp") ;;; (compile-and-load "random-int-form.lsp") ;;; (in-package :cl-test) ;;; (let ((*random-state* (make-random-state t))) ;;; (test-random-integer-forms 100 4 10000)) ;; or other parameters ;;; ;;; If a test breaks during testing the variables *optimized-fn-src*, ;;; *unoptimized-fn-src*, and *int-form-vals* can be used to get the source ;;; of the optimized/unoptimized lambda forms being compiled, and the arguments ;;; on which they are called. ;;; ;;; If a difference is found between optimized/unoptimized functions the forms, ;;; values, and results are collected. A list of all these discrepancies is returned ;;; after testing finishes (assuming nothing breaks). ;;; ;;; The variable *compile-unoptimized-form* controls whether the low optimization ;;; form is compiled, or if a form funcalling it is EVALed. The latter is often ;;; faster, and may find more problems since an interpreter and compiler may evaluate ;;; forms in very different ways. ;;; ;;; The rctest/ subdirectory contains fragments of a more OO random form generator ;;; that will eventually replace this preliminary effort. ;;; ;;; The file misc.lsp contains tests that were mostly for bugs found by this ;;; random tester in various Common Lisp implementations. ;;; (declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals* *opt-result* *unopt-result* $x $y $z *compile-unoptimized-form*)) ;;; Little functions used to run collected tests. ;;; (f i) runs the ith collected optimized test ;;; (g i) runs the ith collected unoptimized test ;;; (p i) prints the ith test (forms, input values, and other information) (defun f (i) (let ((plist (elt $y i))) (apply (compile nil (getf plist :optimized-lambda-form)) (getf plist :vals)))) (defun g (i) (let ((plist (elt $y i))) (if *compile-unoptimized-form* (apply (compile nil (getf plist :unoptimized-lambda-form)) (getf plist :vals)) (apply (the function (eval `(function ,(getf plist :unoptimized-lambda-form)))) (getf plist :vals))))) (defun p (i) (write (elt $y i) :pretty t :escape t) (values)) (defun tn (n &optional (size 100)) (length (setq $y (prune-results (setq $x (test-random-integer-forms size 2 n)))))) (declaim (special *s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*)) (defparameter *loop-random-int-form-period* 2000) ;;; Run the random tester, collecting failures into the special ;;; variable $y. (defun loop-random-int-forms (&optional (size 200) (nvars 3)) (unless (boundp '$x) (setq $x nil)) (unless (boundp '$y) (setq $y nil)) (loop for i from 1 do (format t "~6D | " i) (finish-output *standard-output*) (let ((x (test-random-integer-forms size nvars *loop-random-int-form-period* :index (* (1- i) *loop-random-int-form-period*)))) (when x (setq $x (append $x x)) (setq x (prune-results x)) (terpri) (print x) (finish-output *standard-output*) (setq $y (append $y x))) (terpri)))) (defvar *random-int-form-blocks* nil) (defvar *random-int-form-catch-tags* nil) (defvar *go-tags* nil) (defvar *maximum-random-int-bits* 45) (defvar *random-vals-list-bound* 10) (defvar *max-compile-time* 0) (defvar *max-compile-term* nil) (defvar *print-immediately* nil) (defvar *compile-unoptimized-form* #+(or allegro sbcl) t #-(or allegro sbcl) nil) (declaim (special *vars*)) (defstruct var-desc (name nil :type symbol) (type t)) (defun test-random-integer-forms (size nvars n &key ((:random-state *random-state*) (make-random-state t)) (file-prefix "b") (index 0) (random-size nil) (random-nvars nil) ) "Generate random integer forms of size SIZE with NVARS variables. Do this N times, returning all those on which a discrepancy is found between optimized and nonoptimize, notinlined code." (assert (integerp nvars)) (assert (<= 1 nvars 26)) (assert (and (integerp n) (plusp n))) (assert (and (integerp n) (plusp size))) ;;; #+sbcl ;;; (loop for x in (reverse sb-ext:*before-gc-hooks*) ;;; do (pushnew x sb-ext:*after-gc-hooks*)) (loop for i from 1 to n do (when (= (mod i 100) 0) ;; #+sbcl (print "Do gc...") ;; #+sbcl (sb-ext::gc :full t) (prin1 i) (princ " ") (finish-output *standard-output*)) nconc (let ((result (test-random-integer-form (if random-size (1+ (random size)) size) (if random-nvars (1+ (random nvars)) nvars) :index (+ index i) :file-prefix file-prefix))) (when result (let ((*print-readably* t)) (format t "~%~A~%" (format nil "~S" (car result))) (finish-output *standard-output*))) result))) (defun test-random-integer-form (size nvars &key (index 0) (file-prefix "b")) (let* ((vars (subseq '(a b c d e f g h i j k l m n o p q r s u v w x y z) 0 nvars)) (var-ranges (mapcar #'make-random-integer-range vars)) (var-types (mapcar #'(lambda (range) (let ((lo (car range)) (hi (cadr range))) (assert (>= hi lo)) `(integer ,lo ,hi))) var-ranges)) (form (let ((*vars* (loop for v in vars for tp in var-types collect (make-var-desc :name v :type tp))) (*random-int-form-blocks* nil) (*random-int-form-catch-tags* nil) (*go-tags* nil) ) (make-random-integer-form (1+ (random size))))) (vals-list (loop repeat *random-vals-list-bound* collect (mapcar #'(lambda (range) (let ((lo (car range)) (hi (cadr range))) (random-from-interval (1+ hi) lo))) var-ranges))) (opt-decls-1 (make-random-optimize-settings)) (opt-decls-2 (make-random-optimize-settings))) (when *print-immediately* (with-open-file (s (format nil "~A~A.lsp" file-prefix index) :direction :output :if-exists :error) (print `(defparameter *x* '(:vars ,vars :var-types ,var-types :vals-list ,vals-list :decls1 ,opt-decls-1 :decls2 ,opt-decls-2 :form ,form)) s) (print '(load "c.lsp") s) (finish-output s)) ;; (cl-user::gc) (make-list 1000000) ;; try to trigger a gc ) (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2))) (defun make-random-optimize-settings () (loop for settings = (cons (list 'speed (1+ (random 3))) (loop for s in '(space safety debug compilation-speed) for n = (random 4) collect (list s n))) while #+allegro (subsetp '((speed 3) (safety 0)) settings :test 'equal) #-allegro nil finally (return settings))) (defun fn-symbols-in-form (form) "Return a list of the distinct standardized lisp function symbols occuring ing FORM. These are used to generate a NOTINLINE declaration for the unoptimized form." (intersection (remove-duplicates (fn-symbols-in-form* form) :test #'eq) *cl-function-or-accessor-symbols*)) (defun fn-symbols-in-form* (form) (when (consp form) (if (symbolp (car form)) (cons (car form) (mapcan #'fn-symbols-in-form* (cdr form))) (mapcan #'fn-symbols-in-form* form)))) (defun make-random-integer-range (&optional var) "Generate a list (LO HI) of integers, LO <= HI. This is used for generating integer types." (declare (ignore var)) (rcase (1 (flet ((%r () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*))))) (- (random r) (floor (/ r 2)))))) (let ((x (%r)) (y (%r))) (list (min x y) (max x y))))) (1 (let* ((b (ash 1 (1+ (random *maximum-random-int-bits*)))) (b2 (floor (/ b 2)))) (let ((x (- (random b) b2)) (y (- (random b) b2))) (list (min x y) (max x y))))))) (defun fn-arg-name (fn-name arg-index) (intern (concatenate 'string (subseq (symbol-name fn-name) 1) (format nil "-~D" arg-index)) (symbol-package fn-name))) (declaim (special *flet-names*)) (defparameter *flet-names* nil) (defun make-random-integer () (let ((r (ash 1 (1+ (random 32))))) (- (random r) (floor (/ r 2))))) (defun random-var-desc () (loop (let* ((pos (random (length *vars*))) (desc (elt *vars* pos))) (when (= pos (position (var-desc-name desc) (the list *vars*) :key #'var-desc-name)) (return desc))))) (defun make-random-integer-form (size) "Generate a random legal lisp form of size SIZE (roughly)." (if (<= size 1) ;; Leaf node -- generate a variable, constant, or flet function call (loop when (rcase (10 (make-random-integer)) (9 (if *vars* (let* ((desc (random-var-desc)) (type (var-desc-type desc)) (name (var-desc-name desc))) (cond ((subtypep type 'integer) name) ((subtypep type '(array integer nil)) `(aref ,name)) ((subtypep type '(cons integer integer)) (rcase (1 `(car ,name)) (1 `(cdr ,name)))) (t nil))) nil)) (1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil)) (2 (if *flet-names* (let* ((flet-entry (random-from-seq *flet-names*)) (flet-name (car flet-entry)) (flet-minargs (cadr flet-entry)) (flet-maxargs (caddr flet-entry)) (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) (args (loop repeat nargs collect (make-random-integer-form 1)))) `(,flet-name ,@args)) nil))) return it) ;; (> size 1) (rcase ;; flet call #-(or armedbear) (30 ;; 5 (make-random-integer-flet-call-form size)) ;; Unary ops (40 (let ((op (random-from-seq '(- abs signum 1+ 1- conjugate rational rationalize numerator denominator identity progn floor #-(or armedbear) ignore-errors cl:handler-case restart-case ceiling truncate round realpart imagpart integer-length logcount values locally)))) `(,op ,(make-random-integer-form (1- size))))) #-(or armedbear) (4 (make-random-integer-unwind-protect-form size)) (5 (make-random-integer-mapping-form size)) ;; prog1, multiple-value-prog1 #-(or armedbear) (4 (let* ((op (random-from-seq #(prog1 multiple-value-prog1))) (nforms (random 4)) (sizes (random-partition (1- size) (1+ nforms))) (args (mapcar #'make-random-integer-form sizes))) `(,op ,@args))) ;; prog2 (2 (let* ((nforms (random 4)) (sizes (random-partition (1- size) (+ nforms 2))) (args (mapcar #'make-random-integer-form sizes))) `(prog2 ,@args))) (2 `(isqrt (abs ,(make-random-integer-form (- size 2))))) (2 `(the integer ,(make-random-integer-form (1- size)))) (1 `(cl:handler-bind nil ,(make-random-integer-form (1- size)))) (1 `(restart-bind nil ,(make-random-integer-form (1- size)))) (1 `(macrolet () ,(make-random-integer-form (1- size)))) ;; dotimes #-allegro (5 (let* ((var (random-from-seq #(iv1 iv2 iv3 iv4))) (count (random 4)) (sizes (random-partition (1- size) 2)) (body (let ((*vars* (cons (make-var-desc :name var :type nil) *vars*))) (make-random-integer-form (first sizes)))) (ret-form (make-random-integer-form (second sizes)))) (unless (consp body) (setq body `(progn ,body))) `(dotimes (,var ,count ,ret-form) ,body))) ;; loop (5 (make-random-loop-form (1- size))) #-(or gcl ecl armedbear) ;; load-time-value (2 (let ((arg (let ((*flet-names* nil) (*vars* nil) (*random-int-form-blocks* nil) (*random-int-form-catch-tags* nil) (*go-tags* nil)) (make-random-integer-form (1- size))))) (rcase (4 `(load-time-value ,arg t)) (2 `(load-time-value ,arg)) (2 `(load-time-value ,arg nil))))) ;; eval (2 (make-random-integer-eval-form size)) #-(or cmu allegro) (2 (destructuring-bind (s1 s2) (random-partition (- size 2) 2) `(ash ,(make-random-integer-form s1) (min ,(random 100) ,(make-random-integer-form s2))))) ;; binary floor, ceiling, truncate, round (4 (let ((op (random-from-seq #(floor ceiling truncate round mod rem))) (op2 (random-from-seq #(max min)))) (destructuring-bind (s1 s2) (random-partition (- size 2) 2) `(,op ,(make-random-integer-form s1) (,op2 ,(if (eq op2 'max) (1+ (random 100)) (- (1+ (random 100)))) ,(make-random-integer-form s2)))))) ;; Binary op (30 (let* ((op (random-from-seq '(+ - * logand min max gcd lcm #-:allegro logandc1 logandc2 logeqv logior lognand lognor #-:allegro logorc1 logorc2 logxor )))) (destructuring-bind (leftsize rightsize) (random-partition (1- size) 2) (let ((e1 (make-random-integer-form leftsize)) (e2 (make-random-integer-form rightsize))) `(,op ,e1 ,e2))))) ;; boole (4 (let* ((op (random-from-seq #(boole-1 boole-2 boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand boole-nor boole-orc1 boole-orc2 boole-set boole-xor)))) (destructuring-bind (leftsize rightsize) (random-partition (- size 2) 2) (let ((e1 (make-random-integer-form leftsize)) (e2 (make-random-integer-form rightsize))) `(boole ,op ,e1 ,e2))))) ;; n-ary ops (30 (let* ((op (random-from-seq #(+ - * logand min max logior lcm gcd logxor))) (nargs (1+ (min (random 10) (random 10) (random 10)))) (sizes (random-partition (1- size) nargs)) (args (mapcar #'make-random-integer-form sizes))) `(,op ,@args))) ;; expt (3 `(expt ,(make-random-integer-form (1- size)) ,(random 3))) ;; coerce (2 `(coerce ,(make-random-integer-form (1- size)) 'integer)) ;; complex (degenerate case) (2 `(complex ,(make-random-integer-form (1- size)) 0)) ;; quotient (degenerate cases) (1 `(/ ,(make-random-integer-form (1- size)) 1)) (1 `(/ ,(make-random-integer-form (1- size)) -1)) ;; tagbody (5 (make-random-tagbody-and-progn size)) ;; conditionals (20 (let* ((cond-size (random (max 1 (floor size 2)))) (then-size (random (- size cond-size))) (else-size (- size 1 cond-size then-size)) (pred (make-random-pred-form cond-size)) (then-part (make-random-integer-form then-size)) (else-part (make-random-integer-form else-size))) `(if ,pred ,then-part ,else-part))) (5 (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) `(,(random-from-seq '(deposit-field dpb)) ,(make-random-integer-form s1) ,(make-random-byte-spec-form s2) ,(make-random-integer-form s3)))) #-:allegro (10 (destructuring-bind (s1 s2) (random-partition (1- size) 2) `(,(random-from-seq '(ldb mask-field)) ,(make-random-byte-spec-form s1) ,(make-random-integer-form s2)))) (20 (make-random-integer-binding-form size)) ;; progv #-(or armedbear) (4 (make-random-integer-progv-form size)) (4 `(let () ,(make-random-integer-form (1- size)))) (10 (let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8))) (*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) `(block ,name ,(make-random-integer-form (1- size))))) #-(or armedbear) (20 (let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8)))) (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*))) `(catch ,tag ,(make-random-integer-form (1- size))))) (4 ;; setq and similar (make-random-integer-setq-form size)) (10 (make-random-integer-case-form size)) (3 (if *random-int-form-blocks* (let ((name (random-from-seq *random-int-form-blocks*)) (form (make-random-integer-form (1- size)))) `(return-from ,name ,form)) ;; No blocks -- try again (make-random-integer-form size))) (20 (if *random-int-form-catch-tags* (let ((tag (random-from-seq *random-int-form-catch-tags*)) (form (make-random-integer-form (1- size)))) `(throw ,tag ,form)) ;; No catch tags -- try again (make-random-integer-form size))) (5 (if *random-int-form-blocks* (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) (let ((name (random-from-seq *random-int-form-blocks*)) (pred (make-random-pred-form s1)) (then (make-random-integer-form s2)) (else (make-random-integer-form s3))) `(if ,pred (return-from ,name ,then) ,else))) ;; No blocks -- try again (make-random-integer-form size))) #-(or armedbear) (20 (make-random-flet-form size)) (2 (let* ((nbits (1+ (min (random 20) (random 20)))) (bvec (coerce (loop repeat nbits collect (random 2)) 'simple-bit-vector)) (op (random-from-seq #(bit sbit)))) `(,op ,bvec (min ,(1- nbits) (max 0 ,(make-random-integer-form (- size 3 nbits))))))) (2 (let* ((nvals (1+ (min (random 20) (random 20)))) (lim (ash 1 (+ 3 (random 40)))) (vec (coerce (loop repeat nvals collect (random lim)) 'simple-vector)) (op (random-from-seq #(aref svref elt)))) `(,op ,vec (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals))))))) (2 (let* ((nvals (1+ (min (random 20) (random 20)))) (lim (ash 1 (+ 3 (random 40)))) (vals (loop repeat nvals collect (random lim))) (op 'elt)) `(,op ',vals (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals))))))) ))) (defun make-random-integer-flet-call-form (size) (if *flet-names* (let* ((flet-entry (random-from-seq *flet-names*)) (flet-name (car flet-entry)) (flet-minargs (cadr flet-entry)) (flet-maxargs (caddr flet-entry)) (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) ) (cond ((> nargs 0) (let* ((arg-sizes (random-partition (1- size) nargs)) (args (mapcar #'make-random-integer-form arg-sizes))) (rcase (1 `(,flet-name ,@args)) (1 `(multiple-value-call #',flet-name (values ,@args))) (1 `(funcall (function ,flet-name) ,@args)) (1 (let ((r (random (1+ (length args))))) `(apply (function ,flet-name) ,@(subseq args 0 r) (list ,@(subseq args r)))))))) (t (make-random-integer-form size)))) (make-random-integer-form size))) (defun make-random-integer-unwind-protect-form (size) (let* ((op 'unwind-protect) (nforms (random 4)) (sizes (random-partition (1- size) (1+ nforms))) (arg (make-random-integer-form (first sizes))) (unwind-forms ;; We have to be careful not to generate code that will ;; illegally transfer control to a dead location (let ((*flet-names* nil) (*go-tags* nil) (*random-int-form-blocks* nil) (*random-int-form-catch-tags* nil)) (mapcar #'make-random-integer-form (rest sizes))))) `(,op ,arg ,@unwind-forms))) (defun make-random-integer-eval-form (size) (flet ((%arg (size) (let ((*flet-names* nil) (*vars* (remove-if-not #'(lambda (s) (member (var-desc-name s) '(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*) :test #'eq)) *vars*)) (*random-int-form-blocks* nil) (*go-tags* nil)) (make-random-integer-form size)))) (rcase (2 `(eval ',(%arg (1- size)))) (2 (let* ((nargs (1+ (random 4))) (sizes (random-partition (1- size) nargs)) (args (mapcar #'%arg sizes))) `(eval (values ,@args)))) ))) (defun make-random-type-for-var (var e1) (let (desc) (values (cond ((and (member var '(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*) :test #'eq) (setq desc (find var *vars* :key #'var-desc-name))) (var-desc-type desc)) (t (rcase (4 '(integer * *)) (2 (setq e1 `(make-array nil :initial-element ,e1 ,@(rcase (1 nil) (1 '(:adjustable t))))) '(array integer nil)) (1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1))) '(cons integer integer)) (1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1)) '(cons integer integer))))) e1))) (defun make-random-integer-binding-form (size) (destructuring-bind (s1 s2) (random-partition (1- size) 2) (let* ((var (rcase (2 (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10))) (2 (random-from-seq #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*))))) (e1 (make-random-integer-form s1)) (type (multiple-value-bind (type2 e) (make-random-type-for-var var e1) (setq e1 e) type2)) (e2 (let ((*vars* (cons (make-var-desc :name var :type type) *vars*))) (make-random-integer-form s2))) (op (random-from-seq #(let let*)))) ;; for now, avoid shadowing (if (member var *vars* :key #'var-desc-name) (make-random-integer-form size) (rcase (8 `(,op ((,var ,e1)) ,@(rcase (1 `((declare (dynamic-extent ,var)))) (1 nil)) ,e2)) (2 `(multiple-value-bind (,var) ,e1 ,e2))))))) (defun make-random-integer-progv-form (size) (let* ((num-vars (random 4)) (possible-vars #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*)) (vars nil)) (loop repeat num-vars do (loop for r = (elt possible-vars (random (length possible-vars))) while (member r vars) finally (push r vars))) (setq vars (remove-if #'(lambda (var) (let ((desc (find var *vars* :key #'var-desc-name))) (and desc (not (subtypep (var-desc-type desc) 'integer))))) vars) num-vars (length vars)) (if (null vars) `(progv nil nil ,(make-random-integer-form (1- size))) (destructuring-bind (s1 s2) (random-partition (1- size) 2) (let* ((var-sizes (random-partition s1 num-vars)) (var-forms (mapcar #'make-random-integer-form var-sizes)) (*vars* (append (loop for v in vars collect (make-var-desc :name v :type '(integer * *))) *vars*)) (body-form (make-random-integer-form s2))) `(progv ',vars (list ,@var-forms) ,body-form)))))) (defun make-random-integer-mapping-form (size) ;; reduce (let ((keyargs nil) (nargs (1+ (random (min 10 (max 1 size))))) (sequence-op (random-from-seq '(vector list)))) (when (coin 2) (setq keyargs '(:from-end t))) (cond ((coin 2) (let ((start (random nargs))) (setq keyargs `(:start ,start ,@keyargs)) (when (coin 2) (let ((end (+ start 1 (random (- nargs start))))) (setq keyargs `(:end ,end ,@keyargs)))))) (t (when (coin 2) (let ((end (1+ (random nargs)))) (setq keyargs `(:end ,end ,@keyargs)))))) (rcase (1 (let ((sizes (random-partition (1- size) nargs)) (op (random-from-seq #(+ - * logand logxor logior max min)))) `(reduce ,(rcase (1 `(function ,op)) (1 `(quote ,op))) (,sequence-op ,@(mapcar #'make-random-integer-form sizes)) ,@keyargs))) #-(or armedbear) (1 (destructuring-bind (size1 size2) (random-partition (1- size) 2) (let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6)) (var1 (random-from-seq vars)) (var2 (random-from-seq (remove var1 vars))) (form (let ((*vars* (list* (make-var-desc :name var1 :type '(integer * *)) (make-var-desc :name var2 :type '(integer * *)) *vars*))) (make-random-integer-form size1))) (sizes (random-partition size2 nargs)) (args (mapcar #'make-random-integer-form sizes))) `(reduce (function (lambda (,var1 ,var2) ,form)) (,sequence-op ,@args) ,@keyargs))))))) (defun make-random-integer-setq-form (size) (if *vars* (let* ((vdesc (random-from-seq *vars*)) (var (var-desc-name vdesc)) (type (var-desc-type vdesc)) (op (random-from-seq #(setq setf #-(or armedbear)shiftf)))) (cond ((subtypep '(integer * *) type) (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) (when (coin 4) (setq op 'multiple-value-setq) (setq var (list var))) `(,op ,var ,(make-random-integer-form (1- size)))) ((and (consp type) (eq (car type) 'integer) (integerp (second type)) (integerp (third type))) (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) (when (coin 4) (setq op 'multiple-value-setq) (setq var (list var))) `(,op ,var ,(random-from-interval (1+ (third type)) (second type)))) ((and (subtypep '(array integer nil) type)) (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) (when (eq op 'setq) (setq op (random-from-seq #(setf shiftf)))) `(,op (aref ,var) ,(make-random-integer-form (- size 2)))) ;; Abort -- can't assign (t (make-random-integer-form size)))) (make-random-integer-form size))) (defun make-random-integer-case-form (size) (let ((ncases (1+ (random 10)))) (if (< (+ size size) (+ ncases 2)) ;; Too small, give up (make-random-integer-form size) (let* ((sizes (random-partition (1- size) (+ ncases 2))) (bound (ash 1 (+ 2 (random 16)))) (lower-bound (if (coin 3) 0 (- bound))) (upper-bound (if (and (< lower-bound 0) (coin 3)) 1 (1+ bound))) (cases (loop for case-size in (cddr sizes) for vals = (loop repeat (1+ (min (random 10) (random 10))) collect (random-from-interval upper-bound lower-bound)) for result = (make-random-integer-form case-size) repeat ncases collect `(,vals ,result))) (expr (make-random-integer-form (first sizes)))) `(case ,expr ,@cases (t ,(make-random-integer-form (second sizes)))))))) (defun make-random-flet-form (size) "Generate random flet, labels forms, for now with no arguments and a single binding per form." (let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10 %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18)))) (if (assoc fname *flet-names*) ;; Fail if the name is in use (make-random-integer-form size) (let* ((op (random-from-seq #(flet labels))) (minargs (random 4)) (maxargs #+:allegro minargs #-:allegro (rcase (1 minargs) (1 (+ minargs (random 4))))) (keyarg-p (coin 2)) (keyarg-n (if keyarg-p (random 3) 0)) (arg-names (loop for i from 1 to maxargs collect (fn-arg-name fname i))) (key-arg-names (loop for i from 1 to keyarg-n collect (intern (format nil "KEY~A" i) (find-package "CL-TEST")))) (allow-other-keys (and keyarg-p (coin 3))) ) (destructuring-bind (s1 s2 . opt-sizes) (random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs))) (let* ((form1 ;; Allow return-from of the flet/labels function (let ((*random-int-form-blocks* (cons fname *random-int-form-blocks*)) (*vars* (nconc (loop for var in (append arg-names key-arg-names) collect (make-var-desc :name var :type '(integer * *))) *vars*))) (make-random-integer-form s1))) (form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p) *flet-names*))) (make-random-integer-form s2))) (opt-forms (mapcar #'make-random-integer-form opt-sizes))) (if opt-forms `(,op ((,fname (,@(subseq arg-names 0 minargs) &optional ,@(mapcar #'list (subseq arg-names minargs) opt-forms) ,@(when keyarg-p (append '(&key) (mapcar #'list key-arg-names (subseq opt-forms (- maxargs minargs))) (when allow-other-keys '(&allow-other-keys)) ))) ,form1)) ,form2) `(,op ((,fname (,@arg-names ,@(when keyarg-p (append '(&key) (mapcar #'list key-arg-names opt-forms ) (when allow-other-keys '(&allow-other-keys)) ))) ,form1)) ,form2)))))))) (defun make-random-tagbody (size) (let* ((num-forms (random 6)) (tags nil)) (loop for i below num-forms do (loop for tag = (rcase #-allegro (1 (random 8)) (1 (random-from-seq #(tag1 tag2 tag3 tag4 tag5 tag6 tag7 tag8)))) while (member tag tags) finally (push tag tags))) (assert (= (length (remove-duplicates tags)) (length tags))) (let* ((*go-tags* (set-difference *go-tags* tags)) (sizes (if (> num-forms 0) (random-partition (1- size) num-forms) nil)) (forms (loop for tag-list on tags for i below num-forms for size in sizes collect (let ((*go-tags* (append tag-list *go-tags*))) (make-random-integer-form size))))) `(tagbody ,@(loop for tag in tags for form in forms when (atom form) do (setq form `(progn ,form)) append `(,form ,tag)))))) (defun make-random-tagbody-and-progn (size) (let* ((final-size (random (max 1 (floor size 5)))) (tagbody-size (- size final-size))) (let ((final-form (make-random-integer-form final-size)) (tagbody-form (make-random-tagbody tagbody-size))) `(progn ,tagbody-form ,final-form)))) (defun make-random-pred-form (size) "Make a random form whose value is to be used as a generalized boolean." (if (<= size 1) (rcase (1 (if (coin) t nil)) (2 `(,(random-from-seq '(< <= = > >= /= eql equal)) ,(make-random-integer-form size) ,(make-random-integer-form size)))) (rcase (1 (if (coin) t nil)) (3 `(not ,(make-random-pred-form (1- size)))) (6 (destructuring-bind (leftsize rightsize) (random-partition (1- size) 2) `(,(random-from-seq '(and or)) ,(make-random-pred-form leftsize) ,(make-random-pred-form rightsize)))) (1 (destructuring-bind (leftsize rightsize) (random-partition (1- size) 2) `(,(random-from-seq '(< <= > >= = /= eql equal)) ,(make-random-integer-form leftsize) ,(make-random-integer-form rightsize)))) (3 (let* ((cond-size (random (max 1 (floor size 2)))) (then-size (random (- size cond-size))) (else-size (- size 1 cond-size then-size)) (pred (make-random-pred-form cond-size)) (then-part (make-random-pred-form then-size)) (else-part (make-random-pred-form else-size))) `(if ,pred ,then-part ,else-part))) (1 (destructuring-bind (s1 s2) (random-partition (1- size) 2) `(ldb-test ,(make-random-byte-spec-form s1) ,(make-random-integer-form s2)))) (1 (let ((index (random (1+ (random *maximum-random-int-bits*)))) (form (make-random-integer-form (1- size)))) `(logbitp ,index ,form))) (1 ;; typep form (let ((subform (make-random-integer-form (- size 2))) (type (rcase (1 `(integer ,@(make-random-integer-range))) (1 `(integer ,(make-random-integer))) (1 `(integer * ,(make-random-integer))) (1 `(integer))))) `(typep ,subform ',type))) ))) (defun make-random-loop-form (size) (if (<= size 2) (make-random-integer-form size) (let* ((var (random-from-seq #(lv1 lv2 lv3 lv4))) (count (random 4)) (*vars* (cons (make-var-desc :name var :type nil) *vars*))) (rcase (1 `(loop for ,var below ,count count ,(make-random-pred-form (- size 2)))) (1 `(loop for ,var below ,count sum ,(make-random-integer-form (- size 2)))) )))) (defun make-random-byte-spec-form (size) (declare (ignore size)) (let* ((pform (random 33)) (sform (1+ (random 33)))) `(byte ,sform ,pform))) (defun make-random-element-of-type (type) "Create a random element of a lisp type." (cond ((consp type) (let ((type-op (first type))) (ecase type-op (integer (let ((lo (let ((lo (cadr type))) (cond ((consp lo) (1+ (car lo))) ((eq lo nil) '*) (t lo)))) (hi (let ((hi (caddr type))) (cond ((consp hi) (1- (car hi))) ((eq hi nil) '*) (t hi))))) (if (eq lo '*) (if (eq hi '*) (let ((x (ash 1 (random *maximum-random-int-bits*)))) (random-from-interval x (- x))) (random-from-interval (1+ hi) (- hi (random (ash 1 *maximum-random-int-bits*))))) (if (eq hi '*) (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) lo) ;; May generalize the next case to increase odds ;; of certain integers (near 0, near endpoints, near ;; powers of 2...) (random-from-interval (1+ hi) lo))))) (mod (let ((modulus (second type))) (assert (and (integerp modulus) (plusp modulus))) (make-random-element-of-type `(integer 0 (,modulus))))) (unsigned-byte (if (null (cdr type)) (make-random-element-of-type '(integer 0 *)) (let ((bits (second type))) (if (eq bits'*) (make-random-element-of-type '(integer 0 *)) (progn (assert (and (integerp bits) (>= bits 1))) (make-random-element-of-type `(integer 0 ,(1- (ash 1 bits))))))))) ))) (t (ecase type (bit (random 2)) (boolean (random-from-seq #(nil t))) (symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| cl:car))) (unsigned-byte (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))) 0)) (integer (let ((x (ash 1 (random *maximum-random-int-bits*)))) (random-from-interval (1+ x) (- x)))) )))) (defun make-optimized-lambda-form (form vars var-types opt-decls) `(lambda ,vars ,@(mapcar #'(lambda (tp var) `(declare (type ,tp ,var))) var-types vars) (declare (ignorable ,@vars)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize ,@opt-decls)) ,form)) (defun make-unoptimized-lambda-form (form vars var-types opt-decls) (declare (ignore var-types)) `(lambda ,vars (declare (notinline ,@(fn-symbols-in-form form))) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize ,@opt-decls)) ,form)) (defvar *compile-using-defun* #-(or allegro lispworks) nil #+(or allegro lispworks) t) (defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1) (defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2) (defun test-int-form (form vars var-types vals-list opt-decls-1 opt-decls-2) ;; Try to compile FORM with associated VARS, and if it compiles ;; check for equality of the two compiled forms. ;; Return a non-nil list of details if a problem is found, ;; NIL otherwise. (let ((optimized-fn-src (make-optimized-lambda-form form vars var-types opt-decls-1)) (unoptimized-fn-src (make-unoptimized-lambda-form form vars var-types opt-decls-2))) (setq *int-form-vals* nil *optimized-fn-src* optimized-fn-src *unoptimized-fn-src* unoptimized-fn-src) (flet ((%compile (lambda-form opt-defun-name) (cl:handler-bind (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning) (error #'(lambda (c) (format t "Compilation failure~%~A~%" (format nil "~S" form)) (finish-output *standard-output*) (return-from test-int-form (list (list :vars vars :form form :var-types var-types :vals (first vals-list) :lambda-form lambda-form :decls1 opt-decls-1 :decls2 opt-decls-2 :compiler-condition (with-output-to-string (s) (prin1 c s)))))))) (let ((start-time (get-universal-time))) (prog1 (if *compile-using-defun* (progn (eval `(defun ,opt-defun-name ,@(cdr lambda-form))) (compile opt-defun-name) (symbol-function opt-defun-name)) (compile nil lambda-form)) (let* ((stop-time (get-universal-time)) (total-time (- stop-time start-time))) (when (> total-time *max-compile-time*) (setf *max-compile-time* total-time) (setf *max-compile-term* lambda-form))) ;; #+:ecl (si:gc t) ))))) (let ((optimized-compiled-fn (%compile optimized-fn-src *name-to-use-in-optimized-defun*)) (unoptimized-compiled-fn (if *compile-unoptimized-form* (%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*) (eval `(function ,unoptimized-fn-src))))) (declare (type function optimized-compiled-fn unoptimized-compiled-fn)) (dolist (vals vals-list) (setq *int-form-vals* vals) (flet ((%eval-error (kind) (let ((*print-circle* t)) (format t "~A~%" (format nil "~S" form))) (finish-output *standard-output*) (return (list (list :vars vars :vals vals :form form :var-types var-types :decls1 opt-decls-1 :decls2 opt-decls-2 :optimized-lambda-form optimized-fn-src :unoptimized-lambda-form unoptimized-fn-src :kind kind))))) (let ((unopt-result (cl:handler-case (cl:handler-bind (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning)) (identity ;; multiple-value-list (apply unoptimized-compiled-fn vals))) ((or error serious-condition) (c) (%eval-error (list :unoptimized-form-error (with-output-to-string (s) (prin1 c s))))))) (opt-result (cl:handler-case (cl:handler-bind (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning)) (identity ;; multiple-value-list (apply optimized-compiled-fn vals))) ((or error serious-condition) (c) (%eval-error (list :optimized-form-error (with-output-to-string (s) (prin1 c s)))))))) (if (equal opt-result unopt-result) nil (progn (format t "Different results: ~A, ~A~%" opt-result unopt-result) (setq *opt-result* opt-result *unopt-result* unopt-result) (%eval-error (list :different-results opt-result unopt-result))))))))))) ;;; Interface to the form pruner (declaim (special *prune-table*)) (defun prune-int-form (input-form vars var-types vals-list opt-decls-1 opt-decls-2) "Conduct tests on selected simplified versions of INPUT-FORM. Return the minimal form that still causes some kind of failure." (loop do (let ((form input-form)) (flet ((%try-fn (new-form) (when (test-int-form new-form vars var-types vals-list opt-decls-1 opt-decls-2) (setf form new-form) (throw 'success nil)))) (let ((*prune-table* (make-hash-table :test #'eq))) (loop (catch 'success (prune form #'%try-fn) (return form))))) (when (equal form input-form) (return form)) (setq input-form form)))) (defun prune-results (result-list) "Given a list of test results, prune their forms down to a minimal set." (loop for result in result-list collect (let* ((form (getf result :form)) (vars (getf result :vars)) (var-types (getf result :var-types)) (vals-list (list (getf result :vals))) (opt-decl-1 (getf result :decls1)) (opt-decl-2 (getf result :decls2)) (pruned-form (prune-int-form form vars var-types vals-list opt-decl-1 opt-decl-2)) (optimized-lambda-form (make-optimized-lambda-form pruned-form vars var-types opt-decl-1)) (unoptimized-lambda-form (make-unoptimized-lambda-form pruned-form vars var-types opt-decl-2))) `(:vars ,vars :var-types ,var-types :vals ,(first vals-list) :form ,pruned-form :decls1 ,opt-decl-1 :decls2 ,opt-decl-2 :optimized-lambda-form ,optimized-lambda-form :unoptimized-lambda-form ,unoptimized-lambda-form)))) ;;; ;;; The call (PRUNE form try-fn) attempts to simplify the lisp form ;;; so that it still satisfies TRY-FN. The function TRY-FN should ;;; return if the substitution is a failure. Otherwise, it should ;;; transfer control elsewhere via GO, THROW, etc. ;;; ;;; The return value of PRUNE should be ignored. ;;; (defun prune (form try-fn) (declare (type function try-fn)) (when (gethash form *prune-table*) (return-from prune nil)) (flet ((try (x) (funcall try-fn x))) (cond ((keywordp form) nil) ((integerp form) (unless (zerop form) (try 0))) ((consp form) (let* ((op (car form)) (args (cdr form)) (nargs (length args))) (case op ((quote) nil) ((go) (try 0)) ((signum integer-length logcount logandc1 logandc2 lognand lognor logorc1 logorc2 realpart imagpart) (try 0) (mapc try-fn args) (prune-fn form try-fn)) ((make-array) (when (and (eq (car args) nil) (eq (cadr args) ':initial-element) ; (null (cdddr args)) ) (prune (caddr args) #'(lambda (form) (try `(make-array nil :initial-element ,form . ,(cdddr args))))) (when (cdddr args) (try `(make-array nil :initial-element ,(caddr args)))) )) ((cons) (prune-fn form try-fn)) ((dotimes) (try 0) (let* ((binding-form (first args)) (body (rest args)) (var (first binding-form)) (count-form (second binding-form)) (result (third binding-form))) (try result) (unless (eql count-form 0) (try `(dotimes (,var 0 ,result) ,@body))) (prune result #'(lambda (form) (try `(dotimes (,var ,count-form ,form) ,@body)))) (when (= (length body) 1) (prune (first body) #'(lambda (form) (when (consp form) (try `(dotimes (,var ,count-form ,result) ,form)))))))) ((abs 1+ 1-) (try 0) (mapc try-fn args) (prune-fn form try-fn)) ((identity values ignore-errors cl:handler-case restart-case locally) (unless (and (consp args) (consp (car args)) (eql (caar args) 'tagbody)) (mapc try-fn args)) (prune-fn form try-fn)) ((boole) (try (second args)) (try (third args)) (prune (second args) #'(lambda (form) (try `(boole ,(first args) ,form ,(third args))))) (prune (third args) #'(lambda (form) (try `(boole ,(first args) ,(second args) ,form))))) ((unwind-protect prog1 multiple-value-prog1) (try (first args)) (let ((val (first args)) (rest (rest args))) (when rest (try `(unwind-protect ,val)) (when (cdr rest) (loop for i from 0 below (length rest) do (try `(unwind-protect ,val ,@(subseq rest 0 i) ,@(subseq rest (1+ i)))))))) (prune-fn form try-fn)) ((prog2) (assert (>= (length args) 2)) (let ((val1 (first args)) (arg2 (second args)) (rest (cddr args))) (try arg2) (prune-fn form try-fn) (when rest (try `(prog2 ,val1 ,arg2)) (when (cdr rest) (loop for i from 0 below (length rest) do (try `(prog2 ,val1 ,arg2 ,@(subseq rest 0 i) ,@(subseq rest (1+ i))))))))) ((typep) (try (car args)) (prune (car args) #'(lambda (form) `(,op ,form ,@(cdr args))))) ((load-time-value) (let ((arg (first args))) (try arg) (cond ((cdr args) (try `(load-time-value ,arg)) (prune arg #'(lambda (form) (try `(load-time-value ,form ,(second args)))))) (t (prune arg #'(lambda (form) (try `(load-time-value ,form)))))))) ((eval) (try 0) (let ((arg (first args))) (cond ((consp arg) (cond ((eql (car arg) 'quote) (prune (cadr arg) #'(lambda (form) (try `(eval ',form))))) (t (try arg) (prune arg #'(lambda (form) `(eval ,form)))))) (t (try arg))))) ((the macrolet cl:handler-bind restart-bind) (assert (= (length args) 2)) (try (second args)) (prune (second args) try-fn)) ((not eq eql equal) (when (every #'constantp args) (try (eval form))) (try t) (try nil) (mapc try-fn args) (prune-fn form try-fn) ) ((and or = < > <= >= /=) (when (every #'constantp args) (try (eval form))) (try t) (try nil) (mapc try-fn args) (prune-nary-fn form try-fn) (prune-fn form try-fn)) ((- + * min max logand logior logxor logeqv gcd lcm) (when (every #'constantp args) (try (eval form))) (try 0) (mapc try-fn args) (prune-nary-fn form try-fn) (prune-fn form try-fn)) ((/) (when (every #'constantp args) (try (eval form))) (try 0) (try (car args)) (when (cddr args) (prune (car args) #'(lambda (form) (try `(/ ,form ,(second args))))))) ((multiple-value-call) ;; Simplify usual case (when (= nargs 2) (destructuring-bind (arg1 arg2) args (when (and (consp arg1) (consp arg2) (eql (first arg1) 'function) (eql (first arg2) 'values)) (mapc try-fn (rest arg2)) (let ((fn (second arg1))) (when (symbolp fn) (try `(,fn ,@(rest arg2))))) ;; Prune the VALUES form (prune-list (rest arg2) #'prune #'(lambda (args) (try `(multiple-value-call ,arg1 (values ,@args))))) ))) (mapc try-fn (rest args))) ((bit sbit elt aref svref) (try 0) (when (= (length args) 2) (let ((arg1 (car args)) (arg2 (cadr args))) (when (and (consp arg2) (eql (car arg2) 'min) (integerp (cadr arg2))) (let ((arg2.2 (caddr arg2))) (when (and (consp arg2.2) (eql (car arg2.2) 'max) (integerp (cadr arg2.2))) (prune (caddr arg2.2) #'(lambda (form) (try `(,op ,arg1 (min ,(cadr arg2) (max ,(cadr arg2.2) ,form)))))))))))) ((car cdr) (try 0) (try 1)) ((if) (let (;; (pred (first args)) (then (second args)) (else (third args))) (try then) (try else) (when (every #'constantp args) (try (eval form))) (prune-fn form try-fn))) ((setq setf shiftf) (try 0) ;; Assumes only one assignment (assert (= (length form) 3)) (try (second args)) (unless (integerp (second args)) (prune (second args) #'(lambda (form) (try `(,op ,(first args) ,form)))))) ((multiple-value-setq) (try 0) ;; Assumes only one assignment, and one variable (assert (= (length form) 3)) (assert (= (length (first args)) 1)) (try `(setq ,(caar args) ,(cadr args))) (unless (integerp (second args)) (prune (second args) #'(lambda (form) (try `(,op ,(first args) ,form)))))) ((byte) (prune-fn form try-fn)) ((deposit-field dpb) (try 0) (destructuring-bind (a1 a2 a3) args (try a1) (try a3) (when (and (integerp a1) (integerp a3) (and (consp a2) (eq (first a2) 'byte) (integerp (second a2)) (integerp (third a2)))) (try (eval form)))) (prune-fn form try-fn)) ((ldb mask-field) (try 0) (try (second args)) (when (and (consp (first args)) (eq 'byte (first (first args))) (every #'numberp (cdr (first args))) (numberp (second args))) (try (eval form))) (prune-fn form try-fn)) ((ldb-test) (try t) (try nil) (prune-fn form try-fn)) ((let let*) (prune-let form try-fn)) ((multiple-value-bind) (assert (= (length args) 3)) (let ((arg1 (first args)) (arg2 (second args)) (body (caddr args))) (when (= (length arg1) 1) (try `(let ((,(first arg1) ,arg2)) ,body))) (prune arg2 #'(lambda (form) (try `(multiple-value-bind ,arg1 ,form ,body)))) (prune body #'(lambda (form) (try `(multiple-value-bind ,arg1 ,arg2 ,form)))))) ((block) (let ((name (second form)) (body (cddr form))) (when (and body (null (cdr body))) (let ((form1 (first body))) ;; Try removing the block entirely if it is not in use (when (not (find-in-tree name body)) (try form1)) ;; Try removing the block if its only use is an immediately ;; enclosed return-from: (block (return-from )) (when (and (consp form1) (eq (first form1) 'return-from) (eq (second form1) name) (not (find-in-tree name (third form1)))) (try (third form1))) ;; Otherwise, try to simplify the subexpression (prune form1 #'(lambda (x) (try `(block ,name ,x)))))))) ((catch) (let* ((tag (second form)) (name (if (consp tag) (cadr tag) tag)) (body (cddr form))) (when (and body (null (cdr body))) (let ((form1 (first body))) ;; Try removing the catch entirely if it is not in use ;; We make assumptions here about what throws can ;; be present. (when (or (not (find-in-tree 'throw body)) (not (find-in-tree name body))) (try form1)) ;; Try removing the block if its only use is an immediately ;; enclosed return-from: (block (return-from )) (when (and (consp form1) (eq (first form1) 'throw) (equal (second form1) name) (not (find-in-tree name (third form1)))) (try (third form1))) ;; Otherwise, try to simplify the subexpression (prune form1 #'(lambda (x) (try `(catch ,tag ,x)))))))) ((throw) (try (second args)) (prune (second args) #'(lambda (x) (try `(throw ,(first args) ,x))))) ((flet labels) (try 0) (prune-flet form try-fn)) ((case) (prune-case form try-fn)) ((isqrt) (let ((arg (second form))) (assert (null (cddr form))) (assert (consp arg)) (assert (eq (first arg) 'abs)) (let ((arg2 (second arg))) (try arg2) ;; Try to fold (when (integerp arg2) (try (isqrt (abs arg2)))) ;; Otherwise, simplify arg2 (prune arg2 #'(lambda (form) (try `(isqrt (abs ,form)))))))) ((ash) (try 0) (let ((form1 (second form)) (form2 (third form))) (try form1) (try form2) (prune form1 #'(lambda (form) (try `(ash ,form ,form2)))) (when (and (consp form2) (= (length form2) 3)) (when (and (integerp form1) (eq (first form2) 'min) (every #'integerp (cdr form2))) (try (eval form))) (let ((form3 (third form2))) (prune form3 #'(lambda (form) (try `(ash ,form1 (,(first form2) ,(second form2) ,form))))))))) ((floor ceiling truncate round mod rem) (try 0) (let ((form1 (second form)) (form2 (third form))) (try form1) (when (cddr form) (try form2)) (prune form1 (if (cddr form) #'(lambda (form) (try `(,op ,form ,form2))) #'(lambda (form) (try `(,op ,form))))) (when (and (consp form2) (= (length form2) 3)) (when (and (integerp form1) (member (first form2) '(max min)) (every #'integerp (cdr form2))) (try (eval form))) (let ((form3 (third form2))) (prune form3 #'(lambda (form) (try `(,op ,form1 (,(first form2) ,(second form2) ,form))))))))) ((constantly) (unless (eql (car args) 0) (prune (car args) #'(lambda (arg) (try `(constantly ,arg)))))) ((funcall) (try 0) (let ((fn (second form)) (fn-args (cddr form))) (mapc try-fn fn-args) (unless (equal fn '(constantly 0)) (try `(funcall (constantly 0) ,@fn-args))) (when (and (consp fn) (eql (car fn) 'function) (symbolp (cadr fn))) (try `(,(cadr fn) ,@fn-args))) (prune-list fn-args #'prune #'(lambda (args) (try `(funcall ,fn ,@args)))))) ((reduce) (try 0) (let ((arg1 (car args)) (arg2 (cadr args)) (rest (cddr args))) (when (and ;; (null (cddr args)) (consp arg1) (eql (car arg1) 'function)) (let ((arg1.2 (cadr arg1))) (when (and (consp arg1.2) (eql (car arg1.2) 'lambda)) (let ((largs (cadr arg1.2)) (body (cddr arg1.2))) (when (null (cdr body)) (prune (car body) #'(lambda (bform) (try `(reduce (function (lambda ,largs ,bform)) ,arg2 ,@rest))))))))) (when (consp arg2) (case (car arg2) ((list vector) (let ((arg2.rest (cdr arg2))) (mapc try-fn arg2.rest) (prune-list arg2.rest #'prune #'(lambda (args) (try `(reduce ,arg1 (,(car arg2) ,@args) ,@rest)))))))))) ((apply) (try 0) (let ((fn (second form)) (fn-args (butlast (cddr form))) (list-arg (car (last form)))) (mapc try-fn fn-args) (unless (equal fn '(constantly 0)) (try `(apply (constantly 0) ,@(cddr form)))) (when (and (consp list-arg) (eq (car list-arg) 'list)) (mapc try-fn (cdr list-arg))) (prune-list fn-args #'prune #'(lambda (args) (try `(apply ,fn ,@args ,list-arg)))) (when (and (consp list-arg) (eq (car list-arg) 'list)) (try `(apply ,fn ,@fn-args ,@(cdr list-arg) nil)) (prune-list (cdr list-arg) #'prune #'(lambda (args) (try `(apply ,fn ,@fn-args (list ,@args)))))))) ((progv) (try 0) (prune-progv form try-fn)) ((tagbody) (try 0) (prune-tagbody form try-fn)) ((progn) (when (null args) (try nil)) (try (car (last args))) (loop for i from 0 below (1- (length args)) for a in args do (try `(progn ,@(subseq args 0 i) ,@(subseq args (1+ i)))) do (when (and (consp a) (or (eq (car a) 'progn) (and (eq (car a) 'tagbody) (every #'consp (cdr a))))) (try `(progn ,@(subseq args 0 i) ,@(copy-list (cdr a)) ,@(subseq args (1+ i)))))) (prune-fn form try-fn)) ((loop) (try 0) (when (and (eql (length args) 6) (eql (elt args 0) 'for) (eql (elt args 2) 'below)) (let ((var (elt args 1)) (count (elt args 3)) (form (elt args 5))) (unless (eql count 0) (try count)) (case (elt args 4) (sum (try `(let ((,(elt args 1) 0)) ,(elt args 5))) (prune form #'(lambda (form) (try `(loop for ,var below ,count sum ,form))))) (count (unless (or (eql form t) (eql form nil)) (try `(loop for ,var below ,count count t)) (try `(loop for ,var below ,count count nil)) (prune form #'(lambda (form) (try `(loop for ,var below ,count count ,form)))))) )))) (otherwise (try 0) (prune-fn form try-fn)) ))))) (setf (gethash form *prune-table*) t) nil) (defun find-in-tree (value tree) "Return true if VALUE is eql to a node in TREE." (or (eql value tree) (and (consp tree) (or (find-in-tree value (car tree)) (find-in-tree value (cdr tree)))))) (defun prune-list (list element-prune-fn list-try-fn) (declare (type function element-prune-fn list-try-fn)) "Utility function for pruning in a list." (loop for i from 0 for e in list do (funcall element-prune-fn e #'(lambda (form) (funcall list-try-fn (append (subseq list 0 i) (list form) (subseq list (1+ i)))))))) (defun prune-case (form try-fn) (declare (type function try-fn)) (flet ((try (e) (funcall try-fn e))) (let* ((op (first form)) (expr (second form)) (cases (cddr form))) ;; Try just the top expression (try expr) ;; Try simplifying the expr (prune expr #'(lambda (form) (try `(,op ,form ,@cases)))) ;; Try individual cases (loop for case in cases do (try (first (last (rest case))))) ;; Try deleting individual cases (loop for i from 0 below (1- (length cases)) do (try `(,op ,expr ,@(subseq cases 0 i) ,@(subseq cases (1+ i))))) ;; Try simplifying the cases ;; Assume each case has a single form (prune-list cases #'(lambda (case try-fn) (declare (type function try-fn)) (when (eql (length case) 2) (prune (cadr case) #'(lambda (form) (funcall try-fn (list (car case) form)))))) #'(lambda (cases) (try `(,op ,expr ,@cases))))))) (defun prune-tagbody (form try-fn) (declare (type function try-fn)) (let (;; (op (car form)) (body (cdr form))) (loop for i from 0 for e in body do (cond ((atom e) ;; A tag (unless (find-in-tree e (subseq body 0 i)) (funcall try-fn `(tagbody ,@(subseq body 0 i) ,@(subseq body (1+ i)))))) (t (funcall try-fn `(tagbody ,@(subseq body 0 i) ,@(subseq body (1+ i)))) (prune e #'(lambda (form) ;; Don't put an atom here. (when (consp form) (funcall try-fn `(tagbody ,@(subseq body 0 i) ,form ,@(subseq body (1+ i)))))))))))) (defun prune-progv (form try-fn) (declare (type function try-fn)) (let (;; (op (car form)) (vars-form (cadr form)) (vals-form (caddr form)) (body-list (cdddr form))) (when (and (null vars-form) (null vals-form)) (funcall try-fn `(let () ,@body-list))) (when (and (consp vals-form) (eql (car vals-form) 'list)) (when (and (consp vars-form) (eql (car vars-form) 'quote)) (let ((vars (cadr vars-form)) (vals (cdr vals-form))) (when (eql (length vars) (length vals)) (let ((let-form `(let () ,@body-list))) (mapc #'(lambda (var val) (setq let-form `(let ((,var ,val)) ,let-form))) vars vals) (funcall try-fn let-form))) ;; Try simplifying the vals forms (prune-list vals #'prune #'(lambda (vals) (funcall try-fn `(progv ,vars-form (list ,@vals) ,@body-list))))))) ;; Try simplifying the body (when (eql (length body-list) 1) (prune (car body-list) #'(lambda (form) (funcall try-fn `(progv ,vars-form ,vals-form ,form))))))) (defun prune-nary-fn (form try-fn) ;; Attempt to reduce the number of arguments to the fn ;; Do not reduce below 1 (declare (type function try-fn)) (let* ((op (car form)) (args (cdr form)) (nargs (length args))) (when (> nargs 1) (loop for i from 1 to nargs do (funcall try-fn `(,op ,@(subseq args 0 (1- i)) ,@(subseq args i))))))) (defun prune-fn (form try-fn) "Attempt to simplify a function call form. It is considered acceptable to replace the call by one of its argument forms." (declare (type function try-fn)) (prune-list (cdr form) #'prune #'(lambda (args) (funcall try-fn (cons (car form) args))))) (defun prune-let (form try-fn) "Attempt to simplify a LET form." (declare (type function try-fn)) (let* ((op (car form)) (binding-list (cadr form)) (body (cddr form)) ;; (body-len (length body)) ;; (len (length binding-list)) ) ;; Try to simplify (let (( )) ...) to #| (when (and (>= len 1) ;; (eql body-len 1) ;; (eql (caar binding-list) (car body)) ) (let ((val-form (cadar binding-list))) (unless (and (consp val-form) (eql (car val-form) 'make-array)) (funcall try-fn val-form)))) |# ;; Try to simplify the forms in the RHS of the bindings (prune-list binding-list #'(lambda (binding try-fn) (declare (type function try-fn)) (prune (cadr binding) #'(lambda (form) (funcall try-fn (list (car binding) form))))) #'(lambda (bindings) (funcall try-fn `(,op ,bindings ,@body)))) ;; Try to simplify the body of the LET form (when body (unless binding-list (funcall try-fn (car (last body)))) (when (and (first binding-list) (not (rest binding-list)) (not (rest body))) (let ((binding (first binding-list))) (unless (or (consp (second binding)) (has-binding-to-var (first binding) body) (has-assignment-to-var (first binding) body) ) (funcall try-fn `(let () ,@(subst (second binding) (first binding) (remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare))) body) )))))) (prune (car (last body)) #'(lambda (form2) (funcall try-fn `(,@(butlast form) ,form2))))))) (defun has-assignment-to-var (var form) (find-if-subtree #'(lambda (form) (and (consp form) (or (and (member (car form) '(setq setf shiftf) :test #'eq) (eq (cadr form) var)) (and (eql (car form) 'multiple-value-setq) (member var (cadr form)))))) form)) (defun has-binding-to-var (var form) (find-if-subtree #'(lambda (form) (and (consp form) (case (car form) ((let let*) (loop for binding in (cadr form) thereis (eq (car binding) var))) ((progv) (and (consp (cadr form)) (eq (caadr form) 'quote) (consp (second (cadr form))) (member var (second (cadr form))))) (t nil)))) form)) (defun find-if-subtree (pred tree) (declare (type function pred)) (cond ((funcall pred tree) tree) ((consp tree) (or (find-if-subtree pred (car tree)) (find-if-subtree pred (cdr tree)))) (t nil))) (defun prune-flet (form try-fn) "Attempt to simplify a FLET form." (declare (type function try-fn)) (let* ((op (car form)) (binding-list (cadr form)) (body (cddr form))) ;; Remove a declaration, if any (when (and (consp body) (consp (car body)) (eq (caar body) 'declare)) (funcall try-fn `(,op ,binding-list ,@(cdr body)))) ;; Try to prune optional arguments (prune-list binding-list #'(lambda (binding try-fn) (declare (type function try-fn)) (let* ((name (car binding)) (args (cadr binding)) (body (cddr binding)) (opt-pos (position-if #'(lambda (e) (member e '(&key &optional))) (the list args)))) (when opt-pos (incf opt-pos) (let ((normal-args (subseq args 0 (1- opt-pos))) (optionals (subseq args opt-pos))) (prune-list optionals #'(lambda (opt-lambda-arg try-fn) (declare (type function try-fn)) (when (consp opt-lambda-arg) (let ((name (first opt-lambda-arg)) (form (second opt-lambda-arg))) (prune form #'(lambda (form) (funcall try-fn (list name form))))))) #'(lambda (opt-args) (funcall try-fn `(,name (,@normal-args &optional ,@opt-args) ,@body)))))))) #'(lambda (bindings) (funcall try-fn `(,op ,bindings ,@body)))) ;; Try to simplify the forms in the RHS of the bindings (prune-list binding-list #'(lambda (binding try-fn) (declare (type function try-fn)) ;; Prune body of a binding (prune (third binding) #'(lambda (form) (funcall try-fn (list (first binding) (second binding) form))))) #'(lambda (bindings) (funcall try-fn `(,op ,bindings ,@body)))) ;; ;; Try to simplify the body of the FLET form (when body ;; No bindings -- try to simplify to the last form in the body (unless binding-list (funcall try-fn (first (last body)))) (when (and (consp binding-list) (null (rest binding-list))) (let ((binding (first binding-list))) ;; One binding -- match on (flet (( () )) ()) (when (and (symbolp (first binding)) (not (find-in-tree (first binding) (rest binding))) (null (second binding)) (equal body (list (list (first binding))))) (funcall try-fn `(,op () ,@(cddr binding)))) ;; One binding -- try to remove it if not used (when (and (symbolp (first binding)) (not (find-in-tree (first binding) body))) (funcall try-fn (first (last body)))) )) ;; Try to simplify (the last form in) the body. (prune (first (last body)) #'(lambda (form2) (funcall try-fn `(,@(butlast form) ,form2))))))) ;;; Routine to walk form, applying a function at each form ;;; The fn is applied in preorder. When it returns :stop, do ;;; not descend into subforms #| (defun walk (form fn) (declare (type function fn)) (unless (eq (funcall fn form) :stop) (when (consp form) (let ((op (car form))) (case op ((let let*) (walk-let form fn)) ((cond) (dolist (clause (cdr form)) (walk-implicit-progn clause fn))) ((multiple-value-bind) (walk (third form) fn) (walk-body (cdddr form) fn)) ((function quote declare) nil) ((block the return-from) (walk-implicit-progn (cddr form) fn)) ((case typecase) (walk (cadr form) fn) (dolist (clause (cddr form)) (walk-implicit-progn (cdr clause) fn))) ((flet labels) |# ;;;;;;;;;;;;;;;;;;;;;; ;;; Convert pruned results to test cases (defun produce-test-cases (instances &key (stream *standard-output*) (prefix "MISC.") (index 1)) (dolist (inst instances) (let* (;; (vars (getf inst :vars)) (vals (getf inst :vals)) (optimized-lambda-form (getf inst :optimized-lambda-form)) (unoptimized-lambda-form (getf inst :unoptimized-lambda-form)) (name (intern (concatenate 'string prefix (format nil "~D" index)) "CL-TEST")) (test-form `(deftest ,name (let* ((fn1 ',optimized-lambda-form) (fn2 ',unoptimized-lambda-form) (vals ',vals) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good))) (print test-form stream) (terpri stream) (incf index))) (values)) gcl/ansi-tests/random-intern.lsp000066400000000000000000000032451242227143400172170ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Code to randomly intern and unintern random strings ;;;; in a package. Exercises package and hash table routines (in-package :cl-test) (defconstant +max-len-random-symbol+ 63) (defun make-random-symbol (package) (declare (optimize (speed 3) (safety 3))) (loop (let* ((len (random (1+ +max-len-random-symbol+))) (str (make-string len))) (declare (type (integer 0 #.+max-len-random-symbol+) len)) (loop for i from 0 to (1- len) do (setf (schar str i) (schar +base-chars+ (random +num-base-chars+)))) (multiple-value-bind (symbol status) (intern (copy-seq str) package) (unless (equal str (symbol-name symbol)) (error "Intern gave bad symbol: ~A, ~A~%" str symbol)) (unless status (return symbol)))))) (defun queue-insert (q x) (declare (type cons q)) (push x (cdr q))) (defun queue-remove (q) (declare (type cons q)) (when (null (car q)) (when (null (cdr q)) (error "Attempty to remove from empty queue.~%")) (setf (car q) (nreverse (cdr q))) (setf (cdr q) nil)) (pop (car q))) (defun queue-empty (q) (and (null (car q)) (null (cdr q)))) (defun random-intern (n) (declare (fixnum n)) (let ((q (list nil)) (xp (defpackage "X" (:use)))) (declare (type cons q)) (loop for i from 1 to n do (if (and (= (random 2) 0) (not (queue-empty q))) (unintern (queue-remove q) xp) (queue-insert q (make-random-symbol xp)))))) (defun fill-intern (n) (declare (fixnum n)) (let ((xp (defpackage "X" (:use)))) (loop for i from 1 to n do (make-random-symbol xp)))) gcl/ansi-tests/reader-test.lsp000066400000000000000000000100441242227143400166540ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Apr 8 20:03:45 1998 ;;;; Contains: Tests on readtables (just started, very incomplete) (in-package :cl-test) (declaim (optimize (safety 3))) (deftest readtable-valid (not (readtablep *readtable*)) nil) (deftest readtablep.1 (and (not (readtablep nil)) (not (readtablep 'a)) (not (readtablep 0)) (not (readtablep 1/2)) (not (readtablep 1.2)) (not (readtablep 1.2s2)) (not (readtablep 1.2f3)) (not (readtablep 1.2e2)) (not (readtablep 1.2d2)) (not (readtablep (list 'a))) (not (readtablep "abcde")) (not (readtablep t)) (not (readtablep '*readtable*)) (not (readtablep (make-array '(10)))) (not (readtablep (make-array '(10) :element-type 'fixnum))) (not (readtablep (make-array '(10) :element-type 'float))) (not (readtablep (make-array '(10) :element-type 'double-float))) (not (readtablep (make-array '(10) :element-type 'string))) (not (readtablep (make-array '(10) :element-type 'character))) (not (readtablep (make-array '(10) :element-type 'bit))) (not (readtablep (make-array '(10) :element-type 'boolean))) (not (not (readtablep (copy-readtable)))) (not (readtablep #'car)) ) t) (deftest read-symbol.1 (let ((*package* (find-package "CL-TEST"))) (ignore-errors (read-from-string "a"))) a 1) (deftest read-symbol.2 (let ((*package* (find-package "CL-TEST"))) (ignore-errors (read-from-string "|a|"))) |a| 3) (deftest read-symbol.3 (multiple-value-bind (s n) (ignore-errors (read-from-string "#:abc")) (not (and (symbolp s) (eql n 5) (not (symbol-package s)) (string-equal (symbol-name s) "abc")))) nil) (deftest read-symbol.4 (multiple-value-bind (s n) (ignore-errors (read-from-string "#:|abc|")) (not (and (symbolp s) (eql n 7) (not (symbol-package s)) (string= (symbol-name s) "abc")))) nil) (deftest read-symbol.5 (multiple-value-bind (s n) (ignore-errors (read-from-string "#:||")) (if (not (symbolp s)) s (not (not (and (eql n 4) (not (symbol-package s)) (string= (symbol-name s) "")))))) t) (deftest read-symbol.6 (let ((str "cl-test::abcd0123")) (multiple-value-bind (s n) (ignore-errors (read-from-string str)) (if (not (symbolp s)) s (not (not (and (eql n (length str)) (eqt (symbol-package s) (find-package :cl-test)) (string-equal (symbol-name s) "abcd0123"))))))) t) (deftest read-symbol.7 (multiple-value-bind (s n) (ignore-errors (read-from-string ":ABCD")) (if (not (symbolp s)) s (not (not (and (eql n 5) (eqt (symbol-package s) (find-package "KEYWORD")) (string-equal (symbol-name s) "ABCD")))))) t) (defun read-symbol.9-body (natoms maxlen) (let* ((chars (concatenate 'string "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "0123456789" "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|")) (nchars (length chars))) (loop for i from 1 to natoms count (let* ((len (random (1+ maxlen))) (actual-len 0) (s (make-string (+ 2 (* 2 len)))) (s2 (make-string len))) (loop for j from 0 to (1- len) do (let ((c (elt chars (random (max 1 (1- nchars)))))) (when (member c '(#\| #\\)) (setf (elt s actual-len) #\\) (incf actual-len)) (setf (elt s actual-len) c) (setf (elt s2 j) c) (incf actual-len))) (let ((actual-string (subseq s 0 actual-len))) (multiple-value-bind (sym nread) (ignore-errors (read-from-string (concatenate 'string "#:|" actual-string "|"))) (unless (and (symbolp sym) (eql nread (+ 4 actual-len)) (string-equal s2 (symbol-name sym))) (format t "Symbol read failed: ~S (~S) read as ~S~%" actual-string s2 sym :readably t) t))))))) (deftest read-symbol.9 (read-symbol.9-body 1000 100) 0) (deftest read-symbol.10 (handler-case (not (not (equal (symbol-name (read-from-string (with-output-to-string (s) (write (make-symbol ":") :readably t :stream s)))) ":"))) (error (c) c)) t) gcl/ansi-tests/reduce.lsp000066400000000000000000000262741242227143400157200ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 18 14:08:57 2002 ;;;; Contains: Tests for function REDUCE (in-package :cl-test) (deftest reduce-list.1 (reduce #'cons '(a b c d e f)) (((((a . b) . c) . d) . e) . f)) (deftest reduce-list.2 (reduce #'cons '(a b c d e f) :from-end t) (a b c d e . f)) (deftest reduce-list.3 (reduce #'cons '(a b c d e f) :initial-value 'z) ((((((z . a) . b) . c) . d) . e) . f)) (deftest reduce-list.4 (reduce #'cons '(a b c d e f) :from-end t :initial-value 'g) (a b c d e f . g)) (deftest reduce-list.5 (reduce #'cons '(a b c d e f) :from-end nil) (((((a . b) . c) . d) . e) . f)) (deftest reduce-list.6 (reduce #'cons '(a b c d e f) :from-end 17) (a b c d e . f)) (deftest reduce-list.7 (reduce #'cons '(a b c d e f) :end nil) (((((a . b) . c) . d) . e) . f)) (deftest reduce-list.8 (reduce #'cons '(a b c d e f) :end 3) ((a . b) . c)) (deftest reduce-list.9 (reduce #'cons '(a b c d e f) :start 1 :end 4) ((b . c) . d)) (deftest reduce-list.10 (reduce #'cons '(a b c d e f) :start 1 :end 4 :from-end t) (b c . d)) (deftest reduce-list.11 (reduce #'cons '(a b c d e f) :start 1 :end 4 :from-end t :initial-value nil) (b c d)) (deftest reduce-list.12 (reduce 'cons '(a b c d e f)) (((((a . b) . c) . d) . e) . f)) (deftest reduce-list.13 (reduce #'+ nil) 0) (deftest reduce-list.14 (reduce #'+ '(1 2 3) :start 0 :end 0) 0) (deftest reduce-list.15 (reduce #'+ '(1 2 3) :key '1+) 9) (deftest reduce-list.16 (reduce #'cons '(1 2 3) :key '1+ :from-end t :initial-value nil) (2 3 4)) (deftest reduce-list.17 (reduce #'+ '(1 2 3 4 5 6 7) :key '1+ :start 2 :end 6) 22) ;;;;;;; (deftest reduce-array.1 (reduce #'cons #(a b c d e f)) (((((a . b) . c) . d) . e) . f)) (deftest reduce-array.2 (reduce #'cons #(a b c d e f) :from-end t) (a b c d e . f)) (deftest reduce-array.3 (reduce #'cons #(a b c d e f) :initial-value 'z) ((((((z . a) . b) . c) . d) . e) . f)) (deftest reduce-array.4 (reduce #'cons #(a b c d e f) :from-end t :initial-value 'g) (a b c d e f . g)) (deftest reduce-array.5 (reduce #'cons #(a b c d e f) :from-end nil) (((((a . b) . c) . d) . e) . f)) (deftest reduce-array.6 (reduce #'cons #(a b c d e f) :from-end 17) (a b c d e . f)) (deftest reduce-array.7 (reduce #'cons #(a b c d e f) :end nil) (((((a . b) . c) . d) . e) . f)) (deftest reduce-array.8 (reduce #'cons #(a b c d e f) :end 3) ((a . b) . c)) (deftest reduce-array.9 (reduce #'cons #(a b c d e f) :start 1 :end 4) ((b . c) . d)) (deftest reduce-array.10 (reduce #'cons #(a b c d e f) :start 1 :end 4 :from-end t) (b c . d)) (deftest reduce-array.11 (reduce #'cons #(a b c d e f) :start 1 :end 4 :from-end t :initial-value nil) (b c d)) (deftest reduce-array.12 (reduce 'cons #(a b c d e f)) (((((a . b) . c) . d) . e) . f)) (deftest reduce-array.13 (reduce #'+ #(1 2 3) :start 0 :end 0) 0) (deftest reduce-array.14 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 4))) (reduce #'+ a)) 10) (deftest reduce-array.15 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 4))) (reduce #'+ a :end nil)) 10) (deftest reduce-array.16 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 4))) (reduce #'+ a :from-end t)) 10) (deftest reduce-array.17 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 4))) (reduce #'+ a :initial-value 1)) 11) (deftest reduce-array.18 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 4))) (reduce #'+ a :initial-value 1 :start 2)) 8) (deftest reduce-array.19 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 4))) (reduce #'+ a :end 3)) 6) ;;;;;;;; (deftest reduce.error.1 (classify-error (reduce 'cons 'a)) type-error) (deftest reduce.error.2 (classify-error (reduce)) program-error) (deftest reduce.error.3 (classify-error (reduce #'list nil :start)) program-error) (deftest reduce.error.4 (classify-error (reduce #'list nil 'bad t)) program-error) (deftest reduce.error.5 (classify-error (reduce #'list nil 'bad t :allow-other-keys nil)) program-error) (deftest reduce.error.6 (classify-error (reduce #'list nil 1 2)) program-error) (deftest reduce.error.7 (classify-error (locally (reduce 'cons 'a) t)) type-error) (deftest reduce.error.8 (classify-error (reduce #'identity '(a b c))) program-error) (deftest reduce.error.9 (classify-error (reduce #'cons '(a b c) :key #'cons)) program-error) (deftest reduce.error.10 (classify-error (reduce #'cons '(a b c) :key #'car)) type-error) ;;;;;;;; (deftest reduce-string.1 (reduce #'cons "abcdef") (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) (deftest reduce-string.2 (reduce #'cons "abcdef" :from-end t) (#\a #\b #\c #\d #\e . #\f)) (deftest reduce-string.3 (reduce #'cons "abcdef" :initial-value 'z) ((((((z . #\a) . #\b) . #\c) . #\d) . #\e) . #\f)) (deftest reduce-string.4 (reduce #'cons "abcdef" :from-end t :initial-value 'g) (#\a #\b #\c #\d #\e #\f . g)) (deftest reduce-string.5 (reduce #'cons "abcdef" :from-end nil) (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) (deftest reduce-string.6 (reduce #'cons "abcdef" :from-end 17) (#\a #\b #\c #\d #\e . #\f)) (deftest reduce-string.7 (reduce #'cons "abcdef" :end nil) (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) (deftest reduce-string.8 (reduce #'cons "abcdef" :end 3) ((#\a . #\b) . #\c)) (deftest reduce-string.9 (reduce #'cons "abcdef" :start 1 :end 4) ((#\b . #\c) . #\d)) (deftest reduce-string.10 (reduce #'cons "abcdef" :start 1 :end 4 :from-end t) (#\b #\c . #\d)) (deftest reduce-string.11 (reduce #'cons "abcdef" :start 1 :end 4 :from-end t :initial-value nil) (#\b #\c #\d)) (deftest reduce-string.12 (reduce 'cons "abcdef") (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) (deftest reduce-string.13 (reduce #'+ "abc" :start 0 :end 0) 0) (deftest reduce-string.14 (let ((s (make-array '(8) :initial-contents "abcdefgh" :fill-pointer 6 :element-type 'character))) (coerce (reduce #'(lambda (x y) (cons y x)) s :initial-value nil) 'string)) "fedcba") (deftest reduce-string.15 (let ((s (make-array '(8) :initial-contents "abcdefgh" :fill-pointer 6 :element-type 'character))) (coerce (reduce #'(lambda (x y) (cons y x)) s :initial-value nil :start 1) 'string)) "fedcb") (deftest reduce-string.16 (let ((s (make-array '(8) :initial-contents "abcdefgh" :fill-pointer 6 :element-type 'character))) (coerce (reduce #'(lambda (x y) (cons y x)) s :end nil :initial-value nil) 'string)) "fedcba") (deftest reduce-string.17 (let ((s (make-array '(8) :initial-contents "abcdefgh" :fill-pointer 6 :element-type 'character))) (coerce (reduce #'(lambda (x y) (cons y x)) s :end 4 :initial-value nil) 'string)) "dcba") ;;;;;;;; (deftest reduce-bitstring.1 (reduce #'cons #*001101) (((((0 . 0) . 1) . 1) . 0) . 1)) (deftest reduce-bitstring.2 (reduce #'cons #*001101 :from-end t) (0 0 1 1 0 . 1)) (deftest reduce-bitstring.3 (reduce #'cons #*001101 :initial-value 'z) ((((((z . 0) . 0) . 1) . 1) . 0) . 1)) (deftest reduce-bitstring.4 (reduce #'cons #*001101 :from-end t :initial-value 'g) (0 0 1 1 0 1 . g)) (deftest reduce-bitstring.5 (reduce #'cons #*001101 :from-end nil) (((((0 . 0) . 1) . 1) . 0) . 1)) (deftest reduce-bitstring.6 (reduce #'cons #*001101 :from-end 17) (0 0 1 1 0 . 1)) (deftest reduce-bitstring.7 (reduce #'cons #*001101 :end nil) (((((0 . 0) . 1) . 1) . 0) . 1)) (deftest reduce-bitstring.8 (reduce #'cons #*001101 :end 3) ((0 . 0) . 1)) (deftest reduce-bitstring.9 (reduce #'cons #*001101 :start 1 :end 4) ((0 . 1) . 1)) (deftest reduce-bitstring.10 (reduce #'cons #*001101 :start 1 :end 4 :from-end t) (0 1 . 1)) (deftest reduce-bitstring.11 (reduce #'cons #*001101 :start 1 :end 4 :from-end t :initial-value nil) (0 1 1)) (deftest reduce-bitstring.12 (reduce 'cons #*001101) (((((0 . 0) . 1) . 1) . 0) . 1)) (deftest reduce-bitstring.13 (reduce #'+ #(1 1 1) :start 0 :end 0) 0) (deftest reduce-bitstring.14 (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) :fill-pointer 6 :element-type 'bit))) (reduce #'+ s)) 3) (deftest reduce-bitstring.15 (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) :fill-pointer 6 :element-type 'bit))) (reduce #'+ s :start 3)) 2) (deftest reduce-bitstring.16 (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) :fill-pointer 6 :element-type 'bit))) (reduce #'+ s :start 3 :initial-value 10)) 12) (deftest reduce-bitstring.17 (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) :fill-pointer 6 :element-type 'bit))) (reduce #'+ s :end nil)) 3) (deftest reduce-bitstring.18 (let ((s (make-array '(8) :initial-contents '(1 1 1 1 1 1 1 1) :fill-pointer 6 :element-type 'bit))) (reduce #'+ s :start 2 :end 4)) 2) ;;; Order of evaluation tests (deftest reduce.order.1 (let ((i 0) x y) (values (reduce (progn (setf x (incf i)) #'cons) (progn (setf y (incf i)) '(a b c))) i x y)) ((a . b) . c) 2 1 2) (deftest reduce.order.2 (let ((i 0) a b c d e f g) (values (reduce (progn (setf a (incf i)) #'cons) (progn (setf b (incf i)) '(a b c d e f)) :from-end (progn (setf c (incf i)) t) :initial-value (progn (setf d (incf i)) 'nil) :start (progn (setf e (incf i)) 1) :end (progn (setf f (incf i)) 4) :key (progn (setf g (incf i)) #'identity) ) i a b c d e f g)) (b c d) 7 1 2 3 4 5 6 7) (deftest reduce.order.3 (let ((i 0) a b c d e f g) (values (reduce (progn (setf a (incf i)) #'cons) (progn (setf b (incf i)) '(a b c d e f)) :key (progn (setf c (incf i)) #'identity) :end (progn (setf d (incf i)) 4) :start (progn (setf e (incf i)) 1) :initial-value (progn (setf f (incf i)) 'nil) :from-end (progn (setf g (incf i)) t) ) i a b c d e f g)) (b c d) 7 1 2 3 4 5 6 7) ;;; Keyword tests (deftest reduce.allow-other-keys.1 (reduce #'+ '(1 2 3) :allow-other-keys t) 6) (deftest reduce.allow-other-keys.2 (reduce #'+ '(1 2 3) :allow-other-keys nil) 6) (deftest reduce.allow-other-keys.3 (reduce #'+ '(1 2 3) :bad t :allow-other-keys t) 6) (deftest reduce.allow-other-keys.4 (reduce #'+ '(1 2 3) :allow-other-keys t :bad t) 6) (deftest reduce.allow-other-keys.5 (reduce #'+ '(1 2 3) :allow-other-keys t :allow-other-keys nil :bad t) 6) (deftest reduce.allow-other-keys.6 (reduce #'+ '(1 2 3) :allow-other-keys t :bad t :allow-other-keys nil) 6) (deftest reduce.allow-other-keys.7 (reduce #'+ '(1 2 3) :bad t :allow-other-keys t :allow-other-keys nil) 6) (deftest reduce.allow-other-keys.8 (reduce #'cons '(1 2 3) :allow-other-keys t :from-end t :bad t :initial-value nil) (1 2 3)) (deftest reduce.keywords.9 (reduce #'cons '(1 2 3) :from-end t :from-end nil :initial-value nil :initial-value 'a) (1 2 3)) gcl/ansi-tests/remove-aux.lsp000066400000000000000000000210441242227143400165270ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 15 07:42:36 2002 ;;;; Contains: Auxiliary functions for testing REMOVE and related functions (in-package :cl-test) (defun make-random-element (type) (cond ((subtypep* 'fixnum type) (random most-positive-fixnum)) ((subtypep* '(integer 0 255) type) (random 255)) ((subtypep* '(integer 0 7) type) (random 8)) ((subtypep* 'bit type) (random 2)) ((subtypep* 'symbol type) (elt '(a b c d e f g h) (random 8))) ((subtypep* '(member #\a #\b #\c #\d #\e #\f #\g #\h) type) (elt "abcdefgh" (random 8))) (t (error "Can't get random element of type ~A~%." type)))) (defun make-random-remove-input (len type element-type) "Randomly generate a test case for REMOVE. Given a length a sequence type, and an element type, produce a random sequence of length LEN of sequence type TYPE, and either generate a random member of the sequence or a random element of the element type to delete from the sequence." (let* ((seq (if (subtypep* type 'list) (loop for i from 1 to len collect (make-random-element element-type)) (let ((seq (if (and (subtypep type 'vector) (coin 3)) (make-array (list (+ len (random (1+ len)))) :initial-element (make-random-element element-type) :fill-pointer len :element-type element-type) (make-sequence type len)))) (dotimes (i len) (setf (elt seq i) (make-random-element element-type))) seq))) (e (if (and (> len 0) (coin)) (elt seq (random len)) (make-random-element element-type))) ) (values len seq e))) (defun my-remove (element sequence &key (start 0) (end nil) (test #'eql test-p) (test-not nil test-not-p) (key nil) (from-end nil) (count nil)) (assert (not (and test-p test-not-p))) (my-remove-if (cond (test-p #'(lambda (x) (funcall test element x))) (test-not-p #'(lambda (x) (not (funcall test-not element x)))) (t #'(lambda (x) (eql element x)))) sequence :start start :end end :key key :from-end from-end :count count)) (defun my-remove-if (predicate original-sequence &key (from-end nil) (start 0) (end nil) (count nil) (key #'identity)) (let ((len (length original-sequence)) (sequence (copy-seq original-sequence))) (unless end (setq end len)) (unless key (setq key #'identity)) (unless count (setq count len)) ;; Check that everything's kosher (assert (<= 0 start end len)) (assert (typep sequence 'sequence)) (assert (integerp count)) (assert (or (symbolp predicate) (functionp predicate))) (assert (or (symbolp key) (functionp key))) ;; If FROM-END, reverse the sequence and flip ;; start, end (when from-end (psetq sequence (nreverse sequence) start (- len end) end (- len start))) ;; Accumulate a list of elements for the result (let ((pos 0) (result nil)) ;; accumulate in reverse order (map nil #'(lambda (e) (if (and (> count 0) (>= pos start) (< pos end) (funcall predicate (funcall key e))) (decf count) (push e result)) (incf pos)) sequence) (unless from-end (setq result (nreverse result))) ;; Convert to the correct type (if (listp sequence) result (let ((element-type (array-element-type original-sequence))) (make-array (length result) :element-type element-type :initial-contents result)))))) (defun my-remove-if-not (pred &rest args) (when (symbolp pred) (setq pred (coerce pred 'function))) (assert (typep pred 'function)) (apply #'my-remove-if (complement pred) args)) (defun make-random-rd-params (maxlen) "Generate random paramaters for remove/delete/etc. functions." (let* ((element-type t) (type-select (random 7)) (type (case type-select (0 'list) (1 'vector) (2 (setq element-type 'character) 'string) (3 (setq element-type 'bit) 'bit-vector) (4 'simple-vector) (5 (setq element-type '(integer 0 255)) '(vector (integer 0 255))) (6 (setq element-type 'fixnum) '(vector fixnum)) (t (error "Can't happen?!~%")))) (len (random maxlen)) (start (and (coin) (> len 0) (random len))) (end (and (coin) (if start (+ start (random (- len start))) (random (1+ len))))) (from-end (coin)) (count (case (random 5) ((0 1) nil) ((2 3) (random (1+ len))) (t (if (coin) -1 -10000000000000)))) (seq (multiple-value-bind (x y z) (make-random-remove-input len type element-type) (declare (ignore x z)) y)) (key (and (coin) (case type-select (2 (random-case #'char-upcase 'char-upcase #'char-downcase 'char-downcase)) (3 #'(lambda (x) (- 1 x))) ((5 6) (random-case #'1+ '1+ #'1- '1-)) (t (random-case 'identity #'identity))))) (test (and (eql (random 3) 0) (random-case 'eq 'eql 'equal #'eq #'eql #'equal))) (test-not (and (not test) (coin) (random-case 'eq 'eql 'equal #'eq #'eql #'equal))) ) ;; Return parameters (values element-type type len start end from-end count seq key test test-not))) (defun random-test-remove-args (maxlen) (multiple-value-bind (element-type type len start end from-end count seq key test test-not) (make-random-rd-params maxlen) (declare (ignore type)) (let ((element (if (and (coin) (> len 0)) (random-from-seq seq) (make-random-element element-type))) (arg-list (reduce #'nconc (random-permute (list (when start (list :start start)) (cond (end (list :end end)) ((coin) (list :end nil))) (cond (from-end (list :from-end from-end)) ((coin) (list :from-end nil))) (cond (count (list :count count)) ((coin) (list :count nil))) (cond (key (list :key key)) ;; ((coin) (list :key nil)) ) (when test (list :test test)) (when test-not (list :test test-not))))))) (values element seq arg-list)))) (defparameter *remove-fail-args* nil) (defun random-test-remove (maxlen &key (tested-fn #'remove) (check-fn #'my-remove) (pure t)) (multiple-value-bind (element seq arg-list) (random-test-remove-args maxlen) (let* ((seq1 (copy-seq seq)) (seq2 (copy-seq seq)) (seq1r (apply tested-fn element seq1 arg-list)) (seq2r (apply check-fn element seq2 arg-list))) (setq *remove-fail-args* (list* element seq1 arg-list)) (cond ((and pure (not (equalp seq seq1))) :fail1) ((and pure (not (equalp seq seq2))) :fail2) ((not (equalp seq1r seq2r)) :fail3) (t t))))) (defun random-test-remove-if (maxlen &optional (negate nil)) (multiple-value-bind (element seq arg-list) (random-test-remove-args maxlen) (let ((fn (getf arg-list :key)) (test (getf arg-list :test))) (remf arg-list :key) (remf arg-list :test) (remf arg-list :test-not) (unless test (setq test #'eql)) (if fn (case (random 3) (0 (setf arg-list (list* :key 'identity arg-list))) (1 (setf arg-list (list* :key #'identity arg-list))) (t nil)) (setf fn (if (coin) 'identity #'(lambda (x) (funcall test element x))))) (let* ((seq1 (copy-seq seq)) (seq2 (copy-seq seq)) (seq1r (apply (if negate #'remove-if-not #'remove-if) fn seq1 arg-list)) (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) fn seq2 arg-list))) (setq *remove-fail-args* (cons seq1 arg-list)) (cond ((not (equalp seq seq1)) :fail1) ((not (equalp seq seq2)) :fail2) ((not (equalp seq1r seq2r)) :fail3) (t t)))))) (defun random-test-delete (maxlen) (random-test-remove maxlen :tested-fn #'delete :pure nil)) (defun random-test-delete-if (maxlen &optional (negate nil)) (multiple-value-bind (element seq arg-list) (random-test-remove-args maxlen) (let ((fn (getf arg-list :key)) (test (getf arg-list :test))) (remf arg-list :key) (remf arg-list :test) (remf arg-list :test-not) (unless test (setq test #'eql)) (if fn (case (random 3) (0 (setf arg-list (list* :key 'identity arg-list))) (1 (setf arg-list (list* :key #'identity arg-list))) (t nil)) (setf fn (if (coin) 'identity #'(lambda (x) (funcall test element x))))) (setq *remove-fail-args* (list* seq arg-list)) (let* ((seq1 (copy-seq seq)) (seq2 (copy-seq seq)) (seq1r (apply (if negate #'delete-if-not #'delete-if) fn seq1 arg-list)) (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) fn seq2 arg-list))) (cond ((not (equalp seq1r seq2r)) :fail3) (t t)))))) gcl/ansi-tests/remove-duplicates-aux.lsp000066400000000000000000000056511242227143400206700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 23 20:59:10 2002 ;;;; Contains: Aux. functions for testing REMOVE-DUPLICATES/DELETE-DUPLICATES (in-package :cl-test) (defun my-remove-duplicates (orig-sequence &key from-end test test-not (start 0) end key) (assert (typep orig-sequence 'sequence)) (let* ((sequence orig-sequence) (len (length sequence))) (unless end (setq end len)) (unless key (setq key #'identity)) (cond (test (assert (not test-not))) (test-not (setq test #'(lambda (x y) (not (funcall test x y))))) (t (setq test #'eql))) (assert (integerp start)) (assert (integerp end)) (assert (<= 0 start end len)) ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len) (if from-end (psetq start (- len end) end (- len start) sequence (reverse sequence)) (setq sequence (copy-seq sequence))) ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len) (assert (<= 0 start end len) (start end len)) (let ((result nil)) (loop for i from 0 below start do (push (elt sequence i) result)) (loop for i from start below end for x = (elt sequence i) for kx = (if key (funcall key x) x) unless (position kx sequence :start (1+ i) :end end :test test :key key) do (push x result)) (loop for i from end below len do (push (elt sequence i) result)) (unless from-end (setq result (reverse result))) (cond ((listp orig-sequence) result) ((arrayp orig-sequence) (make-array (length result) :initial-contents result :element-type (array-element-type orig-sequence))) (t (assert nil)))))) (defun make-random-rdup-params (maxlen) "Make random input parameters for REMOVE-DUPLICATES." (multiple-value-bind (element-type type len start end from-end count seq key test test-not) (make-random-rd-params maxlen) (declare (ignore count element-type)) (let ((arg-list (reduce #'nconc (random-permute (list (when start (list :start start)) (cond (end (list :end end)) ((coin) (list :end nil))) (cond (from-end (list :from-end from-end)) ((coin) (list :from-end nil))) (cond (key (list :key key)) ;; ((coin) (list :key nil)) ) (when test (list :test test)) (when test-not (list :test test-not))))))) (values seq arg-list)))) (defun random-test-remove-dups (maxlen &optional (pure t)) (multiple-value-bind (seq arg-list) (make-random-rdup-params maxlen) (let* ((seq1 (copy-seq seq)) (seq2 (copy-seq seq)) (seq1r (apply (if pure #'remove-duplicates #'delete-duplicates) seq1 arg-list)) (seq2r (apply #'my-remove-duplicates seq2 arg-list))) (cond ((and pure (not (equalp seq seq1))) :fail1) ((and pure (not (equalp seq seq2))) :fail2) ((not (equalp seq1r seq2r)) :fail3) (t t))))) gcl/ansi-tests/remove-duplicates.lsp000066400000000000000000000161341242227143400200730ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 29 20:49:47 2002 ;;;; Contains: Tests for REMOVE-DUPLICATES, DELETE-DUPLICATES (in-package :cl-test) (deftest random-remove-duplicates (loop for i from 1 to 5000 always (random-test-remove-dups 20)) t) (deftest random-delete-duplicates (loop for i from 1 to 5000 always (random-test-remove-dups 20 nil)) t) ;;; Look for :KEY NIL bugs (deftest remove-duplicates.1 (let* ((orig '(1 2 3 4 1 3 4 1 2 5 6 2 7)) (x (copy-seq orig)) (y (remove-duplicates x :key nil))) (and (equalp orig x) y)) (3 4 1 5 6 2 7)) (deftest delete-duplicates.1 (let* ((orig '(1 2 3 4 1 3 4 1 2 5 6 2 7)) (x (copy-seq orig)) (y (delete-duplicates x :key nil))) y) (3 4 1 5 6 2 7)) ;;; Order of evaluation tests (deftest remove-duplicates.order.1 (let ((i 0) a b c d e f) (values (remove-duplicates (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) :from-end (progn (setf b (incf i)) nil) :start (progn (setf c (incf i)) 0) :end (progn (setf d (incf i)) nil) :key (progn (setf e (incf i)) #'identity) :test (progn (setf f (incf i)) #'=) ) i a b c d e f)) (3 1 2 4) 6 1 2 3 4 5 6) (deftest remove-duplicates.order.2 (let ((i 0) a b c d e f) (values (remove-duplicates (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) :test-not (progn (setf b (incf i)) #'/=) :key (progn (setf c (incf i)) #'identity) :end (progn (setf d (incf i)) nil) :start (progn (setf e (incf i)) 0) :from-end (progn (setf f (incf i)) nil) ) i a b c d e f)) (3 1 2 4) 6 1 2 3 4 5 6) ;;; Keyword tests (deftest remove-duplicates.allow-other-keys.1 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.2 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.3 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :bad t :allow-other-keys t) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.4 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t :bad t) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.5 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :bad t :allow-other-keys t :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.6 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t :bad t :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.7 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t :allow-other-keys nil :bad t) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.8 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t :from-end t) (1 2 3 4 7 8 5)) (deftest remove-duplicates.keywords.1 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :from-end t :from-end nil) (1 2 3 4 7 8 5)) (deftest delete-duplicates.allow-other-keys.1 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.2 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.3 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :bad t :allow-other-keys t) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.4 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t :bad t) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.5 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :bad t :allow-other-keys t :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.6 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t :bad t :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.7 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t :allow-other-keys nil :bad t) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.8 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t :from-end t) (1 2 3 4 7 8 5)) (deftest delete-duplicates.keywords.1 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :from-end t :from-end nil) (1 2 3 4 7 8 5)) ;;; Order of evaluation tests (deftest delete-duplicates.order.1 (let ((i 0) a b c d e f) (values (delete-duplicates (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) :from-end (progn (setf b (incf i)) nil) :start (progn (setf c (incf i)) 0) :end (progn (setf d (incf i)) nil) :key (progn (setf e (incf i)) #'identity) :test (progn (setf f (incf i)) #'=) ) i a b c d e f)) (3 1 2 4) 6 1 2 3 4 5 6) (deftest delete-duplicates.order.2 (let ((i 0) a b c d e f) (values (delete-duplicates (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) :test-not (progn (setf b (incf i)) #'/=) :key (progn (setf c (incf i)) #'identity) :end (progn (setf d (incf i)) nil) :start (progn (setf e (incf i)) 0) :from-end (progn (setf f (incf i)) nil) ) i a b c d e f)) (3 1 2 4) 6 1 2 3 4 5 6) ;;; Error cases (deftest remove-duplicates.error.1 (classify-error (remove-duplicates)) program-error) (deftest remove-duplicates.error.2 (classify-error (remove-duplicates nil :start)) program-error) (deftest remove-duplicates.error.3 (classify-error (remove-duplicates nil 'bad t)) program-error) (deftest remove-duplicates.error.4 (classify-error (remove-duplicates nil 'bad t :allow-other-keys nil)) program-error) (deftest remove-duplicates.error.5 (classify-error (remove-duplicates nil 1 2)) program-error) (deftest remove-duplicates.error.6 (classify-error (remove-duplicates (list 'a 'b 'c) :test #'identity)) program-error) (deftest remove-duplicates.error.7 (classify-error (remove-duplicates (list 'a 'b 'c) :test-not #'identity)) program-error) (deftest remove-duplicates.error.8 (classify-error (remove-duplicates (list 'a 'b 'c) :key #'cons)) program-error) (deftest remove-duplicates.error.9 (classify-error (remove-duplicates (list 'a 'b 'c) :key #'car)) type-error) ;;; (deftest delete-duplicates.error.1 (classify-error (delete-duplicates)) program-error) (deftest delete-duplicates.error.2 (classify-error (delete-duplicates nil :start)) program-error) (deftest delete-duplicates.error.3 (classify-error (delete-duplicates nil 'bad t)) program-error) (deftest delete-duplicates.error.4 (classify-error (delete-duplicates nil 'bad t :allow-other-keys nil)) program-error) (deftest delete-duplicates.error.5 (classify-error (delete-duplicates nil 1 2)) program-error) (deftest delete-duplicates.error.6 (classify-error (delete-duplicates (list 'a 'b 'c) :test #'identity)) program-error) (deftest delete-duplicates.error.7 (classify-error (delete-duplicates (list 'a 'b 'c) :test-not #'identity)) program-error) (deftest delete-duplicates.error.8 (classify-error (delete-duplicates (list 'a 'b 'c) :key #'cons)) program-error) (deftest delete-duplicates.error.9 (classify-error (delete-duplicates (list 'a 'b 'c) :key #'car)) type-error)gcl/ansi-tests/remove.lsp000066400000000000000000000501071242227143400157360ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 14 11:46:05 2002 ;;;; Contains: Tests for REMOVE (in-package :cl-test) (deftest remove-list.1 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :count nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.3 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :key nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.4 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :count 100))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.5 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :count 0))) (and (equalp orig x) y)) (a b c a b d a c b a e)) (deftest remove-list.6 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :count 1))) (and (equalp orig x) y)) (b c a b d a c b a e)) (deftest remove-list.7 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'c x :count 1))) (and (equalp orig x) y)) (a b a b d a c b a e)) (deftest remove-list.8 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :from-end t))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.9 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :from-end t :count 1))) (and (equalp orig x) y)) (a b c a b d a c b e)) (deftest remove-list.10 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :from-end t :count 4))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.11 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig))) (values (loop for i from 0 to 10 collect (remove 'a x :start i)) (equalp orig x))) ((b c b d c b e) (a b c b d c b e) (a b c b d c b e) (a b c b d c b e) (a b c a b d c b e) (a b c a b d c b e) (a b c a b d c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b a e)) t) (deftest remove-list.12 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig))) (values (loop for i from 0 to 10 collect (remove 'a x :start i :end nil)) (equalp orig x))) ((b c b d c b e) (a b c b d c b e) (a b c b d c b e) (a b c b d c b e) (a b c a b d c b e) (a b c a b d c b e) (a b c a b d c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b a e)) t) (deftest remove-list.13 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig))) (values (loop for i from 0 to 10 collect (remove 'a x :start i :end 11)) (equalp orig x))) ((b c b d c b e) (a b c b d c b e) (a b c b d c b e) (a b c b d c b e) (a b c a b d c b e) (a b c a b d c b e) (a b c a b d c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b a e)) t) (deftest remove-list.14 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :end nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.15 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig))) (values (loop for i from 0 to 9 collect (remove 'a x :start i :end 9)) (equalp orig x))) ((b c b d c b a e) (a b c b d c b a e) (a b c b d c b a e) (a b c b d c b a e) (a b c a b d c b a e) (a b c a b d c b a e) (a b c a b d c b a e) (a b c a b d a c b a e) (a b c a b d a c b a e) (a b c a b d a c b a e)) t) (deftest remove-list.16 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig))) (values (loop for i from 0 to 10 collect (remove 'a x :start i :end 11 :count 1)) (equalp orig x))) ((b c a b d a c b a e) (a b c b d a c b a e) (a b c b d a c b a e) (a b c b d a c b a e) (a b c a b d c b a e) (a b c a b d c b a e) (a b c a b d c b a e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b a e)) t) (deftest remove-list.17 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig))) (values (loop for i from 0 to 10 collect (remove 'a x :start i :end (1+ i))) (equalp orig x))) (( b c a b d a c b a e) (a b c a b d a c b a e) (a b c a b d a c b a e) (a b c b d a c b a e) (a b c a b d a c b a e) (a b c a b d a c b a e) (a b c a b d c b a e) (a b c a b d a c b a e) (a b c a b d a c b a e) (a b c a b d a c b e) (a b c a b d a c b a e)) t) ;;; Show that it tests using EQL, not EQ (deftest remove-list.18 (let* ((i (1+ most-positive-fixnum)) (orig (list i 0 i 1 i 2 3)) (x (copy-seq orig)) (y (remove (1+ most-positive-fixnum) x))) (and (equalp orig x) y)) (0 1 2 3)) (deftest remove-list.19 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 1 x :key #'1-))) (and (equalp orig x) y)) (1 3 6 1 4 1 3 7)) (deftest remove-list.20 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :test #'>))) (and (equalp orig x) y)) (3 6 4 3 7)) (deftest remove-list.21 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :test '> :from-end t))) (and (equalp orig x) y)) (3 6 4 3 7)) (deftest remove-list.22 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 2 x :key nil))) (and (equalp orig x) y)) (1 3 6 1 4 1 3 7)) (deftest remove-list.23 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 1 x :key '1-))) (and (equalp orig x) y)) (1 3 6 1 4 1 3 7)) (deftest remove-list.24 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :test-not #'<=))) (and (equalp orig x) y)) (3 6 4 3 7)) (deftest remove-list.25 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :test-not '<= :from-end t))) (and (equalp orig x) y)) (3 6 4 3 7)) (deftest remove-list.26 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :from-end t :start 1 :end 5))) (and (equalp orig x) y)) (1 2 2 6 1 2 4 1 3 2 7)) (deftest remove-list.27 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :count -1))) (and (equalp orig x) (equalpt x y))) t) (deftest remove-list.28 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :count -1000000000000))) (and (equalp orig x) (equalpt x y))) t) (deftest remove-list.29 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :count 1000000000000))) (and (equalp orig x) y)) (1 2 2 6 1 2 4 1 2 7)) ;;; Assorted tests of remove and delete on vectors, strings, ;;; and bit vectors. These are mostly to exercise bugs previously ;;; detected by the randomized tests (deftest remove-vector.1 (remove 'a (vector 'b 'c 'd)) #(b c d)) (deftest remove-vector.2 (remove 'a (vector 'b 'c 'd) :count -1) #(b c d)) (deftest remove-vector.3 (remove 'a (vector 'a 'b 'c 'd) :count -1) #(a b c d)) (deftest remove-string.1 (remove #\a (copy-seq "abcad")) "bcd") (deftest remove-string.2 (remove #\a (copy-seq "abcad") :count -1) "abcad") (deftest remove-string.3 (remove #\a (copy-seq "bcd") :count -1) "bcd") (deftest delete-vector.1 (delete 'a (vector 'b 'c 'd)) #(b c d)) (deftest delete-vector.2 (delete 'a (vector 'b 'c 'd) :count -1) #(b c d)) (deftest delete-vector.3 (delete 'a (vector 'a 'b 'c 'd) :count -1) #(a b c d)) (deftest delete-string.1 (delete #\a (copy-seq "abcad")) "bcd") (deftest delete-string.2 (delete #\a (copy-seq "abcad") :count -1) "abcad") (deftest delete-string.3 (delete #\a (copy-seq "bcd") :count -1) "bcd") (deftest remove-bit-vector.1 (remove 0 (copy-seq #*00011101101)) #*111111) (deftest remove-bit-vector.2 (remove 0 (copy-seq #*00011101101) :count -1) #*00011101101) (deftest remove-bit-vector.3 (remove 0 (copy-seq #*11111) :count -1) #*11111) (deftest delete-bit-vector.1 (delete 0 (copy-seq #*00011101101)) #*111111) (deftest delete-bit-vector.2 (delete 0 (copy-seq #*00011101101) :count -1) #*00011101101) (deftest delete-bit-vector.3 (delete 0 (copy-seq #*11111) :count -1) #*11111) ;;; Order of evaluation tests (deftest remove.order.1 (let ((i 0) a b c d e f g h) (values (remove (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :from-end (progn (setf c (incf i)) t) :count (progn (setf d (incf i)) 1) :key (progn (setf e (incf i)) #'identity) :test (progn (setf f (incf i)) #'eq) :start (progn (setf g (incf i)) 0) :end (progn (setf h (incf i)) nil)) i a b c d e f g h)) (a b c d f) 8 1 2 3 4 5 6 7 8) (deftest remove.order.2 (let ((i 0) a b c d e f g h) (values (remove (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :end (progn (setf c (incf i)) nil) :start (progn (setf d (incf i)) 0) :test-not (progn (setf e (incf i)) (complement #'eq)) :key (progn (setf f (incf i)) #'identity) :count (progn (setf g (incf i)) 1) :from-end (progn (setf h (incf i)) t) ) i a b c d e f g h)) (a b c d f) 8 1 2 3 4 5 6 7 8) (deftest delete.order.1 (let ((i 0) a b c d e f g h) (values (delete (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :from-end (progn (setf c (incf i)) t) :count (progn (setf d (incf i)) 1) :key (progn (setf e (incf i)) #'identity) :test (progn (setf f (incf i)) #'eq) :start (progn (setf g (incf i)) 0) :end (progn (setf h (incf i)) nil)) i a b c d e f g h)) (a b c d f) 8 1 2 3 4 5 6 7 8) (deftest delete.order.2 (let ((i 0) a b c d e f g h) (values (delete (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :end (progn (setf c (incf i)) nil) :start (progn (setf d (incf i)) 0) :test-not (progn (setf e (incf i)) (complement #'eq)) :key (progn (setf f (incf i)) #'identity) :count (progn (setf g (incf i)) 1) :from-end (progn (setf h (incf i)) t) ) i a b c d e f g h)) (a b c d f) 8 1 2 3 4 5 6 7 8) (deftest remove-if.order.1 (let ((i 0) a b c d e f g) (values (remove-if (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :from-end (progn (setf c (incf i)) t) :count (progn (setf d (incf i)) 1) :key (progn (setf e (incf i)) #'identity) :start (progn (setf f (incf i)) 0) :end (progn (setf g (incf i)) nil)) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest remove-if.order.2 (let ((i 0) a b c d e f g) (values (remove-if (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :end (progn (setf c (incf i)) nil) :start (progn (setf d (incf i)) 0) :key (progn (setf e (incf i)) #'identity) :count (progn (setf f (incf i)) 1) :from-end (progn (setf g (incf i)) t) ) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest delete-if.order.1 (let ((i 0) a b c d e f g) (values (delete-if (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :from-end (progn (setf c (incf i)) t) :count (progn (setf d (incf i)) 1) :key (progn (setf e (incf i)) #'identity) :start (progn (setf f (incf i)) 0) :end (progn (setf g (incf i)) nil)) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest delete-if.order.2 (let ((i 0) a b c d e f g) (values (delete-if (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :end (progn (setf c (incf i)) nil) :start (progn (setf d (incf i)) 0) :key (progn (setf e (incf i)) #'identity) :count (progn (setf f (incf i)) 1) :from-end (progn (setf g (incf i)) t) ) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest remove-if-not.order.1 (let ((i 0) a b c d e f g) (values (remove-if-not (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :from-end (progn (setf c (incf i)) t) :count (progn (setf d (incf i)) 1) :key (progn (setf e (incf i)) #'identity) :start (progn (setf f (incf i)) 0) :end (progn (setf g (incf i)) nil)) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest remove-if-not.order.2 (let ((i 0) a b c d e f g) (values (remove-if-not (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :end (progn (setf c (incf i)) nil) :start (progn (setf d (incf i)) 0) :key (progn (setf e (incf i)) #'identity) :count (progn (setf f (incf i)) 1) :from-end (progn (setf g (incf i)) t) ) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest delete-if-not.order.1 (let ((i 0) a b c d e f g) (values (delete-if-not (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :from-end (progn (setf c (incf i)) t) :count (progn (setf d (incf i)) 1) :key (progn (setf e (incf i)) #'identity) :start (progn (setf f (incf i)) 0) :end (progn (setf g (incf i)) nil)) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest delete-if-not.order.2 (let ((i 0) a b c d e f g) (values (delete-if-not (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :end (progn (setf c (incf i)) nil) :start (progn (setf d (incf i)) 0) :key (progn (setf e (incf i)) #'identity) :count (progn (setf f (incf i)) 1) :from-end (progn (setf g (incf i)) t) ) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) ;;; Randomized tests (deftest remove-random (loop for i from 1 to 2500 unless (eq (random-test-remove 20) t) do (return *remove-fail-args*)) nil) (deftest remove-if-random (loop for i from 1 to 2500 unless (eq (random-test-remove-if 20) t) do (return *remove-fail-args*)) nil) (deftest remove-if-not-random (loop for i from 1 to 2500 unless (eq (random-test-remove-if 20 t) t) do (return *remove-fail-args*)) nil) (deftest delete-random (loop for i from 1 to 2500 unless (eq (random-test-delete 20) t) do (return *remove-fail-args*)) nil) (deftest delete-if-random (loop for i from 1 to 2500 unless (eq (random-test-delete-if 20) t) do (return *remove-fail-args*)) nil) (deftest delete-if-not-random (loop for i from 1 to 2500 unless (eq (random-test-delete-if 20 t) t) do (return *remove-fail-args*)) nil) ;;; Additional tests with KEY = NIL (deftest remove-if-list.1 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove-if #'evenp x :key nil))) (and (equalp orig x) y)) (1 3 1 1 3 7)) (deftest remove-if-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove-if #'(lambda (y) (eqt y 'a)) x :key nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-if-not-list.1 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove-if-not #'oddp x :key nil))) (and (equalp orig x) y)) (1 3 1 1 3 7)) (deftest remove-if-not-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest delete-if-list.1 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (delete-if #'evenp x :key nil))) y) (1 3 1 1 3 7)) (deftest delete-if-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (delete-if #'(lambda (y) (eqt y 'a)) x :key nil))) y) (b c b d c b e)) (deftest delete-if-not-list.1 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (delete-if-not #'oddp x :key nil))) y) (1 3 1 1 3 7)) (deftest delete-if-not-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (delete-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) y) (b c b d c b e)) (deftest delete-list.1 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (delete 'a x :key nil))) y) (b c b d c b e)) (deftest delete-list.2 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (delete 2 x :key nil))) y) (1 3 6 1 4 1 3 7)) ;;; Keyword tests (deftest remove.allow-other-keys.1 (remove 'a '(a b c a d) :allow-other-keys t) (b c d)) (deftest remove.allow-other-keys.2 (remove 'a '(a b c a d) :allow-other-keys nil) (b c d)) (deftest remove.allow-other-keys.3 (remove 'a '(a b c a d) :bad t :allow-other-keys t) (b c d)) (deftest remove.allow-other-keys.4 (remove 'a '(a b c a d) :allow-other-keys t :bad t :bad nil) (b c d)) (deftest remove.allow-other-keys.5 (remove 'a '(a b c a d) :bad1 t :allow-other-keys t :bad2 t :allow-other-keys nil :bad3 t) (b c d)) (deftest remove.allow-other-keys.6 (remove 'a '(a b c a d) :allow-other-keys t :from-end t :count 1) (a b c d)) (deftest remove.keywords.7 (remove 'a '(a b c a d) :from-end t :count 1 :from-end nil :count 10) (a b c d)) (deftest delete.allow-other-keys.1 (delete 'a (copy-seq '(a b c a d)) :allow-other-keys t) (b c d)) (deftest delete.allow-other-keys.2 (delete 'a (copy-seq '(a b c a d)) :allow-other-keys nil) (b c d)) (deftest delete.allow-other-keys.3 (delete 'a (copy-seq '(a b c a d)) :bad t :allow-other-keys t) (b c d)) (deftest delete.allow-other-keys.4 (delete 'a (copy-seq '(a b c a d)) :allow-other-keys t :bad t :bad nil) (b c d)) (deftest delete.allow-other-keys.5 (delete 'a (copy-seq '(a b c a d)) :bad1 t :allow-other-keys t :bad2 t :allow-other-keys nil :bad3 t) (b c d)) (deftest delete.allow-other-keys.6 (delete 'a (copy-seq '(a b c a d)) :allow-other-keys t :from-end t :count 1) (a b c d)) (deftest delete.keywords.7 (delete 'a (copy-seq '(a b c a d)) :from-end t :count 1 :from-end nil :count 10) (a b c d)) ;;; Error cases (deftest remove.error.1 (classify-error (remove)) program-error) (deftest remove.error.2 (classify-error (remove 'a)) program-error) (deftest remove.error.3 (classify-error (remove 'a nil :key)) program-error) (deftest remove.error.4 (classify-error (remove 'a nil 'bad t)) program-error) (deftest remove.error.5 (classify-error (remove 'a nil 'bad t :allow-other-keys nil)) program-error) (deftest remove.error.6 (classify-error (remove 'a nil 1 2)) program-error) (deftest remove.error.7 (classify-error (remove 'a (list 'a 'b 'c) :test #'identity)) program-error) (deftest remove.error.8 (classify-error (remove 'a (list 'a 'b 'c) :test-not #'identity)) program-error) (deftest remove.error.9 (classify-error (remove 'a (list 'a 'b 'c) :key #'cons)) program-error) (deftest remove.error.10 (classify-error (remove 'a (list 'a 'b 'c) :key #'car)) type-error) ;;; (deftest delete.error.1 (classify-error (delete)) program-error) (deftest delete.error.2 (classify-error (delete 'a)) program-error) (deftest delete.error.3 (classify-error (delete 'a nil :key)) program-error) (deftest delete.error.4 (classify-error (delete 'a nil 'bad t)) program-error) (deftest delete.error.5 (classify-error (delete 'a nil 'bad t :allow-other-keys nil)) program-error) (deftest delete.error.6 (classify-error (delete 'a nil 1 2)) program-error) (deftest delete.error.7 (classify-error (delete 'a (list 'a 'b 'c) :test #'identity)) program-error) (deftest delete.error.8 (classify-error (delete 'a (list 'a 'b 'c) :test-not #'identity)) program-error) (deftest delete.error.9 (classify-error (delete 'a (list 'a 'b 'c) :key #'cons)) program-error) (deftest delete.error.10 (classify-error (delete 'a (list 'a 'b 'c) :key #'car)) type-error) gcl/ansi-tests/replace.lsp000066400000000000000000000377251242227143400160670ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 27 16:11:38 2002 ;;;; Contains: Tests for REPLACE (in-package :cl-test) (deftest replace-list.1 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z)))) (values (eqt x result) result)) t (x y z d e f g)) (deftest replace-list.2 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 1))) (values (eqt x result) result)) t (a x y z e f g)) (deftest replace-list.3 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 4))) (values (eqt x result) result)) t (a b c d x y z)) (deftest replace-list.4 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 5))) (values (eqt x result) result)) t (a b c d e x y)) (deftest replace-list.5 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 6))) (values (eqt x result) result)) t (a b c d e f x)) (deftest replace-list.6 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x #(x y z) :start1 2))) (values (eqt x result) result)) t (a b x y z f g)) (deftest replace-list.7 (replace nil #(x y z)) nil) (deftest replace-list.8 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :end1 1))) (values (eqt x result) result)) t (x b c d e f g)) (deftest replace-list.9 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 3 :end1 4))) (values (eqt x result) result)) t (a b c x e f g)) (deftest replace-list.10 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 0 :end1 5))) (values (eqt x result) result)) t (x y z d e f g)) (deftest replace-list.11 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start2 1))) (values (eqt x result) result)) t (y z c d e f g)) (deftest replace-list.12 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start2 1 :end1 nil))) (values (eqt x result) result)) t (y z c d e f g)) (deftest replace-list.13 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start2 1 :end2 nil))) (values (eqt x result) result)) t (y z c d e f g)) (deftest replace-list.14 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start2 1 :end2 2))) (values (eqt x result) result)) t (y b c d e f g)) (deftest replace-list.15 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) (values (eqt x result) result)) t (a b c d y f g)) (deftest replace-list.16 (let* ((x (copy-seq '(a b c d e f))) (y #(1 2 3)) (result (replace x y :start1 1))) (values (eqt x result) result)) t (a 1 2 3 e f)) (deftest replace-list.17 (let* ((x (copy-seq '(a b c d e f))) (y (make-array '(3) :initial-contents '(1 2 3) :fill-pointer t)) (result (replace x y :start1 1))) (values (eqt x result) result)) t (a 1 2 3 e f)) (deftest replace-list.18 (let* ((x (copy-seq '(a b c d e f))) (y (make-array '(6) :initial-contents '(1 2 3 4 5 6) :fill-pointer 3)) (result (replace x y :start1 1))) (values (eqt x result) result)) t (a 1 2 3 e f)) (deftest replace-list.19 (let* ((x (copy-seq '(a b c d e f))) (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) (values (eqt x result) result)) t (b c d d e f)) (deftest replace-list.20 (let* ((x (copy-seq '(a b c d e f))) (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) (values (eqt x result) result)) t (a a b c e f)) ;;; Tests of vectors (deftest replace-vector.1 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z)))) (values (eqt x result) result)) t #(x y z d e f g)) (deftest replace-vector.2 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 1))) (values (eqt x result) result)) t #(a x y z e f g)) (deftest replace-vector.3 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 4))) (values (eqt x result) result)) t #(a b c d x y z)) (deftest replace-vector.4 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 5))) (values (eqt x result) result)) t #(a b c d e x y)) (deftest replace-vector.5 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 6))) (values (eqt x result) result)) t #(a b c d e f x)) (deftest replace-vector.6 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x '(x y z) :start1 2))) (values (eqt x result) result)) t #(a b x y z f g)) (deftest replace-vector.7 (replace #() #(x y z)) #()) (deftest replace-vector.8 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :end1 1))) (values (eqt x result) result)) t #(x b c d e f g)) (deftest replace-vector.9 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 3 :end1 4))) (values (eqt x result) result)) t #(a b c x e f g)) (deftest replace-vector.10 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 0 :end1 5))) (values (eqt x result) result)) t #(x y z d e f g)) (deftest replace-vector.11 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start2 1))) (values (eqt x result) result)) t #(y z c d e f g)) (deftest replace-vector.12 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start2 1 :end1 nil))) (values (eqt x result) result)) t #(y z c d e f g)) (deftest replace-vector.13 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start2 1 :end2 nil))) (values (eqt x result) result)) t #(y z c d e f g)) (deftest replace-vector.14 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start2 1 :end2 2))) (values (eqt x result) result)) t #(y b c d e f g)) (deftest replace-vector.15 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) (values (eqt x result) result)) t #(a b c d y f g)) (deftest replace-vector.16 (let* ((x (copy-seq #(a b c d e f))) (y '(1 2 3)) (result (replace x y :start1 1))) (values (eqt x result) result)) t #(a 1 2 3 e f)) (deftest replace-vector.17 (let* ((x (copy-seq #(a b c d e f))) (y (make-array '(3) :initial-contents '(1 2 3) :fill-pointer t)) (result (replace x y :start1 1))) (values (eqt x result) result)) t #(a 1 2 3 e f)) (deftest replace-vector.18 (let* ((x (copy-seq #(a b c d e f))) (y (make-array '(6) :initial-contents '(1 2 3 4 5 6) :fill-pointer 3)) (result (replace x y :start1 1))) (values (eqt x result) result)) t #(a 1 2 3 e f)) (deftest replace-vector.19 (let* ((x (copy-seq #(a b c d e f))) (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) (values (eqt x result) result)) t #(b c d d e f)) (deftest replace-vector.21 (let* ((x (copy-seq #(a b c d e f))) (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) (values (eqt x result) result)) t #(a a b c e f)) ;;; tests on bit vectors (deftest replace-bit-vector.1 (let* ((x (copy-seq #*1101001)) (result (replace x #*011))) (values (eqt x result) result)) t #*0111001) (deftest replace-bit-vector.2 (let* ((x (copy-seq #*1101001)) (result (replace x #*011 :start1 1))) (values (eqt x result) result)) t #*1011001) (deftest replace-bit-vector.3 (let* ((x (copy-seq #*1101001)) (result (replace x #*011 :start1 4))) (values (eqt x result) result)) t #*1101011) (deftest replace-bit-vector.4 (let* ((x (copy-seq #*0000000)) (result (replace x #*111 :start1 5))) (values (eqt x result) result)) t #*0000011) (deftest replace-bit-vector.5 (let* ((x (copy-seq #*0000000)) (result (replace x #*100 :start1 6))) (values (eqt x result) result)) t #*0000001) (deftest replace-bit-vector.6 (let* ((x (copy-seq #*0000000)) (result (replace x '(1 1 1) :start1 2))) (values (eqt x result) result)) t #*0011100) (deftest replace-bit-vector.7 (replace #* #*111) #*) (deftest replace-bit-vector.8 (let* ((x (copy-seq #*0000000)) (result (replace x #*111 :end1 1))) (values (eqt x result) result)) t #*1000000) (deftest replace-bit-vector.9 (let* ((x (copy-seq #*0000000)) (result (replace x #*110 :start1 3 :end1 4))) (values (eqt x result) result)) t #*0001000) (deftest replace-bit-vector.10 (let* ((x (copy-seq #*0000000)) (result (replace x #*111 :start1 0 :end1 5))) (values (eqt x result) result)) t #*1110000) (deftest replace-bit-vector.11 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start2 1))) (values (eqt x result) result)) t #*1100000) (deftest replace-bit-vector.12 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start2 1 :end1 nil))) (values (eqt x result) result)) t #*1100000) (deftest replace-bit-vector.13 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start2 1 :end2 nil))) (values (eqt x result) result)) t #*1100000) (deftest replace-bit-vector.14 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start2 1 :end2 2))) (values (eqt x result) result)) t #*1000000) (deftest replace-bit-vector.15 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start1 4 :end1 5 :start2 1 :end2 2))) (values (eqt x result) result)) t #*0000100) (deftest replace-bit-vector.16 (let* ((x (copy-seq #*001011)) (y '(1 0 1)) (result (replace x y :start1 1))) (values (eqt x result) result)) t #*010111) (deftest replace-bit-vector.17 (let* ((x (copy-seq #*001011)) (y (make-array '(3) :initial-contents '(1 0 1) :fill-pointer t :element-type 'bit)) (result (replace x y :start1 1))) (values (eqt x result) result)) t #*010111) (deftest replace-bit-vector.18 (let* ((x (copy-seq #*001011)) (y (make-array '(6) :initial-contents '(1 0 1 0 0 1) :fill-pointer 3 :element-type 'bit)) (result (replace x y :start1 1))) (values (eqt x result) result)) t #*010111) (deftest replace-bit-vector.19 (let* ((x (copy-seq #*001011)) (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) (values (eqt x result) result)) t #*010011) (deftest replace-bit-vector.21 (let* ((x (copy-seq #*001011)) (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) (values (eqt x result) result)) t #*000111) ;;; Tests on strings (deftest replace-string.1 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz"))) (values (eqt x result) result)) t "xyzdefg") (deftest replace-string.2 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 1))) (values (eqt x result) result)) t "axyzefg") (deftest replace-string.3 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 4))) (values (eqt x result) result)) t "abcdxyz") (deftest replace-string.4 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 5))) (values (eqt x result) result)) t "abcdexy") (deftest replace-string.5 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 6))) (values (eqt x result) result)) t "abcdefx") (deftest replace-string.6 (let* ((x (copy-seq "abcdefg")) (result (replace x '(#\x #\y #\z) :start1 2))) (values (eqt x result) result)) t "abxyzfg") (deftest replace-string.7 (replace "" "xyz") "") (deftest replace-string.8 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :end1 1))) (values (eqt x result) result)) t "xbcdefg") (deftest replace-string.9 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 3 :end1 4))) (values (eqt x result) result)) t "abcxefg") (deftest replace-string.10 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 0 :end1 5))) (values (eqt x result) result)) t "xyzdefg") (deftest replace-string.11 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start2 1))) (values (eqt x result) result)) t "yzcdefg") (deftest replace-string.12 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start2 1 :end1 nil))) (values (eqt x result) result)) t "yzcdefg") (deftest replace-string.13 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start2 1 :end2 nil))) (values (eqt x result) result)) t "yzcdefg") (deftest replace-string.14 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start2 1 :end2 2))) (values (eqt x result) result)) t "ybcdefg") (deftest replace-string.15 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 4 :end1 5 :start2 1 :end2 2))) (values (eqt x result) result)) t "abcdyfg") (deftest replace-string.16 (let* ((x (copy-seq "abcdef")) (y (coerce "123" 'list)) (result (replace x y :start1 1))) (values (eqt x result) result)) t "a123ef") (deftest replace-string.17 (let* ((x (copy-seq "abcdef")) (y (make-array '(3) :initial-contents '(#\1 #\2 #\3) :fill-pointer t :element-type 'character)) (result (replace x y :start1 1))) (values (eqt x result) result)) t "a123ef") (deftest replace-string.18 (let* ((x (copy-seq "abcdef")) (y (make-array '(6) :initial-contents "123456" :fill-pointer 3 :element-type 'character)) (result (replace x y :start1 1))) (values (eqt x result) result)) t "a123ef") (deftest replace-string.19 (let* ((x (copy-seq "abcdef")) (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) (values (eqt x result) result)) t "bcddef") (deftest replace-string.21 (let* ((x (copy-seq "abcdef")) (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) (values (eqt x result) result)) t "aabcef") ;;; Order of evaluation tests (deftest replace.order.1 (let ((i 0) a b) (values (replace (progn (setf a (incf i)) (list 'a 'b 'c)) (progn (setf b (incf i)) (list 'e 'f))) i a b)) (e f c) 2 1 2) (deftest replace.order.2 (let ((i 0) a b c d e f) (values (replace (progn (setf a (incf i)) (list 'a 'b 'c)) (progn (setf b (incf i)) (list 'e 'f)) :start1 (progn (setf c (incf i)) 1) :end1 (progn (setf d (incf i)) 3) :start2 (progn (setf e (incf i)) 0) :end2 (progn (setf f (incf i)) 2) ) i a b c d e f)) (a e f) 6 1 2 3 4 5 6) (deftest replace.order.3 (let ((i 0) a b c d e f) (values (replace (progn (setf a (incf i)) (list 'a 'b 'c)) (progn (setf b (incf i)) (list 'e 'f)) :end2 (progn (setf c (incf i)) 2) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) 3) :start1 (progn (setf f (incf i)) 1) ) i a b c d e f)) (a e f) 6 1 2 3 4 5 6) ;;; Keyword tests (deftest replace.allow-other-keys.1 (replace (copy-seq "abcdefg") "xyz" :allow-other-keys t) "xyzdefg") (deftest replace.allow-other-keys.2 (replace (copy-seq "abcdefg") "xyz" :allow-other-keys nil) "xyzdefg") (deftest replace.allow-other-keys.3 (replace (copy-seq "abcdefg") "xyz" :allow-other-keys t :bad t) "xyzdefg") (deftest replace.allow-other-keys.4 (replace (copy-seq "abcdefg") "xyz" :bad t :allow-other-keys t) "xyzdefg") (deftest replace.allow-other-keys.5 (replace (copy-seq "abcdefg") "xyz" :bad1 t :allow-other-keys t :bad2 t :allow-other-keys nil :bad3 nil) "xyzdefg") (deftest replace.allow-other-keys.6 (replace (copy-seq "abcdefg") "xyz" :allow-other-keys t :start1 1) "axyzefg") (deftest replace.keywords.7 (replace (copy-seq "abcdefg") "xyz" :start1 0 :start2 0 :end1 3 :end2 3 :start1 1 :start2 1 :end1 2 :end1 2) "xyzdefg") ;;; Error cases (deftest replace.error.1 (classify-error (replace)) program-error) (deftest replace.error.2 (classify-error (replace nil)) program-error) (deftest replace.error.3 (classify-error (replace nil nil :start)) program-error) (deftest replace.error.4 (classify-error (replace nil nil 'bad t)) program-error) (deftest replace.error.5 (classify-error (replace nil nil :allow-other-keys nil 'bad t)) program-error) (deftest replace.error.6 (classify-error (replace nil nil 1 2)) program-error) gcl/ansi-tests/reverse.lsp000066400000000000000000000047571242227143400161260ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 20 23:47:28 2002 ;;;; Contains: Tests for REVERSE (in-package :cl-test) (deftest reverse-list.1 (reverse nil) nil) (deftest reverse-list.2 (let ((x '(a b c))) (values (reverse x) x)) (c b a) (a b c)) (deftest reverse-vector.1 (reverse #()) #()) (deftest reverse-vector.2 (let ((x #(a b c d e))) (values (reverse x) x)) #(e d c b a) #(a b c d e)) (deftest reverse-nonsimple-vector.1 (let ((x (make-array 0 :fill-pointer t :adjustable t))) (reverse x)) #()) (deftest reverse-nonsimple-vector.2 (let* ((x (make-array 5 :initial-contents '(1 2 3 4 5) :fill-pointer t :adjustable t)) (y (reverse x))) (values y x)) #(5 4 3 2 1) #(1 2 3 4 5)) (deftest reverse-nonsimple-vector.3 (let* ((x (make-array 10 :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 5)) (y (reverse x))) y) #(5 4 3 2 1)) (deftest reverse-bit-vector.1 (reverse #*) #*) (deftest reverse-bit-vector.2 (let ((x #*000110110110)) (values (reverse x) x)) #*011011011000 #*000110110110) (deftest reverse-bit-vector.3 (let* ((x (make-array 10 :initial-contents '(0 0 0 1 1 0 1 0 1 0) :fill-pointer 5 :element-type 'bit)) (y (reverse x))) y) #*11000) (deftest reverse-string.1 (reverse "") "") (deftest reverse-string.2 (let ((x "000110110110")) (values (reverse x) x)) "011011011000" "000110110110") (deftest reverse-string.3 (let* ((x (make-array 10 :initial-contents "abcdefghij" :fill-pointer 5 :element-type 'character)) (y (reverse x))) y) "edcba") (deftest reverse-string.4 (let* ((x (make-array 10 :initial-contents "abcdefghij" :fill-pointer 5 :element-type 'base-char)) (y (reverse x))) y) "edcba") (deftest reverse.order.1 (let ((i 0)) (values (reverse (progn (incf i) (list 'a 'b 'c 'd))) i)) (d c b a) 1) ;;; Error cases (deftest reverse.error.1 (classify-error (reverse 'a)) type-error) (deftest reverse.error.2 (classify-error (reverse #\a)) type-error) (deftest reverse.error.3 (classify-error (reverse 10)) type-error) (deftest reverse.error.4 (classify-error (reverse 0.3)) type-error) (deftest reverse.error.5 (classify-error (reverse 10/3)) type-error) (deftest reverse.error.6 (classify-error (reverse)) program-error) (deftest reverse.error.7 (classify-error (reverse nil nil)) program-error) (deftest reverse.error.8 (classify-error (locally (reverse 'a) t)) type-error) gcl/ansi-tests/row-major-aref.lsp000066400000000000000000000052571242227143400172770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 22 20:16:38 2003 ;;;; Contains: Tests of ROW-MAJOR-AREF (in-package :cl-test) ;;; ROW-MAJOR-AREF is also used by equalp-with-case (see rt/rt.lsp) (deftest row-major-aref.1 (loop for i from 0 to 5 collect (row-major-aref #(a b c d e f) i)) (a b c d e f)) (deftest row-major-aref.2 (loop for i from 0 to 5 collect (row-major-aref #2a((a b c d)(e f g h)) i)) (a b c d e f)) (deftest row-major-aref.3 (row-major-aref #0a100 0) 100) (deftest row-major-aref.4 (loop for i from 0 to 5 collect (row-major-aref #*011100 i)) (0 1 1 1 0 0)) (deftest row-major-aref.5 (loop for i from 0 to 5 collect (row-major-aref "abcdef" i)) (#\a #\b #\c #\d #\e #\f)) (deftest row-major-aref.6 (let ((a (make-array nil :initial-element 'x))) (values (aref a) (setf (row-major-aref a 0) 'y) (aref a) a)) x y y #0ay) (deftest row-major-aref.7 (let ((a (make-array '(4) :initial-element 'x))) (values (aref a 0) (aref a 1) (aref a 2) (aref a 3) (setf (row-major-aref a 0) 'a) (setf (row-major-aref a 1) 'b) (setf (row-major-aref a 2) 'c) a)) x x x x a b c #(a b c x)) (deftest row-major-aref.8 (let ((a (make-array '(4) :element-type 'base-char :initial-element #\x))) (values (aref a 0) (aref a 1) (aref a 2) (aref a 3) (setf (row-major-aref a 0) #\a) (setf (row-major-aref a 1) #\b) (setf (row-major-aref a 2) #\c) a)) #\x #\x #\x #\x #\a #\b #\c "abcx") (deftest row-major-aref.9 (let ((a (make-array '(4) :initial-element 0 :element-type 'bit))) (values (aref a 0) (aref a 1) (aref a 2) (aref a 3) (setf (row-major-aref a 0) 1) (setf (row-major-aref a 1) 1) (setf (row-major-aref a 3) 1) a)) 0 0 0 0 1 1 1 #*1101) (deftest row-major-aref.10 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d)(e f g h)(i j k l)) ((m n o p)(q r s t)(u v w x)))))) (loop for i from 0 to 23 collect (row-major-aref a i))) (a b c d e f g h i j k l m n o p q r s t u v w x)) (deftest row-major-aref.order.1 (let ((i 0) x y) (values (row-major-aref (progn (setf x (incf i)) #(a b c d e f)) (progn (setf y (incf i)) 2)) i x y)) c 2 1 2) (deftest row-major-aref.order.2 (let ((i 0) x y z (a (copy-seq #(a b c d e f)))) (values (setf (row-major-aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 2)) (progn (setf z (incf i)) 'w)) a i x y z)) w #(a b w d e f) 3 1 2 3) ;;; Error tests (deftest row-major-aref.error.1 (classify-error (row-major-aref)) program-error) gcl/ansi-tests/rt-acl.system000066400000000000000000000004771242227143400163560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 7 23:30:22 1998 ;;;; Contains: Allegro CL defsystem for RT testing system (defsystem :rt-acl (:default-pathname #.(directory-namestring (truename *LOAD-PATHNAME*)) :default-file-type "lsp") (:definitions "rt-package" "rt")) gcl/ansi-tests/rt-doc.txt000066400000000000000000000207731242227143400156600ustar00rootroot00000000000000 #|----------------------------------------------------------------------------| | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | | | | Permission to use, copy, modify, and distribute this software and its | | documentation for any purpose and without fee is hereby granted, provided | | that this copyright and permission notice appear in all copies and | | supporting documentation, and that the name of M.I.T. not be used in | | advertising or publicity pertaining to distribution of the software | | without specific, written prior permission. M.I.T. makes no | | representations about the suitability of this software for any purpose. | | It is provided "as is" without express or implied warranty. | | | | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | | SOFTWARE. | |----------------------------------------------------------------------------|# (This is the December 19, 1990 version of brief documentation for the RT regression tester. A more complete discussion can be found in the article in Lisp Pointers.) The functions, macros, and variables that make up the RT regression tester are in a package called "RT". The ten exported symbols are documented below. If you want to refer to these symbols without a package prefix, you have to `use' the package. The basic unit of concern of RT is the test. Each test has an identifying name and a body that specifies the action of the test. Functions are provided for defining, redefining, removing, and performing individual tests and the test suite as a whole. In addition, information is maintained about which tests have succeeded and which have failed. <> deftest NAME FORM &rest VALUES Individual tests are defined using the macro DEFTEST. The identifying NAME is typically a number or symbol, but can be any Lisp form. If the test suite already contains a test with the same (EQUAL) NAME, then this test is redefined and a warning message printed. (This warning is important to alert the user when a test suite definition file contains two tests with the same name.) When the test is a new one, it is added to the end of the suite. In either case, NAME is returned as the value of DEFTEST and stored in the variable *TEST*. (deftest t-1 (floor 15/7) 2 1/7) => t-1 (deftest (t 2) (list 1) (1)) => (t 2) (deftest bad (1+ 1) 1) => bad (deftest good (1+ 1) 2) => good The FORM can be any kind of Lisp form. The zero or more VALUES can be any kind of Lisp objects. The test is performed by evaluating FORM and comparing the results with the VALUES. The test succeeds if and only if FORM produces the correct number of results and each one is EQUAL to the corresponding VALUE. <> *test* NAME-OF-CURRENT-TEST The variable *TEST* contains the name of the test most recently defined or performed. It is set by DEFTEST and DO-TEST. <> do-test &optional (NAME *TEST*) The function DO-TEST performs the test identified by NAME, which defaults to *TEST*. Before running the test, DO-TEST stores NAME in the variable *TEST*. If the test succeeds, DO-TEST returns NAME as its value. If the test fails, DO-TEST returns NIL, after printing an error report on *STANDARD-OUTPUT*. The following examples show the results of performing two of the tests defined above. (do-test '(t 2)) => (t 2) (do-test 'bad) => nil ; after printing: Test BAD failed Form: (1+ 1) Expected value: 1 Actual value: 2. <> *do-tests-when-defined* default value NIL If the value of this variable is non-null, each test is performed at the moment that it is defined. This is helpful when interactively constructing a suite of tests. However, when loading a test suite for later use, performing tests as they are defined is not liable to be helpful. <> get-test &optional (NAME *TEST*) This function returns the NAME, FORM, and VALUES of the specified test. (get-test '(t 2)) => ((t 2) (list 1) (1)) <> rem-test &optional (NAME *TEST*) If the indicated test is in the test suite, this function removes it and returns NAME. Otherwise, NIL is returned. <> rem-all-tests This function reinitializes RT by removing every test from the test suite and returns NIL. Generally, it is advisable for the whole test suite to apply to some one system. When switching from testing one system to testing another, it is wise to remove all the old tests before beginning to define new ones. <> do-tests &optional (OUT *STANDARD-OUTPUT*) This function uses DO-TEST to run each of the tests in the test suite and prints a report of the results on OUT, which can either be an output stream or the name of a file. If OUT is omitted, it defaults to *STANDARD-OUTPUT*. DO-TESTS returns T if every test succeeded and NIL if any test failed. As illustrated below, the first line of the report produced by DO-TEST shows how many tests need to be performed. The last line shows how many tests failed and lists their names. While the tests are being performed, DO-TESTS prints the names of the successful tests and the error reports from the unsuccessful tests. (do-tests "report.txt") => nil ; the file "report.txt" contains: Doing 4 pending tests of 4 tests total. T-1 (T 2) Test BAD failed Form: (1+ 1) Expected value: 1 Actual value: 2. GOOD 1 out of 4 total tests failed: BAD. It is best if the individual tests in the suite are totally independent of each other. However, should the need arise for some interdependence, you can rely on the fact that DO-TESTS will run tests in the order they were originally defined. <> pending-tests When a test is defined or redefined, it is marked as pending. In addition, DO-TEST marks the test to be run as pending before running it and DO-TESTS marks every test as pending before running any of them. The only time a test is marked as not pending is when it completes successfully. The function PENDING-TESTS returns a list of the names of the currently pending tests. (pending-tests) => (bad) <> continue-testing This function is identical to DO-TESTS except that it only runs the tests that are pending and always writes its output on *STANDARD-OUTPUT*. (continue-testing) => nil ; after printing: Doing 1 pending test out of 4 total tests. Test BAD failed Form: (1+ 1) Expected value: 1 Actual value: 2. 1 out of 4 total tests failed: BAD. CONTINUE-TESTING has a special meaning if called at a breakpoint generated while a test is being performed. The failure of a test to return the correct value does not trigger an error break. However, there are many kinds of things that can go wrong while a test is being performed (e.g., dividing by zero) that will cause breaks. If CONTINUE-TESTING is evaluated in a break generated during testing, it aborts the current test (which remains pending) and forces the processing of tests to continue. Note that in such a breakpoint, *TEST* is bound to the name of the test being performed and (GET-TEST) can be used to look at the test. When building a system, it is advisable to start constructing a test suite for it as soon as possible. Since individual tests are rather weak, a comprehensive test suite requires large numbers of tests. However, these can be accumulated over time. In particular, whenever a bug is found by some means other than testing, it is wise to add a test that would have found the bug and therefore will ensure that the bug will not reappear. Every time the system is changed, the entire test suite should be run to make sure that no unintended changes have occurred. Typically, some tests will fail. Sometimes, this merely means that tests have to be changed to reflect changes in the system's specification. Other times, it indicates bugs that have to be tracked down and fixed. During this phase, CONTINUE-TESTING is useful for focusing on the tests that are failing. However, for safety sake, it is always wise to reinitialize RT, redefine the entire test suite, and run DO-TESTS one more time after you think all of the tests are working. gcl/ansi-tests/rt-package.lsp000066400000000000000000000010321242227143400164500ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Dec 17 21:10:53 2002 ;;;; Contains: Package definition for RT (eval-when ;;(:execute :compile-toplevel :load-toplevel) (load eval compile) (defpackage :regression-test (:use :cl) (:nicknames :rtest #-lispworks :rt) (:export #:*do-tests-when-defined* #:*test* #:continue-testing #:deftest #:do-test #:do-tests #:get-test #:pending-tests #:rem-all-tests #:rem-test ))) (in-package :regression-test) gcl/ansi-tests/rt-test.lsp000066400000000000000000000155301242227143400160440ustar00rootroot00000000000000;-*-syntax:COMMON-LISP-*- #|----------------------------------------------------------------------------| | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | | | | Permission to use, copy, modify, and distribute this software and its | | documentation for any purpose and without fee is hereby granted, provided | | that this copyright and permission notice appear in all copies and | | supporting documentation, and that the name of M.I.T. not be used in | | advertising or publicity pertaining to distribution of the software | | without specific, written prior permission. M.I.T. makes no | | representations about the suitability of this software for any purpose. | | It is provided "as is" without express or implied warranty. | | | | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | | SOFTWARE. | |----------------------------------------------------------------------------|# ;This is the December 19, 1990 version of a set of tests that use the ;RT regression tester to test itself. See the documentation of RT for ;a discusion of how to use this file. (in-package :user) ;; (require "RT") (use-package :regression-test) (defmacro setup (&rest body) `(do-setup '(progn ., body))) (defun do-setup (form) (let ((*test* nil) (*do-tests-when-defined* nil) (regression-test::*entries* (list nil)) (regression-test::*in-test* nil) (regression-test::*debug* t) result) (deftest t1 4 4) (deftest (t 2) 4 3) (values-list (cons (normalize (with-output-to-string (*standard-output*) (setq result (multiple-value-list (catch 'regression-test::*debug* (eval form)))))) result)))) (defun normalize (string) (with-input-from-string (s string) (normalize-stream s))) (defvar *file-name* nil) (defun get-file-name () (loop (if *file-name* (return *file-name*)) (format *error-output* "~%Type a string representing naming of a scratch disk file: ") (setq *file-name* (read)) (if (not (stringp *file-name*)) (setq *file-name* nil)))) (get-file-name) (defmacro with-temporary-file (f &body forms) `(let ((,f *file-name*)) ,@ forms (get-file-output ,f))) (defun get-file-output (f) (prog1 (with-open-file (in f) (normalize-stream in)) (delete-file f))) (defun normalize-stream (s) (let ((l nil)) (loop (push (read-line s nil s) l) (when (eq (car l) s) (setq l (nreverse (cdr l))) (return nil))) (delete "" l :test #'equal))) (rem-all-tests) (deftest deftest-1 (setup (deftest t1 3 3) (values (get-test 't1) *test* (pending-tests))) ("Redefining test T1") (t1 3 3) t1 (t1 (t 2))) (deftest deftest-2 (setup (deftest (t 2) 3 3) (get-test '(t 2))) ("Redefining test (T 2)") ((t 2) 3 3)) (deftest deftest-3 (setup (deftest 2 3 3) (values (get-test 2) *test* (pending-tests))) () (2 3 3) 2 (t1 (t 2) 2)) (deftest deftest-4 (setup (let ((*do-tests-when-defined* t)) (deftest (temp) 4 3))) ("Test (TEMP) failed" "Form: 4" "Expected value: 3" "Actual value: 4.") (temp)) (deftest do-test-1 (setup (values (do-test 't1) *test* (pending-tests))) () t1 t1 ((t 2))) (deftest do-test-2 (setup (values (do-test '(t 2)) (pending-tests))) ("Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4.") nil (t1 (t 2))) (deftest do-test-3 (setup (let ((*test* 't1)) (do-test))) () t1) (deftest get-test-1 (setup (values (get-test 't1) *test*)) () (t1 4 4) (t 2)) (deftest get-test-2 (setup (get-test '(t 2))) () ((t 2) 4 3)) (deftest get-test-3 (setup (let ((*test* 't1)) (get-test))) () (t1 4 4)) (deftest get-test-4 (setup (deftest t3 1 1) (get-test)) () (t3 1 1)) (deftest get-test-5 (setup (get-test 't0)) ("No test with name T0.") nil) (deftest rem-test-1 (setup (values (rem-test 't1) (pending-tests))) () t1 ((t 2))) (deftest rem-test-2 (setup (values (rem-test '(t 2)) (pending-tests))) () (t 2) (t1)) (deftest rem-test-3 (setup (let ((*test* '(t 2))) (rem-test)) (pending-tests)) () (t1)) (deftest rem-test-4 (setup (values (rem-test 't0) (pending-tests))) () nil (t1 (t 2))) (deftest rem-test-5 (setup (rem-all-tests) (rem-test 't0) (pending-tests)) () ()) (deftest rem-all-tests-1 (setup (values (rem-all-tests) (pending-tests))) () nil nil) (deftest rem-all-tests-2 (setup (rem-all-tests) (rem-all-tests) (pending-tests)) () nil) (deftest do-tests-1 (setup (let ((*print-case* :downcase)) (values (do-tests) (continue-testing) (do-tests)))) ("Doing 2 pending tests of 2 tests total." " T1" "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2)." "Doing 1 pending test of 2 tests total." "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2)." "Doing 2 pending tests of 2 tests total." " T1" "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2).") nil nil nil) (deftest do-tests-2 (setup (rem-test '(t 2)) (deftest (t 2) 3 3) (values (do-tests) (continue-testing) (do-tests))) ("Doing 2 pending tests of 2 tests total." " T1 (T 2)" "No tests failed." "Doing 0 pending tests of 2 tests total." "No tests failed." "Doing 2 pending tests of 2 tests total." " T1 (T 2)" "No tests failed.") t t t) (deftest do-tests-3 (setup (rem-all-tests) (values (do-tests) (continue-testing))) ("Doing 0 pending tests of 0 tests total." "No tests failed." "Doing 0 pending tests of 0 tests total." "No tests failed.") t t) (deftest do-tests-4 (setup (normalize (with-output-to-string (s) (do-tests s)))) () ("Doing 2 pending tests of 2 tests total." " T1" "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2).")) (deftest do-tests-5 (setup (with-temporary-file s (do-tests s))) () ("Doing 2 pending tests of 2 tests total." " T1" "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2).")) (deftest continue-testing-1 (setup (deftest temp (continue-testing) 5) (do-test 'temp) (pending-tests)) () (t1 (t 2) temp)) gcl/ansi-tests/rt.lsp000066400000000000000000000211031242227143400150600ustar00rootroot00000000000000;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*- #|----------------------------------------------------------------------------| | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | | | | Permission to use, copy, modify, and distribute this software and its | | documentation for any purpose and without fee is hereby granted, provided | | that this copyright and permission notice appear in all copies and | | supporting documentation, and that the name of M.I.T. not be used in | | advertising or publicity pertaining to distribution of the software | | without specific, written prior permission. M.I.T. makes no | | representations about the suitability of this software for any purpose. | | It is provided "as is" without express or implied warranty. | | | | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | | SOFTWARE. | |----------------------------------------------------------------------------|# ;This is the December 19, 1990 version of the regression tester. (in-package :regression-test) (defvar *test* nil "Current test name") (defvar *do-tests-when-defined* nil) (defvar *entries* '(nil) "Test database") (defvar *in-test* nil "Used by TEST") (defvar *debug* nil "For debugging") (defvar *catch-errors* t "When true, causes errors in a test to be caught.") (defvar *print-circle-on-failure* nil "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") (defvar *compile-tests* nil "When true, compile the tests before running them.") (defvar *optimization-settings* '((safety 3))) (defvar *expected-failures* nil "A list of test names that are expected to fail.") (defstruct (entry (:conc-name nil) (:type list)) pend name form) (defmacro vals (entry) `(cdddr ,entry)) (defmacro defn (entry) `(cdr ,entry)) (defun pending-tests () (do ((l (cdr *entries*) (cdr l)) (r nil)) ((null l) (nreverse r)) (when (pend (car l)) (push (name (car l)) r)))) (defun rem-all-tests () (setq *entries* (list nil)) nil) (defun rem-test (&optional (name *test*)) (do ((l *entries* (cdr l))) ((null (cdr l)) nil) (when (equal (name (cadr l)) name) (setf (cdr l) (cddr l)) (return name)))) (defun get-test (&optional (name *test*)) (defn (get-entry name))) (defun get-entry (name) (let ((entry (find name (cdr *entries*) :key #'name :test #'equal))) (when (null entry) (report-error t "~%No test with name ~:@(~S~)." name)) entry)) (defmacro deftest (name form &rest values) `(add-entry '(t ,name ,form .,values))) (defun add-entry (entry) (setq entry (copy-list entry)) (do ((l *entries* (cdr l))) (nil) (when (null (cdr l)) (setf (cdr l) (list entry)) (return nil)) (when (equal (name (cadr l)) (name entry)) (setf (cadr l) entry) (report-error nil "Redefining test ~:@(~S~)" (name entry)) (return nil))) (when *do-tests-when-defined* (do-entry entry)) (setq *test* (name entry))) (defun report-error (error? &rest args) (cond (*debug* (apply #'format t args) (if error? (throw '*debug* nil))) (error? (apply #'error args)) (t (apply #'warn args)))) (defun do-test (&optional (name *test*)) (do-entry (get-entry name))) (defun equalp-with-case (x y) "Like EQUALP, but doesn't do case conversion of characters. Currently doesn't work on arrays of dimension > 2." (cond ((consp x) (and (consp y) (equalp-with-case (car x) (car y)) (equalp-with-case (cdr x) (cdr y)))) ((and (typep x 'array) (= (array-rank x) 0)) (equalp-with-case (aref x) (aref y))) ((typep x 'vector) (and (typep y 'vector) (let ((x-len (length x)) (y-len (length y))) (and (eql x-len y-len) (loop for e1 across x for e2 across y always (equalp-with-case e1 e2)))))) ((and (typep x 'array) (typep y 'array) (not (equal (array-dimensions x) (array-dimensions y)))) nil) #| ((and (typep x 'array) (= (array-rank x) 2)) (let ((dim (array-dimensions x))) (loop for i from 0 below (first dim) always (loop for j from 0 below (second dim) always (equalp-with-case (aref x i j) (aref y i j)))))) |# ((typep x 'array) (and (typep y 'array) (let ((size (array-total-size x))) (loop for i from 0 below size always (equalp-with-case (row-major-aref x i) (row-major-aref y i)))))) (t (eql x y)))) (defun do-entry (entry &optional (s *standard-output*)) (catch '*in-test* (setq *test* (name entry)) (setf (pend entry) t) (let* ((*in-test* t) ;; (*break-on-warnings* t) (aborted nil) r) ;; (declare (special *break-on-warnings*)) (flet ((%do () (setf r (multiple-value-list (if *compile-tests* (funcall (compile nil `(lambda () (declare (optimize ,@*optimization-settings*)) ,(form entry)))) (eval (form entry))))))) (block aborted (if *catch-errors* (handler-bind (#-ecl (style-warning #'muffle-warning) (error #'(lambda (c) (setf aborted t) (setf r (list c)) (return-from aborted nil)))) (%do)) (%do)))) (setf (pend entry) (or aborted (not (equalp-with-case r (vals entry))))) (when (pend entry) (let ((*print-circle* *print-circle-on-failure*)) (format s "~&Test ~:@(~S~) failed~%Form: ~S~%Expected value~P:~%" *test* (form entry) (length (vals entry))) (dolist (v (vals entry)) (format s "~10t~S~%" v)) (format s "Actual value~P:~%" (length r)) (dolist (v r) (format s "~10t~S~:[~; [~2:*~A]~]~%" v (typep v 'condition))))))) (when (not (pend entry)) *test*)) (defun continue-testing () (if *in-test* (throw '*in-test* nil) (do-entries *standard-output*))) (defun do-tests (&optional (out *standard-output*)) (dolist (entry (cdr *entries*)) (setf (pend entry) t)) (if (streamp out) (do-entries out) (with-open-file (stream out :direction :output) (do-entries stream)))) (defun do-entries (s) (format s "~&Doing ~A pending test~:P ~ of ~A tests total.~%" (count t (cdr *entries*) :key #'pend) (length (cdr *entries*))) (dolist (entry (cdr *entries*)) (when (pend entry) (format s "~@[~<~%~:; ~:@(~S~)~>~]" (do-entry entry s)))) (let ((pending (pending-tests)) (expected-table (make-hash-table :test #'equal))) (dolist (ex *expected-failures*) (setf (gethash ex expected-table) t)) (let ((new-failures (loop for pend in pending unless (gethash pend expected-table) collect pend))) (if (null pending) (format s "~&No tests failed.") (progn (format s "~&~A out of ~A ~ total tests failed: ~ ~:@(~{~<~% ~1:;~S~>~ ~^, ~}~)." (length pending) (length (cdr *entries*)) pending) (if (null new-failures) (format s "~&No unexpected failures.") (when *expected-failures* (format s "~&~A unexpected failures: ~ ~:@(~{~<~% ~1:;~S~>~ ~^, ~}~)." (length new-failures) new-failures))) (when *expected-failures* (let ((pending-table (make-hash-table :test #'equal))) (dolist (ex pending) (setf (gethash ex pending-table) t)) (let ((unexpected-successes (loop :for ex :in *expected-failures* :unless (gethash ex pending-table) :collect ex))) (if unexpected-successes (format t "~&~:D unexpected successes: ~ ~:@(~{~<~% ~1:;~S~>~ ~^, ~}~)." (length unexpected-successes) unexpected-successes) (format t "~&No unexpected successes."))))) )) (null pending)))) gcl/ansi-tests/rt.system000066400000000000000000000012501242227143400156070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 7 23:30:22 1998 ;;;; Contains: Portable defsystem for RT testing system (mk::defsystem "rt" :source-pathname #.(directory-namestring *LOAD-TRUENAME*) :binary-pathname #.(mk::append-directories (directory-namestring *LOAD-TRUENAME*) "binary/") :source-extension "lsp" :binary-extension #+CMU #.(C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*) #+ALLEGRO "fasl" #+(OR AKCL GCL) "o" #+CLISP "fas" #-(OR CMU ALLEGRO AKCL GCL CLISP) #.(pathname-type (compile-file-pathname "foo.lisp")) :components ( "rt-package" ("rt" :depends-on ("rt-package")))) gcl/ansi-tests/sbit.lsp000066400000000000000000000034051242227143400154010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 15:30:31 2003 ;;;; Contains: Tests for SBIT (in-package :cl-test) (deftest sbit.1 (sbit #*0010 2) 1) (deftest sbit.2 (let ((a #*00000000)) (loop for i from 0 below (length a) collect (let ((b (copy-seq a))) (setf (sbit b i) 1) b))) (#*10000000 #*01000000 #*00100000 #*00010000 #*00001000 #*00000100 #*00000010 #*00000001)) (deftest sbit.3 (let ((a #*11111111)) (loop for i from 0 below (length a) collect (let ((b (copy-seq a))) (setf (sbit b i) 0) b))) (#*01111111 #*10111111 #*11011111 #*11101111 #*11110111 #*11111011 #*11111101 #*11111110)) (deftest sbit.4 (let ((a (make-array nil :element-type 'bit :initial-element 0))) (values (aref a) (sbit a) (setf (sbit a) 1) (aref a) (sbit a))) 0 0 1 1 1) (deftest sbit.5 (let ((a (make-array '(1 1) :element-type 'bit :initial-element 0))) (values (aref a 0 0) (sbit a 0 0) (setf (sbit a 0 0) 1) (aref a 0 0) (sbit a 0 0))) 0 0 1 1 1) (deftest sbit.6 (let ((a (make-array '(10 10) :element-type 'bit :initial-element 0))) (values (aref a 5 5) (sbit a 5 5) (setf (sbit a 5 5) 1) (aref a 5 5) (sbit a 5 5))) 0 0 1 1 1) (deftest sbit.order.1 (let ((i 0) a b) (values (sbit (progn (setf a (incf i)) #*001001) (progn (setf b (incf i)) 1)) i a b)) 0 2 1 2) (deftest sbit.order.2 (let ((i 0) a b c (v (copy-seq #*001001))) (values (setf (sbit (progn (setf a (incf i)) v) (progn (setf b (incf i)) 1)) (progn (setf c (incf i)) 1)) v i a b c)) 1 #*011001 3 1 2 3) (deftest sbit.error.1 (classify-error (sbit)) program-error) gcl/ansi-tests/search-aux.lsp000066400000000000000000000056651242227143400165120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 24 07:22:10 2002 ;;;; Contains: Aux. functions for testing SEARCH (in-package :cl-test) (defparameter *searched-list* '(b b a b b b b b b b a b a b b b a b a b b b a a a a b a a b a a a a a a b a b b a b a a b a a a b b a a b a a a a b b a b a b a a a b a b b a b a a b b b b b a a a a a b a b b b b b a b a b b a b a b)) (defparameter *pattern-sublists* (remove-duplicates (let* ((s *searched-list*) (len (length s))) (loop for x from 0 to 8 nconc (loop for y from 0 to (- len x) collect (subseq s y (+ y x))))) :test #'equal)) (defparameter *searched-vector* (make-array (length *searched-list*) :initial-contents *searched-list*)) (defparameter *pattern-subvectors* (mapcar #'(lambda (x) (apply #'vector x)) *pattern-sublists*)) (defparameter *searched-bitvector* #*1101111111010111010111000010010000001011010010001100100001101010001011010011111000001011111010110101) (defparameter *pattern-subbitvectors* (remove-duplicates (let* ((s *searched-bitvector*) (len (length s))) (loop for x from 0 to 8 nconc (loop for y from 0 to (- len x) collect (subseq s y (+ y x))))) :test #'equalp)) (defparameter *searched-string* "1101111111010111010111000010010000001011010010001100100001101010001011010011111000001011111010110101") (defparameter *pattern-substrings* (remove-duplicates (let* ((s *searched-string*) (len (length s))) (loop for x from 0 to 8 nconc (loop for y from 0 to (- len x) collect (subseq s y (+ y x))))) :test #'equalp)) (defun subseq-equalp (seq1 seq2 start1 start2 len &key (test #'equalp)) (assert (and (>= start1 0) (>= start2 0) (<= (+ start1 len) (length seq1)) (<= (+ start2 len) (length seq2)))) (if (and (listp seq1) (listp seq2)) (loop for i from 0 to (1- len) for e1 in (nthcdr start1 seq1) for e2 in (nthcdr start2 seq2) always (funcall test e1 e2)) (loop for i from 0 to (1- len) always (funcall test (elt seq1 (+ start1 i)) (elt seq2 (+ start2 i)))))) (defun search-check (pattern searched pos &key (start1 0) (end1 nil) (start2 0) (end2 nil) key from-end (test #'equalp)) (unless end1 (setq end1 (length pattern))) (unless end2 (setq end2 (length searched))) (assert (<= start1 end1)) (assert (<= start2 end2)) (let* ((plen (- end1 start1))) (when key (setq pattern (map 'list key pattern)) (setq searched (map 'list key searched))) (if pos (and (subseq-equalp searched pattern pos start1 plen :test test) (if from-end (loop for i from (1+ pos) to (- end2 plen) never (subseq-equalp searched pattern i start1 plen :test test)) (loop for i from start2 to (1- pos) never (subseq-equalp searched pattern i start1 plen :test test)))) (loop for i from start2 to (- end2 plen) never (subseq-equalp searched pattern i start1 plen :test test))))) gcl/ansi-tests/search-bitvector.lsp000066400000000000000000000116051242227143400177050ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 25 13:06:54 2002 ;;;; Contains: Tests for SEARCH on bit vectors (in-package :cl-test) (deftest search-bitvector.1 (let ((target *searched-bitvector*) (pat #(a))) (loop for i from 0 to (1- (length target)) for tail on target always (let ((pos (search pat tail))) (search-check pat tail pos)))) t) (deftest search-bitvector.2 (let ((target *searched-bitvector*) (pat #(a))) (loop for i from 1 to (length target) always (let ((pos (search pat target :end2 i :from-end t))) (search-check pat target pos :end2 i :from-end t)))) t) (deftest search-bitvector.3 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target) unless (search-check pat target pos) collect pat)) nil) (deftest search-bitvector.4 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :from-end t) unless (search-check pat target pos :from-end t) collect pat)) nil) (deftest search-bitvector.5 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :start2 25 :end2 75) unless (search-check pat target pos :start2 25 :end2 75) collect pat)) nil) (deftest search-bitvector.6 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :from-end t :start2 25 :end2 75) unless (search-check pat target pos :from-end t :start2 25 :end2 75) collect pat)) nil) (deftest search-bitvector.7 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :start2 20) unless (search-check pat target pos :start2 20) collect pat)) nil) (deftest search-bitvector.8 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :from-end t :start2 20) unless (search-check pat target pos :from-end t :start2 20) collect pat)) nil) (deftest search-bitvector.9 (let ((target *searched-bitvector*)) (loop for pat in (mapcar #'(lambda (x) (map 'vector #'(lambda (y) (sublis '((a . 2) (b . 3)) y)) x)) *pattern-sublists*) for pos = (search pat target :start2 20 :key #'evenp) unless (search-check pat target pos :start2 20 :key #'evenp) collect pat)) nil) (deftest search-bitvector.10 (let ((target *searched-bitvector*)) (loop for pat in (mapcar #'(lambda (x) (map 'vector #'(lambda (y) (sublis '((a . 2) (b . 3)) y)) x)) *pattern-sublists*) for pos = (search pat target :from-end t :start2 20 :key 'oddp) unless (search-check pat target pos :from-end t :start2 20 :key 'oddp) collect pat)) nil) (deftest search-bitvector.11 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :start2 20 :test (complement #'eql)) unless (search-check pat target pos :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-bitvector.12 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :from-end t :start2 20 :test-not #'eql) unless (search-check pat target pos :from-end t :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-bitvector.13 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* when (and (> (length pat) 0) (let ((pos (search pat target :start1 1 :test (complement #'eql)))) (not (search-check pat target pos :start1 1 :test (complement #'eql))))) collect pat)) nil) (deftest search-bitvector.14 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* when (let ((len (length pat))) (and (> len 0) (let ((pos (search pat target :end1 (1- len) :test (complement #'eql)))) (not (search-check pat target pos :end1 (1- len) :test (complement #'eql)))))) collect pat)) nil) (deftest search-bitvector.15 (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 0 1 0 1 1) :fill-pointer 5 :element-type 'bit))) (values (search #*0 a) (search #*0 a :from-end t) (search #*01 a) (search #*01 a :from-end t) (search #*010 a) (search #*010 a :from-end t))) 0 4 0 0 nil nil) (deftest search-bitvector.16 (let ((pat (make-array '(3) :initial-contents '(0 1 0) :fill-pointer 1)) (a #*01100)) (values (search pat a) (search pat a :from-end t) (progn (setf (fill-pointer pat) 2) (search pat a)) (search pat a :from-end t) (progn (setf (fill-pointer pat) 3) (search pat a)) (search pat a :from-end t))) 0 4 0 0 nil nil) gcl/ansi-tests/search-list.lsp000066400000000000000000000153201242227143400166550ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 24 07:22:10 2002 ;;;; Contains: Tests for SEARCH on lists (in-package :cl-test) (deftest search-list.1 (let ((target *searched-list*) (pat '(a))) (loop for i from 0 to (1- (length target)) for tail on target always (let ((pos (search pat tail))) (search-check pat tail pos)))) t) (deftest search-list.2 (let ((target *searched-list*) (pat '(a))) (loop for i from 1 to (length target) always (let ((pos (search pat target :end2 i :from-end t))) (search-check pat target pos :end2 i :from-end t)))) t) (deftest search-list.3 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target) unless (search-check pat target pos) collect pat)) nil) (deftest search-list.4 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :from-end t) unless (search-check pat target pos :from-end t) collect pat)) nil) (deftest search-list.5 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :start2 25 :end2 75) unless (search-check pat target pos :start2 25 :end2 75) collect pat)) nil) (deftest search-list.6 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :from-end t :start2 25 :end2 75) unless (search-check pat target pos :from-end t :start2 25 :end2 75) collect pat)) nil) (deftest search-list.7 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :start2 20) unless (search-check pat target pos :start2 20) collect pat)) nil) (deftest search-list.8 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :from-end t :start2 20) unless (search-check pat target pos :from-end t :start2 20) collect pat)) nil) (deftest search-list.9 (let ((target (sublis '((a . 1) (b . 2)) *searched-list*))) (loop for pat in (sublis '((a . 3) (b . 4)) *pattern-sublists*) for pos = (search pat target :start2 20 :key #'evenp) unless (search-check pat target pos :start2 20 :key #'evenp) collect pat)) nil) (deftest search-list.10 (let ((target (sublis '((a . 1) (b . 2)) *searched-list*))) (loop for pat in (sublis '((a . 3) (b . 4)) *pattern-sublists*) for pos = (search pat target :from-end t :start2 20 :key 'oddp) unless (search-check pat target pos :from-end t :start2 20 :key 'oddp) collect pat)) nil) (deftest search-list.11 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :start2 20 :test (complement #'eql)) unless (search-check pat target pos :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-list.12 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :from-end t :start2 20 :test-not #'eql) unless (search-check pat target pos :from-end t :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-list.13 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* when (and (> (length pat) 0) (let ((pos (search pat target :start1 1 :test (complement #'eql)))) (not (search-check pat target pos :start1 1 :test (complement #'eql))))) collect pat)) nil) (deftest search-list.14 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* when (let ((len (length pat))) (and (> len 0) (let ((pos (search pat target :end1 (1- len) :test (complement #'eql)))) (not (search-check pat target pos :end1 (1- len) :test (complement #'eql)))))) collect pat)) nil) ;;; Keyword tests (deftest search.allow-other-keys.1 (search '(c d) '(a b c d c d e) :allow-other-keys t) 2) (deftest search.allow-other-keys.2 (search '(c d) '(a b c d c d e) :allow-other-keys nil) 2) (deftest search.allow-other-keys.3 (search '(c d) '(a b c d c d e) :bad t :allow-other-keys t) 2) (deftest search.allow-other-keys.4 (search '(c d) '(a b c d c d e) :allow-other-keys 'foo :bad nil) 2) (deftest search.allow-other-keys.5 (search '(c d) '(a b c d c d e) :bad1 1 :allow-other-keys t :bad2 2 :allow-other-keys nil :bad3 3) 2) (deftest search.allow-other-keys.6 (search '(c d) '(a b c d c d e) :allow-other-keys 'foo :from-end t) 4) (deftest search.allow-other-keys.7 (search '(c d) '(a b c d c d e) :from-end t :allow-other-keys t) 4) (deftest search.keywords.8 (search '(c d) '(a b c d c d e) :start1 0 :start2 0 :start1 1 :start2 6 :from-end t :from-end nil) 4) ;;; Error cases (deftest search.error.1 (classify-error (search)) program-error) (deftest search.error.2 (classify-error (search "a")) program-error) (deftest search.error.3 (classify-error (search "a" "a" :key)) program-error) (deftest search.error.4 (classify-error (search "a" "a" 'bad t)) program-error) (deftest search.error.5 (classify-error (search "a" "a" 'bad t :allow-other-keys nil)) program-error) (deftest search.error.6 (classify-error (search "a" "a" 1 2)) program-error) (deftest search.error.7 (classify-error (search "c" "abcde" :test #'identity)) program-error) (deftest search.error.8 (classify-error (search "c" "abcde" :test-not #'identity)) program-error) (deftest search.error.9 (classify-error (search "c" "abcde" :key #'cons)) program-error) (deftest search.error.10 (classify-error (search "c" "abcde" :key #'car)) type-error) ;;; Order of evaluation (deftest search.order.1 (let ((i 0) a b c d e f g h j) (values (search (progn (setf a (incf i)) '(nil a b nil)) (progn (setf b (incf i)) '(z z z a a b b z z z)) :from-end (progn (setf c (incf i)) t) :start1 (progn (setf d (incf i)) 1) :end1 (progn (setf e (incf i)) 3) :start2 (progn (setf f (incf i)) 1) :end2 (progn (setf g (incf i)) 8) :key (progn (setf h (incf i)) #'identity) :test (progn (setf j (incf i)) #'eql) ) i a b c d e f g h j)) 4 9 1 2 3 4 5 6 7 8 9) (deftest search.order.2 (let ((i 0) a b c d e f g h j) (values (search (progn (setf a (incf i)) '(nil a b nil)) (progn (setf b (incf i)) '(z z z a a b b z z z)) :test-not (progn (setf c (incf i)) (complement #'eql)) :key (progn (setf d (incf i)) #'identity) :end2 (progn (setf e (incf i)) 8) :start2 (progn (setf f (incf i)) 1) :end1 (progn (setf g (incf i)) 3) :start1 (progn (setf h (incf i)) 1) :from-end (progn (setf j (incf i)) t) ) i a b c d e f g h j)) 4 9 1 2 3 4 5 6 7 8 9)gcl/ansi-tests/search-string.lsp000066400000000000000000000107201242227143400172070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 25 13:06:54 2002 ;;;; Contains: Tests for SEARCH on strings (in-package :cl-test) ;;; The next test was busted due to to a stupid cut and paste ;;; error. The loop terminates immediately, doing nothing ;;; useful. -- PFD #| (deftest search-string.1 (let ((target *searched-string*) (pat #(a))) (loop for i from 0 to (1- (length target)) for tail on target always (let ((pos (search pat tail))) (search-check pat tail pos)))) t) |# (deftest search-string.2 (let ((target *searched-string*) (pat #(a))) (loop for i from 1 to (length target) always (let ((pos (search pat target :end2 i :from-end t))) (search-check pat target pos :end2 i :from-end t)))) t) (deftest search-string.3 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target) unless (search-check pat target pos) collect pat)) nil) (deftest search-string.4 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :from-end t) unless (search-check pat target pos :from-end t) collect pat)) nil) (deftest search-string.5 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :start2 25 :end2 75) unless (search-check pat target pos :start2 25 :end2 75) collect pat)) nil) (deftest search-string.6 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :from-end t :start2 25 :end2 75) unless (search-check pat target pos :from-end t :start2 25 :end2 75) collect pat)) nil) (deftest search-string.7 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :start2 20) unless (search-check pat target pos :start2 20) collect pat)) nil) (deftest search-string.8 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :from-end t :start2 20) unless (search-check pat target pos :from-end t :start2 20) collect pat)) nil) (deftest search-string.9 (flet ((%f (x) (case x ((#\0 a) 'c) ((#\1 b) 'd) (t nil)))) (let ((target *searched-string*)) (loop for pat in *pattern-sublists* for pos = (search pat target :start2 20 :key #'%f) unless (search-check pat target pos :start2 20 :key #'%f) collect pat))) nil) (deftest search-string.10 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :start2 20 :test (complement #'eql)) unless (search-check pat target pos :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-string.11 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :from-end t :start2 20 :test-not #'eql) unless (search-check pat target pos :from-end t :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-string.13 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* when (and (> (length pat) 0) (let ((pos (search pat target :start1 1 :test (complement #'eql)))) (not (search-check pat target pos :start1 1 :test (complement #'eql))))) collect pat)) nil) (deftest search-string.14 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* when (let ((len (length pat))) (and (> len 0) (let ((pos (search pat target :end1 (1- len) :test (complement #'eql)))) (not (search-check pat target pos :end1 (1- len) :test (complement #'eql)))))) collect pat)) nil) (deftest search-string.15 (let ((a (make-array '(10) :initial-contents "abbaaababb" :fill-pointer 5 :element-type 'character))) (values (search "a" a) (search "a" a :from-end t) (search "ab" a) (search "ab" a :from-end t) (search "aba" a) (search "aba" a :from-end t))) 0 4 0 0 nil nil) (deftest search-string.16 (let ((pat (make-array '(3) :initial-contents '(#\a #\b #\a) :fill-pointer 1)) (a "abbaa")) (values (search pat a) (search pat a :from-end t) (progn (setf (fill-pointer pat) 2) (search pat a)) (search pat a :from-end t) (progn (setf (fill-pointer pat) 3) (search pat a)) (search pat a :from-end t))) 0 4 0 0 nil nil) gcl/ansi-tests/search-vector.lsp000066400000000000000000000115751242227143400172140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 25 13:06:54 2002 ;;;; Contains: Tests for SEARCH on vectors (in-package :cl-test) (deftest search-vector.1 (let ((target *searched-vector*) (pat #(a))) (loop for i from 0 to (1- (length target)) for tail on target always (let ((pos (search pat tail))) (search-check pat tail pos)))) t) (deftest search-vector.2 (let ((target *searched-vector*) (pat #(a))) (loop for i from 1 to (length target) always (let ((pos (search pat target :end2 i :from-end t))) (search-check pat target pos :end2 i :from-end t)))) t) (deftest search-vector.3 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target) unless (search-check pat target pos) collect pat)) nil) (deftest search-vector.4 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :from-end t) unless (search-check pat target pos :from-end t) collect pat)) nil) (deftest search-vector.5 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :start2 25 :end2 75) unless (search-check pat target pos :start2 25 :end2 75) collect pat)) nil) (deftest search-vector.6 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :from-end t :start2 25 :end2 75) unless (search-check pat target pos :from-end t :start2 25 :end2 75) collect pat)) nil) (deftest search-vector.7 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :start2 20) unless (search-check pat target pos :start2 20) collect pat)) nil) (deftest search-vector.8 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :from-end t :start2 20) unless (search-check pat target pos :from-end t :start2 20) collect pat)) nil) (deftest search-vector.9 (let ((target (map 'vector #'(lambda (x) (sublis '((a . 1) (b . 2)) x)) *searched-list*))) (loop for pat in (mapcar #'(lambda (x) (map 'vector #'(lambda (y) (sublis '((a . 3) (b . 4)) y)) x)) *pattern-sublists*) for pos = (search pat target :start2 20 :key #'evenp) unless (search-check pat target pos :start2 20 :key #'evenp) collect pat)) nil) (deftest search-vector.10 (let ((target (map 'vector #'(lambda (x) (sublis '((a . 1) (b . 2)) x)) *searched-list*))) (loop for pat in (mapcar #'(lambda (x) (map 'vector #'(lambda (y) (sublis '((a . 3) (b . 4)) y)) x)) *pattern-sublists*) for pos = (search pat target :from-end t :start2 20 :key 'oddp) unless (search-check pat target pos :from-end t :start2 20 :key 'oddp) collect pat)) nil) (deftest search-vector.11 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :start2 20 :test (complement #'eql)) unless (search-check pat target pos :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-vector.12 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :from-end t :start2 20 :test-not #'eql) unless (search-check pat target pos :from-end t :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-vector.13 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* when (and (> (length pat) 0) (let ((pos (search pat target :start1 1 :test (complement #'eql)))) (not (search-check pat target pos :start1 1 :test (complement #'eql))))) collect pat)) nil) (deftest search-vector.14 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* when (let ((len (length pat))) (and (> len 0) (let ((pos (search pat target :end1 (1- len) :test (complement #'eql)))) (not (search-check pat target pos :end1 (1- len) :test (complement #'eql)))))) collect pat)) nil) (deftest search-vector.15 (let ((a (make-array '(10) :initial-contents '(a b b a a a b a b b) :fill-pointer 5))) (values (search '(a) a) (search '(a) a :from-end t) (search '(a b) a) (search '(a b) a :from-end t) (search '(a b a) a) (search '(a b a) a :from-end t))) 0 4 0 0 nil nil) (deftest search-vector.16 (let ((pat (make-array '(3) :initial-contents '(a b a) :fill-pointer 1)) (a #(a b b a a))) (values (search pat a) (search pat a :from-end t) (progn (setf (fill-pointer pat) 2) (search pat a)) (search pat a :from-end t) (progn (setf (fill-pointer pat) 3) (search pat a)) (search pat a :from-end t))) 0 4 0 0 nil nil) gcl/ansi-tests/simple-array-t.lsp000066400000000000000000000126341242227143400173120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 07:23:45 2003 ;;;; Contains: Tests of SIMPLE-ARRAY on T element type (in-package :cl-test) ;;; Tests of (simple-array t) (deftest simple-array-t.2.1 (notnot-mv (typep #() '(simple-array t))) t) (deftest simple-array-t.2.2 (notnot-mv (typep #0aX '(simple-array t))) t) (deftest simple-array-t.2.3 (notnot-mv (typep #2a(()) '(simple-array t))) t) (deftest simple-array-t.2.4 (notnot-mv (typep #(1 2 3) '(simple-array t))) t) (deftest simple-array-t.2.5 (typep "abcd" '(simple-array t)) nil) (deftest simple-array-t.2.6 (typep #*010101 '(simple-array t)) nil) ;;; Tests of (simple-array t ()) (deftest simple-array-t.3.1 (notnot-mv (typep #() '(simple-array t nil))) nil) (deftest simple-array-t.3.2 (notnot-mv (typep #0aX '(simple-array t nil))) t) (deftest simple-array-t.3.3 (typep #2a(()) '(simple-array t nil)) nil) (deftest simple-array-t.3.4 (typep #(1 2 3) '(simple-array t nil)) nil) (deftest simple-array-t.3.5 (typep "abcd" '(simple-array t nil)) nil) (deftest simple-array-t.3.6 (typep #*010101 '(simple-array t nil)) nil) ;;; Tests of (simple-array t 1) ;;; The '1' indicates rank, so this is equivalent to 'vector' (deftest simple-array-t.4.1 (notnot-mv (typep #() '(simple-array t 1))) t) (deftest simple-array-t.4.2 (typep #0aX '(simple-array t 1)) nil) (deftest simple-array-t.4.3 (typep #2a(()) '(simple-array t 1)) nil) (deftest simple-array-t.4.4 (notnot-mv (typep #(1 2 3) '(simple-array t 1))) t) (deftest simple-array-t.4.5 (typep "abcd" '(simple-array t 1)) nil) (deftest simple-array-t.4.6 (typep #*010101 '(simple-array t 1)) nil) ;;; Tests of (simple-array t 0) (deftest simple-array-t.5.1 (typep #() '(simple-array t 0)) nil) (deftest simple-array-t.5.2 (notnot-mv (typep #0aX '(simple-array t 0))) t) (deftest simple-array-t.5.3 (typep #2a(()) '(simple-array t 0)) nil) (deftest simple-array-t.5.4 (typep #(1 2 3) '(simple-array t 0)) nil) (deftest simple-array-t.5.5 (typep "abcd" '(simple-array t 0)) nil) (deftest simple-array-t.5.6 (typep #*010101 '(simple-array t 0)) nil) ;;; Tests of (simple-array t *) (deftest simple-array-t.6.1 (notnot-mv (typep #() '(simple-array t *))) t) (deftest simple-array-t.6.2 (notnot-mv (typep #0aX '(simple-array t *))) t) (deftest simple-array-t.6.3 (notnot-mv (typep #2a(()) '(simple-array t *))) t) (deftest simple-array-t.6.4 (notnot-mv (typep #(1 2 3) '(simple-array t *))) t) (deftest simple-array-t.6.5 (typep "abcd" '(simple-array t *)) nil) (deftest simple-array-t.6.6 (typep #*010101 '(simple-array t *)) nil) ;;; Tests of (simple-array t 2) (deftest simple-array-t.7.1 (typep #() '(simple-array t 2)) nil) (deftest simple-array-t.7.2 (typep #0aX '(simple-array t 2)) nil) (deftest simple-array-t.7.3 (notnot-mv (typep #2a(()) '(simple-array t 2))) t) (deftest simple-array-t.7.4 (typep #(1 2 3) '(simple-array t 2)) nil) (deftest simple-array-t.7.5 (typep "abcd" '(simple-array t 2)) nil) (deftest simple-array-t.7.6 (typep #*010101 '(simple-array t 2)) nil) ;;; Testing '(simple-array t (--)) (deftest simple-array-t.8.1 (typep #() '(simple-array t (1))) nil) (deftest simple-array-t.8.2 (notnot-mv (typep #() '(simple-array t (0)))) t) (deftest simple-array-t.8.3 (notnot-mv (typep #() '(simple-array t (*)))) t) (deftest simple-array-t.8.4 (typep #(a b c) '(simple-array t (2))) nil) (deftest simple-array-t.8.5 (notnot-mv (typep #(a b c) '(simple-array t (3)))) t) (deftest simple-array-t.8.6 (notnot-mv (typep #(a b c) '(simple-array t (*)))) t) (deftest simple-array-t.8.7 (typep #(a b c) '(simple-array t (4))) nil) (deftest simple-array-t.8.8 (typep #2a((a b c)) '(simple-array t (*))) nil) (deftest simple-array-t.8.9 (typep #2a((a b c)) '(simple-array t (3))) nil) (deftest simple-array-t.8.10 (typep #2a((a b c)) '(simple-array t (1))) nil) (deftest simple-array-t.8.11 (typep "abc" '(simple-array t (2))) nil) (deftest simple-array-t.8.12 (typep "abc" '(simple-array t (3))) nil) (deftest simple-array-t.8.13 (typep "abc" '(simple-array t (*))) nil) (deftest simple-array-t.8.14 (typep "abc" '(simple-array t (4))) nil) ;;; Two dimensional simple-array type tests (deftest simple-array-t.9.1 (typep #() '(simple-array t (* *))) nil) (deftest simple-array-t.9.2 (typep "abc" '(simple-array t (* *))) nil) (deftest simple-array-t.9.3 (typep #(a b c) '(simple-array t (3 *))) nil) (deftest simple-array-t.9.4 (typep #(a b c) '(simple-array t (* 3))) nil) (deftest simple-array-t.9.5 (typep "abc" '(simple-array t (3 *))) nil) (deftest simple-array-t.9.6 (typep "abc" '(simple-array t (* 3))) nil) (deftest simple-array-t.9.7 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (* *)))) t) (deftest simple-array-t.9.8 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (3 *)))) t) (deftest simple-array-t.9.9 (typep #2a((a b)(c d)(e f)) '(simple-array t (2 *))) nil) (deftest simple-array-t.9.10 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (* 2)))) t) (deftest simple-array-t.9.11 (typep #2a((a b)(c d)(e f)) '(simple-array t (* 3))) nil) (deftest simple-array-t.9.12 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (3 2)))) t) (deftest simple-array-t.9.13 (typep #2a((a b)(c d)(e f)) '(simple-array t (2 3))) nil) gcl/ansi-tests/simple-array.lsp000066400000000000000000000144521242227143400170510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 07:20:31 2003 ;;;; Contains: Tests of SIMPLE-ARRAY (in-package :cl-test) ;;; Tests of simple-array by itself (deftest simple-array.1.1 (notnot-mv (typep #() 'simple-array)) t) (deftest simple-array.1.2 (notnot-mv (typep #0aX 'simple-array)) t) (deftest simple-array.1.3 (notnot-mv (typep #2a(()) 'simple-array)) t) (deftest simple-array.1.4 (notnot-mv (typep #(1 2 3) 'simple-array)) t) (deftest simple-array.1.5 (notnot-mv (typep "abcd" 'simple-array)) t) (deftest simple-array.1.6 (notnot-mv (typep #*010101 'simple-array)) t) (deftest simple-array.1.7 (typep nil 'simple-array) nil) (deftest simple-array.1.8 (typep 'x 'simple-array) nil) (deftest simple-array.1.9 (typep '(a b c) 'simple-array) nil) (deftest simple-array.1.10 (typep 10.0 'simple-array) nil) (deftest simple-array.1.11 (typep #'(lambda (x) (cons x nil)) 'simple-array) nil) (deftest simple-array.1.12 (typep 1 'simple-array) nil) (deftest simple-array.1.13 (typep (1+ most-positive-fixnum) 'simple-array) nil) ;;; Tests of (simple-array *) (deftest simple-array.2.1 (notnot-mv (typep #() '(simple-array *))) t) (deftest simple-array.2.2 (notnot-mv (typep #0aX '(simple-array *))) t) (deftest simple-array.2.3 (notnot-mv (typep #2a(()) '(simple-array *))) t) (deftest simple-array.2.4 (notnot-mv (typep #(1 2 3) '(simple-array *))) t) (deftest simple-array.2.5 (notnot-mv (typep "abcd" '(simple-array *))) t) (deftest simple-array.2.6 (notnot-mv (typep #*010101 '(simple-array *))) t) ;;; Tests of (simple-array * ()) (deftest simple-array.3.1 (notnot-mv (typep #() '(simple-array * nil))) nil) (deftest simple-array.3.2 (notnot-mv (typep #0aX '(simple-array * nil))) t) (deftest simple-array.3.3 (typep #2a(()) '(simple-array * nil)) nil) (deftest simple-array.3.4 (typep #(1 2 3) '(simple-array * nil)) nil) (deftest simple-array.3.5 (typep "abcd" '(simple-array * nil)) nil) (deftest simple-array.3.6 (typep #*010101 '(simple-array * nil)) nil) ;;; Tests of (simple-array * 1) ;;; The '1' indicates rank, so this is equivalent to 'vector' (deftest simple-array.4.1 (notnot-mv (typep #() '(simple-array * 1))) t) (deftest simple-array.4.2 (typep #0aX '(simple-array * 1)) nil) (deftest simple-array.4.3 (typep #2a(()) '(simple-array * 1)) nil) (deftest simple-array.4.4 (notnot-mv (typep #(1 2 3) '(simple-array * 1))) t) (deftest simple-array.4.5 (notnot-mv (typep "abcd" '(simple-array * 1))) t) (deftest simple-array.4.6 (notnot-mv (typep #*010101 '(simple-array * 1))) t) ;;; Tests of (simple-array * 0) (deftest simple-array.5.1 (typep #() '(simple-array * 0)) nil) (deftest simple-array.5.2 (notnot-mv (typep #0aX '(simple-array * 0))) t) (deftest simple-array.5.3 (typep #2a(()) '(simple-array * 0)) nil) (deftest simple-array.5.4 (typep #(1 2 3) '(simple-array * 0)) nil) (deftest simple-array.5.5 (typep "abcd" '(simple-array * 0)) nil) (deftest simple-array.5.6 (typep #*010101 '(simple-array * 0)) nil) ;;; Tests of (simple-array * *) (deftest simple-array.6.1 (notnot-mv (typep #() '(simple-array * *))) t) (deftest simple-array.6.2 (notnot-mv (typep #0aX '(simple-array * *))) t) (deftest simple-array.6.3 (notnot-mv (typep #2a(()) '(simple-array * *))) t) (deftest simple-array.6.4 (notnot-mv (typep #(1 2 3) '(simple-array * *))) t) (deftest simple-array.6.5 (notnot-mv (typep "abcd" '(simple-array * *))) t) (deftest simple-array.6.6 (notnot-mv (typep #*010101 '(simple-array * *))) t) ;;; Tests of (simple-array * 2) (deftest simple-array.7.1 (typep #() '(simple-array * 2)) nil) (deftest simple-array.7.2 (typep #0aX '(simple-array * 2)) nil) (deftest simple-array.7.3 (notnot-mv (typep #2a(()) '(simple-array * 2))) t) (deftest simple-array.7.4 (typep #(1 2 3) '(simple-array * 2)) nil) (deftest simple-array.7.5 (typep "abcd" '(simple-array * 2)) nil) (deftest simple-array.7.6 (typep #*010101 '(simple-array * 2)) nil) ;;; Testing '(simple-array * (--)) (deftest simple-array.8.1 (typep #() '(simple-array * (1))) nil) (deftest simple-array.8.2 (notnot-mv (typep #() '(simple-array * (0)))) t) (deftest simple-array.8.3 (notnot-mv (typep #() '(simple-array * (*)))) t) (deftest simple-array.8.4 (typep #(a b c) '(simple-array * (2))) nil) (deftest simple-array.8.5 (notnot-mv (typep #(a b c) '(simple-array * (3)))) t) (deftest simple-array.8.6 (notnot-mv (typep #(a b c) '(simple-array * (*)))) t) (deftest simple-array.8.7 (typep #(a b c) '(simple-array * (4))) nil) (deftest simple-array.8.8 (typep #2a((a b c)) '(simple-array * (*))) nil) (deftest simple-array.8.9 (typep #2a((a b c)) '(simple-array * (3))) nil) (deftest simple-array.8.10 (typep #2a((a b c)) '(simple-array * (1))) nil) (deftest simple-array.8.11 (typep "abc" '(simple-array * (2))) nil) (deftest simple-array.8.12 (notnot-mv (typep "abc" '(simple-array * (3)))) t) (deftest simple-array.8.13 (notnot-mv (typep "abc" '(simple-array * (*)))) t) (deftest simple-array.8.14 (typep "abc" '(simple-array * (4))) nil) ;;; Two dimensional simple-array type tests (deftest simple-array.9.1 (typep #() '(simple-array * (* *))) nil) (deftest simple-array.9.2 (typep "abc" '(simple-array * (* *))) nil) (deftest simple-array.9.3 (typep #(a b c) '(simple-array * (3 *))) nil) (deftest simple-array.9.4 (typep #(a b c) '(simple-array * (* 3))) nil) (deftest simple-array.9.5 (typep "abc" '(simple-array * (3 *))) nil) (deftest simple-array.9.6 (typep "abc" '(simple-array * (* 3))) nil) (deftest simple-array.9.7 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (* *)))) t) (deftest simple-array.9.8 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (3 *)))) t) (deftest simple-array.9.9 (typep #2a((a b)(c d)(e f)) '(simple-array * (2 *))) nil) (deftest simple-array.9.10 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (* 2)))) t) (deftest simple-array.9.11 (typep #2a((a b)(c d)(e f)) '(simple-array * (* 3))) nil) (deftest simple-array.9.12 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (3 2)))) t) (deftest simple-array.9.13 (typep #2a((a b)(c d)(e f)) '(simple-array * (2 3))) nil) gcl/ansi-tests/simple-bit-vector-p.lsp000066400000000000000000000024231242227143400202410ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 20:20:27 2003 ;;;; Contains: Tests of SIMPLE-BIT-VECTOR-P (in-package :cl-test) (deftest simple-bit-vector-p.2 (notnot-mv (simple-bit-vector-p #*)) t) (deftest simple-bit-vector-p.3 (notnot-mv (simple-bit-vector-p #*00101)) t) (deftest simple-bit-vector-p.4 (simple-bit-vector-p #(0 1 1 1 0 0)) nil) (deftest simple-bit-vector-p.5 (simple-bit-vector-p "011100") nil) (deftest simple-bit-vector-p.6 (simple-bit-vector-p 0) nil) (deftest simple-bit-vector-p.7 (simple-bit-vector-p 1) nil) (deftest simple-bit-vector-p.8 (simple-bit-vector-p nil) nil) (deftest simple-bit-vector-p.9 (simple-bit-vector-p 'x) nil) (deftest simple-bit-vector-p.10 (simple-bit-vector-p '(0 1 1 0)) nil) (deftest simple-bit-vector-p.11 (simple-bit-vector-p (make-array '(2 2) :element-type 'bit :initial-element 0)) nil) (deftest simple-bit-vector-p.12 (loop for e in *universe* for p1 = (typep e 'simple-bit-vector) for p2 = (simple-bit-vector-p e) always (if p1 p2 (not p2))) t) (deftest simple-bit-vector-p.error.1 (classify-error (simple-bit-vector-p)) program-error) (deftest simple-bit-vector-p.error.2 (classify-error (simple-bit-vector-p #* #*)) program-error) gcl/ansi-tests/simple-bit-vector.lsp000066400000000000000000000026741242227143400200140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 13:12:07 2003 ;;;; Contains: Tests for type SIMPLE-BIT-VECTOR (in-package :cl-test) (deftest simple-bit-vector.2 (notnot-mv (typep #* 'simple-bit-vector)) t) (deftest simple-bit-vector.3 (notnot-mv (typep #*00101 'simple-bit-vector)) t) (deftest simple-bit-vector.4 (typep #(0 1 1 1 0 0) 'simple-bit-vector) nil) (deftest simple-bit-vector.5 (typep "011100" 'simple-bit-vector) nil) (deftest simple-bit-vector.6 (typep 0 'simple-bit-vector) nil) (deftest simple-bit-vector.7 (typep 1 'simple-bit-vector) nil) (deftest simple-bit-vector.8 (typep nil 'simple-bit-vector) nil) (deftest simple-bit-vector.9 (typep 'x 'simple-bit-vector) nil) (deftest simple-bit-vector.10 (typep '(0 1 1 0) 'simple-bit-vector) nil) (deftest simple-bit-vector.11 (typep (make-array '(2 2) :element-type 'bit :initial-element 0) 'simple-bit-vector) nil) (deftest simple-bit-vector.12 (notnot-mv (typep #* '(simple-bit-vector *))) t) (deftest simple-bit-vector.13 (notnot-mv (typep #*01101 '(simple-bit-vector *))) t) (deftest simple-bit-vector.14 (notnot-mv (typep #* '(simple-bit-vector 0))) t) (deftest simple-bit-vector.15 (typep #*01101 '(simple-bit-vector 0)) nil) (deftest simple-bit-vector.16 (typep #* '(simple-bit-vector 5)) nil) (deftest simple-bit-vector.17 (notnot-mv (typep #*01101 '(simple-bit-vector 5))) t) gcl/ansi-tests/simple-vector-p.lsp000066400000000000000000000030321242227143400174620ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 22 21:23:45 2003 ;;;; Contains: Tests for SIMPLE-VECTOR-P (in-package :cl-test) ;;; More tests for this are in make-array.lsp (deftest simple-vector-p.1 (loop for e in *universe* unless (if (typep e 'simple-vector) (simple-vector-p e) (not (simple-vector-p e))) collect e) nil) (deftest simple-vector-p.2 (notnot-mv (simple-vector-p (make-array '(10)))) t) ;; (deftest simple-vector-p.3 ;; (simple-vector-p (make-array '(5) :fill-pointer t)) ;; nil) (deftest simple-vector-p.4 (notnot-mv (simple-vector-p (vector 'a 'b 'c))) t) ;;; (deftest simple-vector-p.5 ;;; (simple-vector-p (make-array '(5) :adjustable t)) ;;; nil) ;;; (deftest simple-vector-p.6 ;;; (let ((a #(a b c d e g h))) ;;; (simple-vector-p (make-array '(5) :displaced-to a))) ;;; nil) (deftest simple-vector-p.7 (simple-vector-p #*001101) nil) (deftest simple-vector-p.8 (simple-vector-p "abcdef") nil) (deftest simple-vector-p.9 (simple-vector-p (make-array nil)) nil) (deftest simple-vector-p.10 (simple-vector-p (make-array '(10) :element-type 'base-char)) nil) (deftest simple-vector-p.11 (simple-vector-p (make-array '(10) :element-type 'character)) nil) (deftest simple-vector-p.12 (simple-vector-p (make-array '(10) :element-type 'bit)) nil) ;;; Error tests (deftest simple-vector-p.error.1 (classify-error (simple-vector-p)) program-error) (deftest simple-vector-p.error.2 (classify-error (simple-vector-p #(a b) nil)) program-error) gcl/ansi-tests/some.lsp000066400000000000000000000053221242227143400154030ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 07:07:07 2002 ;;;; Contains: Tests for SOME (in-package :cl-test) (deftest some.1 (some #'identity nil) nil) (deftest some.2 (some #'identity #()) nil) (deftest some.3 (let ((count 0)) (values (some #'(lambda (x) (incf count) (if (>= x 10) x nil)) '(1 2 4 13 5 1)) count)) 13 4) (deftest some.4 (some #'/= '(1 2 3 4) '(1 2 3 4 5)) nil) (deftest some.5 (some #'/= '(1 2 3 4 5) '(1 2 3 4)) nil) (deftest some.6 (not-mv (some #'/= '(1 2 3 4 5) '(1 2 3 4 6))) nil) (deftest some.7 (some #'(lambda (x y) (and x y)) '(nil t t nil t) #(t nil nil t nil nil)) nil) (deftest some.8 (let ((x '(1)) (args nil)) (loop for i from 1 below (1- (min 100 call-arguments-limit)) do (push x args) always (apply #'some #'/= args))) nil) (deftest some.9 (some #'zerop #*11111111111111) nil) (deftest some.10 (some #'zerop #*) nil) (deftest some.11 (not-mv (some #'zerop #*1111111011111)) nil) (deftest some.12 (some #'(lambda (x) (not (eql x #\a))) "aaaaaaaa") nil) (deftest some.13 (some #'(lambda (x) (eql x #\a)) "") nil) (deftest some.14 (not-mv (some #'(lambda (x) (not (eql x #\a))) "aaaaaabaaaa")) nil) (deftest some.15 (some 'null '(1 2 3 4)) nil) (deftest some.16 (not-mv (some 'null '(1 2 3 nil 5))) nil) (deftest some.order.1 (let ((i 0) x y) (values (some (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '(a b c d))) i x y)) nil 2 1 2) (deftest some.order.2 (let ((i 0) x y z) (values (some (progn (setf x (incf i)) #'eq) (progn (setf y (incf i)) '(a b c d)) (progn (setf z (incf i)) '(e f g h))) i x y z)) nil 3 1 2 3) (deftest some.error.1 (classify-error (some 1 '(a b c))) type-error) (deftest some.error.2 (classify-error (some #\a '(a b c))) type-error) (deftest some.error.3 (classify-error (some #() '(a b c))) type-error) (deftest some.error.4 (classify-error (some #'null 'a)) type-error) (deftest some.error.5 (classify-error (some #'null 100)) type-error) (deftest some.error.6 (classify-error (some #'null 'a)) type-error) (deftest some.error.7 (classify-error (some #'eq () 'a)) type-error) (deftest some.error.8 (classify-error (some)) program-error) (deftest some.error.9 (classify-error (some #'null)) program-error) (deftest some.error.10 (classify-error (locally (some 1 '(a b c)) t)) type-error) (deftest some.error.11 (classify-error (some #'cons '(a b c))) program-error) (deftest some.error.12 (classify-error (some #'car '(a b c))) type-error) (deftest some.error.13 (classify-error (some #'cons '(a b c) '(b c d) '(c d e))) program-error) gcl/ansi-tests/sort.lsp000066400000000000000000000060131242227143400154250ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 21 00:11:24 2002 ;;;; Contains: Tests for SORT (in-package :cl-test) (deftest sort-list.1 (let ((a (list 1 4 2 5 3))) (sort a #'<)) (1 2 3 4 5)) (deftest sort-list.2 (let ((a (list 1 4 2 5 3))) (sort a #'< :key #'-)) (5 4 3 2 1)) (deftest sort-list.3 (let ((a (list 1 4 2 5 3))) (sort a #'(lambda (x y) nil)) (sort a #'<)) (1 2 3 4 5)) (deftest sort-vector.1 (let ((a (copy-seq #(1 4 2 5 3)))) (sort a #'<)) #(1 2 3 4 5)) (deftest sort-vector.2 (let ((a (copy-seq #(1 4 2 5 3)))) (sort a #'< :key #'-)) #(5 4 3 2 1)) (deftest sort-vector.3 (let ((a (copy-seq #(1 4 2 5 3)))) (sort a #'(lambda (x y) nil)) (sort a #'<)) #(1 2 3 4 5)) (deftest sort-vector.4 (let ((a (make-array 10 :initial-contents '(10 40 20 50 30 15 45 25 55 35) :fill-pointer 5))) (sort a #'<)) #(10 20 30 40 50)) (deftest sort-bit-vector.1 (let ((a (copy-seq #*10011101))) (sort a #'<)) #*00011111) (deftest sort-bit-vector.2 (let ((a (copy-seq #*10011101))) (values (sort a #'< :key #'-) a)) #*11111000 #*11111000) (deftest sort-bit-vector.3 (let ((a (make-array 10 :initial-contents '(1 0 0 1 1 1 1 0 1 1) :element-type 'bit :fill-pointer 5))) (sort a #'<)) #*00111) (deftest sort-string.1 (let ((a (copy-seq "10011101"))) (values (sort a #'char<) a)) "00011111" "00011111") (deftest sort-string.2 (let ((a (copy-seq "10011101"))) (values (sort a #'char< :key #'(lambda (c) (if (eql c #\0) #\1 #\0))) a)) "11111000" "11111000") (deftest sort-string.3 (let ((a (make-array 10 :initial-contents "1001111011" :element-type 'character :fill-pointer 5))) (sort a #'char<)) "00111") ;;; Order of evaluation tests (deftest sort.order.1 (let ((i 0) x y) (values (sort (progn (setf x (incf i)) (list 1 7 3 2)) (progn (setf y (incf i)) #'<)) i x y)) (1 2 3 7) 2 1 2) (deftest sort.order.2 (let ((i 0) x y z) (values (sort (progn (setf x (incf i)) (list 1 7 3 2)) (progn (setf y (incf i)) #'<) :key (progn (setf z (incf i)) #'-)) i x y z)) (7 3 2 1) 3 1 2 3) ;;; Error cases (deftest sort.error.1 (classify-error (sort)) program-error) (deftest sort.error.2 (classify-error (sort nil)) program-error) (deftest sort.error.3 (classify-error (sort nil #'< :key)) program-error) (deftest sort.error.4 (classify-error (sort nil #'< 'bad t)) program-error) (deftest sort.error.5 (classify-error (sort nil #'< 'bad t :allow-other-keys nil)) program-error) (deftest sort.error.6 (classify-error (sort nil #'< 1 2)) program-error) (deftest sort.error.7 (classify-error (sort (list 1 2 3 4) #'identity)) program-error) (deftest sort.error.8 (classify-error (sort (list 1 2 3 4) #'< :key #'cons)) program-error) (deftest sort.error.9 (classify-error (sort (list 1 2 3 4) #'< :key #'car)) type-error) (deftest sort.error.10 (classify-error (sort (list 1 2 3 4) #'elt)) type-error) gcl/ansi-tests/stable-sort.lsp000066400000000000000000000074121242227143400167010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 28 21:00:44 2002 ;;;; Contains: Tests for STABLE-SORT (in-package :cl-test) (deftest stable-sort-list.1 (let ((a (list 1 4 2 5 3))) (stable-sort a #'<)) (1 2 3 4 5)) (deftest stable-sort-list.2 (let ((a (list 1 4 2 5 3))) (stable-sort a #'< :key #'-)) (5 4 3 2 1)) (deftest stable-sort-list.3 (let ((a (list 1 4 2 5 3))) (stable-sort a #'(lambda (x y) nil)) (stable-sort a #'<)) (1 2 3 4 5)) (deftest stable-sort-list.4 (let ((a (copy-seq '((1 a) (2 a) (1 b) (2 b) (1 c) (2 c))))) (stable-sort a #'(lambda (x y) (< (car x) (car y))))) ((1 a) (1 b) (1 c) (2 a) (2 b) (2 c))) (deftest stable-sort-list.5 (let ((a (reverse (copy-seq '((1 a) (2 a) (1 b) (2 b) (1 c) (2 c)))))) (stable-sort a #'(lambda (x y) (< (car x) (car y))))) ((1 c) (1 b) (1 a) (2 c) (2 b) (2 a))) (deftest stable-sort-vector.1 (let ((a (copy-seq #(1 4 2 5 3)))) (stable-sort a #'<)) #(1 2 3 4 5)) (deftest stable-sort-vector.2 (let ((a (copy-seq #(1 4 2 5 3)))) (stable-sort a #'< :key #'-)) #(5 4 3 2 1)) (deftest stable-sort-vector.3 (let ((a (copy-seq #(1 4 2 5 3)))) (stable-sort a #'(lambda (x y) nil)) (stable-sort a #'<)) #(1 2 3 4 5)) (deftest stable-sort-vector.4 (let ((a (make-array 10 :initial-contents '(10 40 20 50 30 15 45 25 55 35) :fill-pointer 5))) (stable-sort a #'<)) #(10 20 30 40 50)) (deftest stable-sort-bit-vector.1 (let ((a (copy-seq #*10011101))) (stable-sort a #'<)) #*00011111) (deftest stable-sort-bit-vector.2 (let ((a (copy-seq #*10011101))) (values (stable-sort a #'< :key #'-) a)) #*11111000 #*11111000) (deftest stable-sort-bit-vector.3 (let ((a (make-array 10 :initial-contents '(1 0 0 1 1 1 1 0 1 1) :element-type 'bit :fill-pointer 5))) (stable-sort a #'<)) #*00111) (deftest stable-sort-string.1 (let ((a (copy-seq "10011101"))) (values (stable-sort a #'char<) a)) "00011111" "00011111") (deftest stable-sort-string.2 (let ((a (copy-seq "10011101"))) (values (stable-sort a #'char< :key #'(lambda (c) (if (eql c #\0) #\1 #\0))) a)) "11111000" "11111000") (deftest stable-sort-string.3 (let ((a (make-array 10 :initial-contents "1001111011" :element-type 'character :fill-pointer 5))) (stable-sort a #'char<)) "00111") ;;; Order of evaluation tests (deftest stable-sort.order.1 (let ((i 0) x y) (values (stable-sort (progn (setf x (incf i)) (list 1 7 3 2)) (progn (setf y (incf i)) #'<)) i x y)) (1 2 3 7) 2 1 2) (deftest stable-sort.order.2 (let ((i 0) x y z) (values (stable-sort (progn (setf x (incf i)) (list 1 7 3 2)) (progn (setf y (incf i)) #'<) :key (progn (setf z (incf i)) #'-)) i x y z)) (7 3 2 1) 3 1 2 3) ;;; Error cases (deftest stable-sort.error.1 (classify-error (stable-sort)) program-error) (deftest stable-sort.error.2 (classify-error (stable-sort nil)) program-error) (deftest stable-sort.error.3 (classify-error (stable-sort nil #'< :key)) program-error) (deftest stable-sort.error.4 (classify-error (stable-sort nil #'< 'bad t)) program-error) (deftest stable-sort.error.5 (classify-error (stable-sort nil #'< 'bad t :allow-other-keys nil)) program-error) (deftest stable-sort.error.6 (classify-error (stable-sort nil #'< 1 2)) program-error) (deftest stable-sort.error.7 (classify-error (stable-sort (list 1 2 3 4) #'identity)) program-error) (deftest stable-sort.error.8 (classify-error (stable-sort (list 1 2 3 4) #'< :key #'cons)) program-error) (deftest stable-sort.error.9 (classify-error (stable-sort (list 1 2 3 4) #'< :key #'car)) type-error) (deftest stable-sort.error.10 (classify-error (stable-sort (list 1 2 3 4) #'elt)) type-error) gcl/ansi-tests/string-aux.lsp000066400000000000000000000116211242227143400165400ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 4 06:51:32 2002 ;;;; Contains: Auxiliary functions for string testing (in-package :cl-test) (defun my-string-compare (string1 string2 comparison &key (start1 0) end1 (start2 0) end2 case &aux (len1 (progn (assert (stringp string1)) (length string1))) (len2 (progn (assert (stringp string2)) (length string2))) (compare-fn (case comparison (< (if case #'char-lessp #'char<)) (<= (if case #'char-not-greaterp #'char<=)) (= (if case #'char-equal #'char=)) (/= (if case #'char-not-equal #'char/=)) (> (if case #'char-greaterp #'char>)) (>= (if case #'char-not-lessp #'char>=)) (t (error "Bad comparison arg: ~A~%" comparison)))) (equal-fn (if case #'char-equal #'char=))) (assert (integerp start1)) (assert (integerp start2)) (unless end1 (setq end1 len1)) (unless end2 (setq end2 len2)) (assert (<= 0 start1 end1)) (assert (<= 0 start2 end2)) (loop for i1 from start1 for i2 from start2 do (cond ((= i1 end1) (return (cond ((= i2 end2) ;; Both ended -- equality case (if (member comparison '(= <= >=)) end1 nil)) (t ;; string2 still extending (if (member comparison '(/= < <=)) end1 nil))))) ((= i2 end2) ;; string1 still extending (return (if (member comparison '(/= > >=)) i1 nil))) (t (let ((c1 (char string1 i1)) (c2 (char string2 i2))) (cond ((funcall equal-fn c1 c2)) (t ;; mismatch found -- what kind? (return (if (funcall compare-fn c1 c2) i1 nil))))))))) (defun make-random-string-compare-test (n) (let* ((len (random n)) ;; Lengths of the two strings (len1 (if (or (coin) (= len 0)) len (+ len (random len)))) (len2 (if (or (coin) (= len 0)) len (+ len (random len)))) ;; Lengths of the parts of the strings to be matched (sublen1 (if (or (coin) (= len1 0)) (min len1 len2) (random len1))) (sublen2 (if (or (coin) (= len2 0)) (min len2 sublen1) (random len2))) ;; Start and end of the substring of the first string (start1 (if (coin 3) 0 (max 0 (min (1- len1) (random (- len1 sublen1 -1)))))) (end1 (+ start1 sublen1)) ;; Start and end of the substring of the second string (start2 (if (coin 3) 0 (max 0 (min (1- len2) (random (- len2 sublen2 -1)))))) (end2 (+ start2 sublen2)) ;; generate the strings (s1 (make-random-string len1)) (s2 (make-random-string len2))) #| (format t "len = ~A, len1 = ~A, len2 = ~A, sublen1 = ~A, sublen2 = ~A~%" len len1 len2 sublen1 sublen2) (format t "start1 = ~A, end1 = ~A, start2 = ~A, end2 = ~A~%" start1 end1 start2 end2) (format t "s1 = ~S, s2 = ~S~%" s1 s2) |# ;; Sometimes we want them to have a common prefix (when (coin) (if (<= sublen1 sublen2) (setf (subseq s2 start2 (+ start2 sublen1)) (subseq s1 start1 (+ start1 sublen1))) (setf (subseq s1 start1 (+ start1 sublen2)) (subseq s2 start2 (+ start2 sublen2))))) (values s1 s2 (reduce #'nconc (random-permute (list (if (and (= start1 0) (coin)) nil (list :start1 start1)) (if (and (= end1 len1) (coin)) nil (list :end1 end1)) (if (and (= start2 0) (coin)) nil (list :start2 start2)) (if (and (= end2 len2) (coin)) nil (list :end2 end2)))))))) (defun random-string-compare-test (n comparison case &optional (iterations 1)) (loop for i from 1 to iterations count (multiple-value-bind (s1 s2 args) (make-random-string-compare-test n) ;; (format t "Args = ~S~%" args) (let ((x (apply (case comparison (< (if case #'string-lessp #'string<)) (<= (if case #'string-not-greaterp #'string<=)) (= (if case #'string-equal #'string=)) (/= (if case #'string-not-equal #'string/=)) (> (if case #'string-greaterp #'string>)) (>= (if case #'string-not-lessp #'string>=)) (t (error "Bad comparison arg: ~A~%" comparison))) s1 s2 args)) (y (apply #'my-string-compare s1 s2 comparison :case case args))) (not (or (eql x y) (and x y (eqt comparison '=)))))))) (defun make-random-string (n) (let ((s (random-case (make-string n) (make-array n :element-type 'character :initial-element #\a) (make-array n :element-type 'standard-char :initial-element #\a) (make-array n :element-type 'base-char :initial-element #\a)))) (if (coin) (dotimes (i n) (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4)))) (dotimes (i n) (dotimes (i n) (setf (char s i) (or (code-char (random 256)) (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" (random 62))))))) s)) (defun string-all-the-same (s) (let ((len (length s))) (or (= len 0) (let ((c (char s 0))) (loop for d across s always (eql c d)))))) gcl/ansi-tests/string-capitalize.lsp000066400000000000000000000062221242227143400200710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 3 20:08:26 2002 ;;;; Contains: Tests for STRING-CAPITALIZE (in-package :cl-test) (deftest string-capitalize.1 (let ((s "abCd")) (values (string-capitalize s) s)) "Abcd" "abCd") (deftest string-capitalize.2 (let ((s "0adA2Cdd3wXy")) (values (string-capitalize s) s)) "0ada2cdd3wxy" "0adA2Cdd3wXy") (deftest string-capitalize.3 (let ((s "1a")) (values (string-capitalize s) s)) "1a" "1a") (deftest string-capitalize.4 (let ((s "a1a")) (values (string-capitalize s) s)) "A1a" "a1a") (deftest string-capitalize.5 (let ((s #\a)) (values (string-capitalize s) s)) "A" #\a) (deftest string-capitalize.6 (let ((s '|abcDe|)) (values (string-capitalize s) (symbol-name s))) "Abcde" "abcDe") (deftest string-capitalize.7 (let ((s "ABCDEF")) (values (loop for i from 0 to 5 collect (string-capitalize s :start i)) s)) ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") "ABCDEF") (deftest string-capitalize.8 (let ((s "ABCDEF")) (values (loop for i from 0 to 5 collect (string-capitalize s :start i :end nil)) s)) ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") "ABCDEF") (deftest string-capitalize.9 (let ((s "ABCDEF")) (values (loop for i from 0 to 6 collect (string-capitalize s :end i)) s)) ("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") "ABCDEF") (deftest string-capitalize.10 (let ((s "ABCDEF")) (values (loop for i from 0 to 5 collect (loop for j from i to 6 collect (string-capitalize s :start i :end j))) s)) (("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") ("ABCDEF" "ABCDEF" "ABcDEF" "ABcdEF" "ABcdeF" "ABcdef") ("ABCDEF" "ABCDEF" "ABCdEF" "ABCdeF" "ABCdef") ("ABCDEF" "ABCDEF" "ABCDeF" "ABCDef") ("ABCDEF" "ABCDEF" "ABCDEf") ("ABCDEF" "ABCDEF")) "ABCDEF") (deftest string-capitalize.order.1 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (string-capitalize (progn (setf a (incf i)) s) :start (progn (setf b (incf i)) 1) :end (progn (setf c (incf i)) 4)) i a b c)) "aBcdef" 3 1 2 3) (deftest string-capitalize.order.2 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (string-capitalize (progn (setf a (incf i)) s) :end (progn (setf b (incf i)) 4) :start (progn (setf c (incf i)) 1)) i a b c)) "aBcdef" 3 1 2 3) ;;; Error cases (deftest string-capitalize.error.1 (classify-error (string-capitalize)) program-error) (deftest string-capitalize.error.2 (classify-error (string-capitalize (copy-seq "abc") :bad t)) program-error) (deftest string-capitalize.error.3 (classify-error (string-capitalize (copy-seq "abc") :start)) program-error) (deftest string-capitalize.error.4 (classify-error (string-capitalize (copy-seq "abc") :bad t :allow-other-keys nil)) program-error) (deftest string-capitalize.error.5 (classify-error (string-capitalize (copy-seq "abc") :end)) program-error) (deftest string-capitalize.error.6 (classify-error (string-capitalize (copy-seq "abc") 1 2)) program-error) gcl/ansi-tests/string-comparisons.lsp000066400000000000000000000322311242227143400203000ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 4 06:32:41 2002 ;;;; Contains: Tests of string comparison functions (in-package :cl-test) (deftest string=.1 (not (string= "abc" (copy-seq "abc"))) nil) (deftest string=.2 (string= "A" "a") nil) (deftest string=.3 (not (string= #\a "a")) nil) (deftest string=.4 (not (string= '|abc| (copy-seq "abc"))) nil) (deftest string=.5 (not (string= (copy-seq "abc") '#:|abc|)) nil) ;;; Test that it doesn't stop at null characters (deftest string=.6 (let ((s1 (copy-seq "abc")) (s2 (copy-seq "abd")) (c (or (code-char 0) #\a))) (setf (char s1 1) c) (setf (char s2 1) c) (values (length s1) (length s2) (string= s1 s2))) 3 3 nil) (deftest string=.7 (loop for i from 0 to 3 collect (not (string= "abc" "abd" :start1 0 :end1 i :end2 i))) (nil nil nil t)) (deftest string=.8 (loop for i from 0 to 3 collect (not (string= "abc" "ab" :end1 i))) (t t nil t)) (deftest string=.9 (loop for i from 0 to 3 collect (not (string= "abc" "abd" :start2 0 :end2 i :end1 i))) (nil nil nil t)) (deftest string=.10 (loop for i from 0 to 3 collect (not (string= "ab" "abc" :end2 i))) (t t nil t)) (deftest string=.11 (loop for i from 0 to 3 collect (not (string= "xyab" "ab" :start1 i))) (t t nil t)) (deftest string=.12 (loop for i from 0 to 3 collect (not (string= "ab" "xyab" :start2 i))) (t t nil t)) (deftest string=.13 (loop for i from 0 to 3 collect (not (string= "xyab" "ab" :start1 i :end1 nil))) (t t nil t)) (deftest string=.14 (loop for i from 0 to 3 collect (not (string= "ab" "xyab" :start2 i :end2 nil))) (t t nil t)) ;;; Order of evaluation (deftest string=.order.1 (let ((i 0) x y) (values (string= (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string=.order.2 (let ((i 0) a b c d e f) (values (string= (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string=.order.3 (let ((i 0) a b c d e f) (values (string= (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string<=.order.1 (let ((i 0) x y) (values (string<= (progn (setf x (incf i)) "abf") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string<=.order.2 (let ((i 0) a b c d e f) (values (string<= (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string<=.order.3 (let ((i 0) a b c d e f) (values (string<= (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string<.order.1 (let ((i 0) x y) (values (string< (progn (setf x (incf i)) "abf") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string<.order.2 (let ((i 0) a b c d e f) (values (string< (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string<.order.3 (let ((i 0) a b c d e f) (values (string< (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string/=.order.1 (let ((i 0) x y) (values (string/= (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abc")) i x y)) nil 2 1 2) (deftest string/=.order.2 (let ((i 0) a b c d e f) (values (string/= (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abc") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string/=.order.3 (let ((i 0) a b c d e f) (values (string/= (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abc") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string>=.order.1 (let ((i 0) x y) (values (string<= (progn (setf x (incf i)) "abf") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string>=.order.2 (let ((i 0) a b c d e f) (values (string>= (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string>=.order.3 (let ((i 0) a b c d e f) (values (string>= (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string>.order.1 (let ((i 0) x y) (values (string> (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string>.order.2 (let ((i 0) a b c d e f) (values (string> (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string>.order.3 (let ((i 0) a b c d e f) (values (string> (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-equal.order.1 (let ((i 0) x y) (values (string-equal (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string-equal.order.2 (let ((i 0) a b c d e f) (values (string-equal (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-equal.order.3 (let ((i 0) a b c d e f) (values (string-equal (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-not-greaterp.order.1 (let ((i 0) x y) (values (string-not-greaterp (progn (setf x (incf i)) "abf") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string-not-greaterp.order.2 (let ((i 0) a b c d e f) (values (string-not-greaterp (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-not-greaterp.order.3 (let ((i 0) a b c d e f) (values (string-not-greaterp (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-lessp.order.1 (let ((i 0) x y) (values (string-lessp (progn (setf x (incf i)) "abf") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string-lessp.order.2 (let ((i 0) a b c d e f) (values (string-lessp (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-lessp.order.3 (let ((i 0) a b c d e f) (values (string-lessp (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-not-equal.order.1 (let ((i 0) x y) (values (string-not-equal (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abc")) i x y)) nil 2 1 2) (deftest string-not-equal.order.2 (let ((i 0) a b c d e f) (values (string-not-equal (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abc") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-not-equal.order.3 (let ((i 0) a b c d e f) (values (string-not-equal (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abc") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-not-lessp.order.1 (let ((i 0) x y) (values (string-not-lessp (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string-not-lessp.order.2 (let ((i 0) a b c d e f) (values (string-not-lessp (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-not-lessp.order.3 (let ((i 0) a b c d e f) (values (string-not-lessp (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-greaterp.order.1 (let ((i 0) x y) (values (string-greaterp (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string-greaterp.order.2 (let ((i 0) a b c d e f) (values (string-greaterp (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-greaterp.order.3 (let ((i 0) a b c d e f) (values (string-greaterp (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) ;;; Random tests (of all the string comparson functions) (deftest random-string-comparison-tests (loop for cmp in '(= /= < > <= >=) append (loop for case in '(nil t) collect (list cmp case (random-string-compare-test 10 cmp case 1000)))) ((= nil 0) (= t 0) (/= nil 0) (/= t 0) (< nil 0) (< t 0) (> nil 0) (> t 0) (<= nil 0) (<= t 0) (>= nil 0) (>= t 0))) gcl/ansi-tests/string-downcase.lsp000066400000000000000000000064551242227143400175570ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 30 21:41:59 2002 ;;;; Contains: Tests for STRING-DOWNCASE (in-package :cl-test) (deftest string-downcase.1 (let ((s "A")) (values (string-downcase s) s)) "a" "A") (deftest string-downcase.2 (let ((s "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) (values (string-downcase s) s)) "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") (deftest string-downcase.3 (let ((s "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) (values (string-downcase s) s)) "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ " "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") (deftest string-downcase.4 (string-downcase #\A) "a") (deftest string-downcase.5 (let ((sym '|A|)) (values (string-downcase sym) sym)) "a" |A|) (deftest string-downcase.6 (let ((s (make-array 6 :element-type 'character :initial-contents '(#\A #\B #\C #\D #\E #\F)))) (values (string-downcase s) s)) "abcdef" "ABCDEF") (deftest string-downcase.7 (let ((s (make-array 6 :element-type 'standard-char :initial-contents '(#\A #\B #\7 #\D #\E #\F)))) (values (string-downcase s) s)) "ab7def" "AB7DEF") ;; Tests with :start, :end (deftest string-downcase.8 (let ((s "ABCDEF")) (values (loop for i from 0 to 6 collect (string-downcase s :start i)) s)) ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") "ABCDEF") (deftest string-downcase.9 (let ((s "ABCDEF")) (values (loop for i from 0 to 6 collect (string-downcase s :start i :end nil)) s)) ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") "ABCDEF") (deftest string-downcase.10 (let ((s "ABCDE")) (values (loop for i from 0 to 4 collect (loop for j from i to 5 collect (string-invertcase (string-downcase s :start i :end j)))) s)) (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") ("abcde" "abCde" "abCDe" "abCDE") ("abcde" "abcDe" "abcDE") ("abcde" "abcdE")) "ABCDE") (deftest string-downcase.order.1 (let ((i 0) a b c (s (copy-seq "ABCDEF"))) (values (string-downcase (progn (setf a (incf i)) s) :start (progn (setf b (incf i)) 1) :end (progn (setf c (incf i)) 4)) i a b c)) "AbcdEF" 3 1 2 3) (deftest string-downcase.order.2 (let ((i 0) a b c (s (copy-seq "ABCDEF"))) (values (string-downcase (progn (setf a (incf i)) s) :end (progn (setf b (incf i)) 4) :start (progn (setf c (incf i)) 1)) i a b c)) "AbcdEF" 3 1 2 3) ;;; Error cases (deftest string-downcase.error.1 (classify-error (string-downcase)) program-error) (deftest string-downcase.error.2 (classify-error (string-downcase (copy-seq "abc") :bad t)) program-error) (deftest string-downcase.error.3 (classify-error (string-downcase (copy-seq "abc") :start)) program-error) (deftest string-downcase.error.4 (classify-error (string-downcase (copy-seq "abc") :bad t :allow-other-keys nil)) program-error) (deftest string-downcase.error.5 (classify-error (string-downcase (copy-seq "abc") :end)) program-error) (deftest string-downcase.error.6 (classify-error (string-downcase (copy-seq "abc") 1 2)) program-error) gcl/ansi-tests/string-left-trim.lsp000066400000000000000000000071531242227143400176530ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 4 04:57:41 2002 ;;;; Contains: Tests for STRING-LEFT-TRIM (in-package :cl-test) (deftest string-left-trim.1 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.2 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim '(#\a #\b) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.3 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim #(#\a #\b) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.4 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b)) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.5 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'character) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.6 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'standard-char) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.7 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'base-char) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.8 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) :element-type 'character :fill-pointer 2) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.9 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'character )) (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.10 (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'character :fill-pointer 7)) (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.11 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'standard-char )) (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.12 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'base-char )) (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") ;;; Test that trimming is case sensitive (deftest string-left-trim.13 (let* ((s (copy-seq "aA")) (s2 (string-left-trim "a" s))) (values s s2)) "aA" "A") (deftest string-left-trim.14 (let* ((s '|abcdaba|) (s2 (string-left-trim "ab" s))) (values (symbol-name s) s2)) "abcdaba" "cdaba") (deftest string-left-trim.15 (string-left-trim "abc" "") "") (deftest string-left-trim.16 (string-left-trim "a" #\a) "") (deftest string-left-trim.17 (string-left-trim "b" #\a) "a") (deftest string-left-trim.18 (string-left-trim "" (copy-seq "abcde")) "abcde") (deftest string-left-trim.19 (string-left-trim "abc" (copy-seq "abcabcabc")) "") (deftest string-left-trim.order.1 (let ((i 0) x y) (values (string-left-trim (progn (setf x (incf i)) " ") (progn (setf y (incf i)) (copy-seq " abc d e f "))) i x y)) "abc d e f " 2 1 2) ;;; Error cases (deftest string-left-trim.error.1 (classify-error (string-left-trim)) program-error) (deftest string-left-trim.error.2 (classify-error (string-left-trim "abc")) program-error) (deftest string-left-trim.error.3 (classify-error (string-left-trim "abc" "abcdddabc" nil)) program-error) gcl/ansi-tests/string-right-trim.lsp000066400000000000000000000072151242227143400200350ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 4 04:59:46 2002 ;;;; Contains: Tests of STRING-RIGHT-TRIM (in-package :cl-test) (deftest string-right-trim.1 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.2 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim '(#\a #\b) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.3 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim #(#\a #\b) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.4 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b)) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.5 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'character) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.6 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'standard-char) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.7 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'base-char) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.8 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) :element-type 'character :fill-pointer 2) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.9 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'character )) (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.10 (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'character :fill-pointer 7)) (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.11 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'standard-char )) (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.12 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'base-char )) (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") ;;; Test that trimming is case sensitive (deftest string-right-trim.13 (let* ((s (copy-seq "Aa")) (s2 (string-right-trim "a" s))) (values s s2)) "Aa" "A") (deftest string-right-trim.14 (let* ((s '|abcdaba|) (s2 (string-right-trim "ab" s))) (values (symbol-name s) s2)) "abcdaba" "abcd") (deftest string-right-trim.15 (string-right-trim "abc" "") "") (deftest string-right-trim.16 (string-right-trim "a" #\a) "") (deftest string-right-trim.17 (string-right-trim "b" #\a) "a") (deftest string-right-trim.18 (string-right-trim "" (copy-seq "abcde")) "abcde") (deftest string-right-trim.19 (string-right-trim "abc" (copy-seq "abcabcabc")) "") (deftest string-right-trim.order.1 (let ((i 0) x y) (values (string-right-trim (progn (setf x (incf i)) " ") (progn (setf y (incf i)) (copy-seq " abc d e f "))) i x y)) " abc d e f" 2 1 2) ;;; Error cases (deftest string-right-trim.error.1 (classify-error (string-right-trim)) program-error) (deftest string-right-trim.error.2 (classify-error (string-right-trim "abc")) program-error) (deftest string-right-trim.error.3 (classify-error (string-right-trim "abc" "abcdddabc" nil)) program-error) gcl/ansi-tests/string-trim.lsp000066400000000000000000000065151242227143400167240ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 3 21:53:38 2002 ;;;; Contains: Tests for STRING-TRIM (in-package :cl-test) (deftest string-trim.1 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.2 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim '(#\a #\b) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.3 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim #(#\a #\b) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.4 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b)) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.5 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'character) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.6 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'standard-char) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.7 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'base-char) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.8 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) :element-type 'character :fill-pointer 2) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.9 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'character )) (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.10 (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'character :fill-pointer 7)) (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.11 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'standard-char )) (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.12 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'base-char )) (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") ;;; Test that trimming is case sensitive (deftest string-trim.13 (let* ((s (copy-seq "Aa")) (s2 (string-trim "a" s))) (values s s2)) "Aa" "A") (deftest string-trim.14 (let* ((s '|abcdaba|) (s2 (string-trim "ab" s))) (values (symbol-name s) s2)) "abcdaba" "cd") (deftest string-trim.15 (string-trim "abc" "") "") (deftest string-trim.16 (string-trim "a" #\a) "") (deftest string-trim.17 (string-trim "b" #\a) "a") (deftest string-trim.18 (string-trim "" (copy-seq "abcde")) "abcde") (deftest string-trim.19 (string-trim "abc" (copy-seq "abcabcabc")) "") (deftest string-trim.order.1 (let ((i 0) x y) (values (string-trim (progn (setf x (incf i)) " ") (progn (setf y (incf i)) (copy-seq " abc d e f "))) i x y)) "abc d e f" 2 1 2) ;;; Error cases (deftest string-trim.error.1 (classify-error (string-trim)) program-error) (deftest string-trim.error.2 (classify-error (string-trim "abc")) program-error) (deftest string-trim.error.3 (classify-error (string-trim "abc" "abcdddabc" nil)) program-error) gcl/ansi-tests/string-upcase.lsp000066400000000000000000000063251242227143400172300ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Oct 1 07:51:00 2002 ;;;; Contains: Tests for STRING-UPCASE (in-package :cl-test) (deftest string-upcase.1 (let ((s "a")) (values (string-upcase s) s)) "A" "a") (deftest string-upcase.2 (let ((s "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) (values (string-upcase s) s)) "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") (deftest string-upcase.3 (let ((s "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) (values (string-upcase s) s)) "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ " "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") (deftest string-upcase.4 (string-upcase #\a) "A") (deftest string-upcase.5 (let ((sym '|a|)) (values (string-upcase sym) sym)) "A" |a|) (deftest string-upcase.6 (let ((s (make-array 6 :element-type 'character :initial-contents '(#\a #\b #\c #\d #\e #\f)))) (values (string-upcase s) s)) "ABCDEF" "abcdef") (deftest string-upcase.7 (let ((s (make-array 6 :element-type 'standard-char :initial-contents '(#\a #\b #\7 #\d #\e #\f)))) (values (string-upcase s) s)) "AB7DEF" "ab7def") ;; Tests with :start, :end (deftest string-upcase.8 (let ((s "abcdef")) (values (loop for i from 0 to 6 collect (string-upcase s :start i)) s)) ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef") "abcdef") (deftest string-upcase.9 (let ((s "abcdef")) (values (loop for i from 0 to 6 collect (string-upcase s :start i :end nil)) s)) ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef") "abcdef") (deftest string-upcase.10 (let ((s "abcde")) (values (loop for i from 0 to 4 collect (loop for j from i to 5 collect (string-upcase s :start i :end j))) s)) (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") ("abcde" "abCde" "abCDe" "abCDE") ("abcde" "abcDe" "abcDE") ("abcde" "abcdE")) "abcde") (deftest string-upcase.order.1 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (string-upcase (progn (setf a (incf i)) s) :start (progn (setf b (incf i)) 1) :end (progn (setf c (incf i)) 4)) i a b c)) "aBCDef" 3 1 2 3) (deftest string-upcase.order.2 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (string-upcase (progn (setf a (incf i)) s) :end (progn (setf b (incf i)) 4) :start (progn (setf c (incf i)) 1)) i a b c)) "aBCDef" 3 1 2 3) ;;; Error cases (deftest string-upcase.error.1 (classify-error (string-upcase)) program-error) (deftest string-upcase.error.2 (classify-error (string-upcase (copy-seq "abc") :bad t)) program-error) (deftest string-upcase.error.3 (classify-error (string-upcase (copy-seq "abc") :start)) program-error) (deftest string-upcase.error.4 (classify-error (string-upcase (copy-seq "abc") :bad t :allow-other-keys nil)) program-error) (deftest string-upcase.error.5 (classify-error (string-upcase (copy-seq "abc") :end)) program-error) (deftest string-upcase.error.6 (classify-error (string-upcase (copy-seq "abc") 1 2)) program-error) gcl/ansi-tests/string.lsp000066400000000000000000000077421242227143400157560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 30 19:16:59 2002 ;;;; Contains: Tests for string related functions and classes (in-package :cl-test) (deftest string.1 (subtypep* 'string 'array) t t) (deftest string.2 (subtypep* 'string 'vector) t t) (deftest string.3 (subtypep* 'string 'sequence) t t) (deftest string.4 (let ((s (string #\a))) (values (notnot (stringp s)) s)) t "a") (deftest string.5 (let ((s (string ""))) (values (notnot (stringp s)) s)) t "") (deftest string.6 (let ((s (string '|FOO|))) (values (notnot (stringp s)) s)) t "FOO") (deftest string.7 (loop for x in *universe* always (handler-case (stringp (string x)) (type-error () :caught))) t) ;;; Tests of base-string (deftest base-string.1 (subtypep* 'base-string 'string) t t) (deftest base-string.2 (subtypep* 'base-string 'vector) t t) (deftest base-string.3 (subtypep* 'base-string 'array) t t) (deftest base-string.4 (subtypep* 'base-string 'sequence) t t) ;;; Tests of simple-string (deftest simple-string.1 (subtypep* 'simple-string 'string) t t) (deftest simple-string.2 (subtypep* 'simple-string 'vector) t t) (deftest simple-string.3 (subtypep* 'simple-string 'simple-array) t t) (deftest simple-string.4 (subtypep* 'simple-string 'array) t t) (deftest simple-string.5 (subtypep* 'simple-string 'sequence) t t) ;;; Tests for simple-base-string (deftest simple-base-string.1 (subtypep* 'simple-base-string 'string) t t) (deftest simple-base-string.2 (subtypep* 'simple-base-string 'vector) t t) (deftest simple-base-string.3 (subtypep* 'simple-base-string 'simple-array) t t) (deftest simple-base-string.4 (subtypep* 'simple-base-string 'array) t t) (deftest simple-base-string.5 (subtypep* 'simple-base-string 'sequence) t t) (deftest simple-base-string.6 (subtypep* 'simple-base-string 'base-string) t t) (deftest simple-base-string.7 (subtypep* 'simple-base-string 'simple-string) t t) (deftest simple-base-string.8 (subtypep* 'simple-base-string 'simple-vector) nil t) ;;; Tests for simple-string-p (deftest simple-string-p.1 (loop for x in *universe* always (if (typep x 'simple-string) (simple-string-p x) (not (simple-string-p x)))) t) (deftest simple-string-p.2 (notnot (simple-string-p "ancd")) t) (deftest simple-string-p.3 (simple-string-p 0) nil) (deftest simple-string-p.4 (simple-string-p (make-array 4 :element-type 'character :initial-contents '(#\a #\a #\a #\b) :fill-pointer t)) nil) (deftest simple-string-p.5 (notnot (simple-string-p (make-array 4 :element-type 'base-char :initial-contents '(#\a #\a #\a #\b)))) t) (deftest simple-string-p.6 (notnot (simple-string-p (make-array 4 :element-type 'standard-char :initial-contents '(#\a #\a #\a #\b)))) t) (deftest simple-string-p.7 (let* ((s (make-array 10 :element-type 'character :initial-element #\a)) (s2 (make-array 4 :element-type 'character :displaced-to s :displaced-index-offset 2))) (simple-string-p s2)) nil) ;;; Tests of stringp (deftest stringp.1 (loop for x in *universe* always (if (typep x 'string) (stringp x) (not (stringp x)))) t) (deftest stringp.2 (notnot (stringp "abcd")) t) (deftest stringp.3 (notnot (stringp (make-array 4 :element-type 'character :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.4 (notnot (stringp (make-array 4 :element-type 'base-char :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.5 (notnot (stringp (make-array 4 :element-type 'standard-char :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.6 (stringp 0) nil) (deftest stringp.7 (stringp #\a) nil) (deftest stringp.8 (let* ((s (make-array 10 :element-type 'character :initial-element #\a)) (s2 (make-array 4 :element-type 'character :displaced-to s :displaced-index-offset 2))) (notnot (stringp s2))) t) gcl/ansi-tests/structure-00.lsp000066400000000000000000000415511242227143400167210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 9 11:21:25 1998 ;;;; Contains: Common code for creating structure tests (in-package :cl-test) (declaim (optimize (safety 3))) (defun make-struct-test-name (structure-name n) ;; (declare (type (or string symbol character) structure-name) ;; (type fixnum n)) (assert (typep structure-name '(or string symbol character))) ;; (assert (typep n 'fixnum)) (setf structure-name (string structure-name)) (intern (concatenate 'string structure-name "/" (princ-to-string n)))) (defun make-struct-p-fn (structure-name) (assert (typep structure-name '(or string symbol character))) (setf structure-name (string structure-name)) (intern (concatenate 'string structure-name (string '#:-p)))) (defun make-struct-copy-fn (structure-name) (assert (typep structure-name '(or string symbol character))) (setf structure-name (string structure-name)) (intern (concatenate 'string (string '#:copy-) structure-name))) (defun make-struct-field-fn (conc-name field-name) "Make field accessor for a field in a structure" (cond ((null conc-name) field-name) (t (assert (typep conc-name '(or string symbol character))) (assert (typep field-name '(or string symbol character))) (setf conc-name (string conc-name)) (setf field-name (string field-name)) (intern (concatenate 'string conc-name field-name))))) (defun make-struct-make-fn (structure-name) "Make the make- function for a structure" (assert (typep structure-name '(or string symbol character))) (setf structure-name (string structure-name)) (intern (concatenate 'string (string '#:make-) structure-name))) (defun create-instance-of-type (type) "Return an instance of a type. Signal an error if it can't figure out a value for the type." (cond ((eqt type t) ;; anything 'a) ((eqt type 'symbol) 'b) ((eqt type 'null) nil) ((eqt type 'boolean) t) ((eqt type 'keyword) :foo) ((eqt type nil) (error "Cannot obtain element of type ~S~%" type)) ((eqt type 'cons) (cons 'a 'b)) ((eqt type 'list) (list 1 2 3)) ((eqt type 'fixnum) 17) ((eqt type 'bignum) (let ((x 1)) (loop until (typep x 'bignum) do (setq x (* 2 x))) x)) ((and (symbolp type) (typep type 'structure-class)) (let ((make-fn (intern (concatenate 'string (string '#:make-) (symbol-name type)) (symbol-package type)))) (eval (list make-fn)))) ((eqt type 'character) #\w) ((eqt type 'base-char) #\z) ((member type '(integer unsigned-byte signed-byte)) 35) ((eqt type 'bit) 1) ((and (consp type) (consp (cdr type)) (consp (cddr type)) (null (cdddr type)) (eqt (car type) 'integer) (integerp (second type))) (second type)) ((member type '(float single-float long-float double-float short-float)) 0.0) ((and (consp type) (eqt (car type) 'member) (consp (cdr type))) (second type)) ((and (consp type) (eqt (car type) 'or) (consp (second type))) (create-instance-of-type (second type))) (t (error "Cannot generate element for type ~S~%" type)))) (defun find-option (option-list option &optional default) (loop for opt in option-list when (or (eq opt option) (and (consp opt) (eq (car opt) option))) return opt finally (return default))) (defvar *defstruct-with-tests-names* nil "Names of structure types defined with DEFSRUCT-WITH-TESTS.") #| (defvar *subtypep-works-with-classes* t "Becomes NIL if SUBTYPEP doesn't work with classes. We test this first to avoid repeated test failures that cause GCL to bomb.") (deftest subtypep-works-with-classes (let ((c1 (find-class 'vector))) ;; (setq *subtypep-works-with-classes* nil) (subtypep c1 'vector) (subtypep 'vector c1) ;; (setq *subtypep-works-with-classes* t)) t) (defvar *typep-works-with-classes* t "Becomes NIL if TYPEP doesn't work with classes. We test this first to avoid repeated test failures that cause GCL to bomb.") (deftest typep-works-with-classes (let ((c1 (find-class 'vector))) ;; (setq *typep-works-with-classes* nil) (typep #(0 0) c1) ;; (setq *typep-works-with-classes* t)) t) |# ;; ;; There are a number of standardized tests for ;; structures. The following macro generates the ;; structure definition and the tests. ;; (defmacro defstruct-with-tests (name-and-options &body slot-descriptions-and-documentation) "Construct standardized tests for a defstruct, and also do the defstruct." (defstruct-with-tests-fun name-and-options slot-descriptions-and-documentation)) (defun defstruct-with-tests-fun (name-and-options slot-descriptions-and-documentation) ;; Function called from macro defstruct-with-tests (let* ( ;; Either NIL or the documentation string for the structure (doc-string (when (and (consp slot-descriptions-and-documentation) (stringp (car slot-descriptions-and-documentation))) (car slot-descriptions-and-documentation))) ;; The list of slot descriptions that follows either the ;; name and options or the doc string (slot-descriptions (if doc-string (cdr slot-descriptions-and-documentation) slot-descriptions-and-documentation)) ;; The name of the structure (should be a symbol) (name (if (consp name-and-options) (car name-and-options) name-and-options)) ;; The options list, or NIL if there were no options (options (if (consp name-and-options) (cdr name-and-options) nil)) ;; List of symbols that are the names of the slots (slot-names (loop for x in slot-descriptions collect (if (consp x) (car x) x))) ;; List of slot types, if any (slot-types (loop for x in slot-descriptions collect (if (consp x) (getf (cddr x) :type :none) :none))) ;; read-only flags for slots (slot-read-only (loop for x in slot-descriptions collect (and (consp x) (getf (cddr x) :read-only)))) ;; Symbol obtained by prepending MAKE- to the name symbol (make-fn (make-struct-make-fn name)) ;; The type option, if specified (type-option (find-option options :type)) (struct-type (second type-option)) (named-option (find-option options :named)) (include-option (find-option options :include)) ;; The :predicate option entry from OPTIONS, or NIL if none (predicate-option (find-option options :predicate)) ;; The name of the -P function, either the default or the ;; one specified in the :predicate option (p-fn-default (make-struct-p-fn name)) (p-fn (cond ((and type-option (not named-option)) nil) ((or (eq predicate-option :predicate) (null (cdr predicate-option))) p-fn-default) ((cadr predicate-option) (cadr predicate-option)) (t nil))) ;; The :copier option, or NIL if no such option specified (copier-option (find-option options :copier)) ;; The name of the copier function, either the default or ;; one speciefied in the :copier option (copy-fn-default (make-struct-copy-fn name)) (copy-fn (cond ((or (eq copier-option :copier) (null (cdr copier-option))) copy-fn-default) ((cadr copier-option) (cadr copier-option)) (t nil))) ;; The :conc-name option, or NIL if none specified (conc-option (find-option options :conc-name)) ;; String to be prepended to slot names to get the ;; slot accessor function (conc-prefix-default (concatenate 'string (string name) "-")) (conc-prefix (cond ((null conc-option) conc-prefix-default) ((or (eq conc-option :conc-name) (null (cadr conc-option))) nil) (t (string (cadr conc-option))))) (initial-offset-option (find-option options :initial-offset)) (initial-offset (second initial-offset-option)) ;; Accessor names (field-fns (loop for slot-name in slot-names collect (make-struct-field-fn conc-prefix slot-name))) ;; a list of initial values (initial-value-alist (loop for slot-desc in slot-descriptions for slot-name in slot-names for type in slot-types for i from 1 collect (if (not (eq type :none)) (cons slot-name (create-instance-of-type type)) (cons slot-name (defstruct-maketemp name "SLOTTEMP" i))))) ) ;; Build the tests in an eval-when form `(eval-when (compile load eval) (ignore-errors (eval '(defstruct ,name-and-options ,@slot-descriptions-and-documentation)) ,(unless (or type-option include-option) `(pushnew ',name *defstruct-with-tests-names*)) nil) ;; Test that structure is of the correct type (deftest ,(make-struct-test-name name 1) (and (fboundp (quote ,make-fn)) (functionp (function ,make-fn)) (symbol-function (quote ,make-fn)) (typep (,make-fn) (quote ,(if type-option struct-type name))) t) t) ;; Test that the predicate exists ,@(when p-fn `((deftest ,(make-struct-test-name name 2) (let ((s (,make-fn))) (and (fboundp (quote ,p-fn)) (functionp (function ,p-fn)) (symbol-function (quote ,p-fn)) (notnot (funcall #',p-fn s)) (notnot-mv (,p-fn s)) )) t) (deftest ,(make-struct-test-name name "ERROR.1") (classify-error (,p-fn)) program-error) (deftest ,(make-struct-test-name name "ERROR.2") (classify-error (,p-fn (,make-fn) nil)) program-error) )) ;; Test that the elements of *universe* are not ;; of this type ,@(when p-fn `((deftest ,(make-struct-test-name name 3) (count-if (function ,p-fn) *universe*) 0))) ,@(unless type-option `((deftest ,(make-struct-test-name name 4) (count-if (function (lambda (x) (typep x (quote ,name)))) *universe*) 0))) ;; Check that the fields can be read after being initialized (deftest ,(make-struct-test-name name 5) ,(let ((inits nil) (tests nil) (var (defstruct-maketemp name "TEMP-5"))) (loop for (slot-name . initval) in initial-value-alist for field-fn in field-fns do (setf inits (list* (intern (string slot-name) "KEYWORD") (list 'quote initval) inits)) (push `(and (eqlt (quote ,initval) (,field-fn ,var)) (eqlt (quote ,initval) (funcall #',field-fn ,var))) tests)) `(let ((,var (,make-fn . ,inits))) (and ,@tests t))) t) (deftest ,(make-struct-test-name name "ERROR.3") (remove nil (list ,@(loop for (slot-name . initval) in initial-value-alist for field-fn in field-fns collect `(let ((x (classify-error (,field-fn)))) (unless (eqt x 'program-error) (list ',slot-name ',field-fn x)))))) nil) (deftest ,(make-struct-test-name name "ERROR.4") (remove nil (list ,@(loop for (slot-name . initval) in initial-value-alist for field-fn in field-fns collect `(let ((x (classify-error (,field-fn (,make-fn) nil)))) (unless (eqt x 'program-error) (list ',slot-name ',field-fn x)))))) nil) ;; Check that two invocations return different structures (deftest ,(make-struct-test-name name 6) (eqt (,make-fn) (,make-fn)) nil) ;; Check that we can setf the fields (deftest ,(make-struct-test-name name 7) ,(let* ((var (defstruct-maketemp name "TEMP-7-1")) (var2 (defstruct-maketemp name "TEMP-7-2")) (tests (loop for (slot-name . initval) in initial-value-alist for read-only-p in slot-read-only for slot-desc in slot-descriptions for field-fn in field-fns unless read-only-p collect `(let ((,var2 (quote ,initval))) (setf (,field-fn ,var) ,var2) (eqlt (,field-fn ,var) ,var2))))) `(let ((,var (,make-fn))) (and ,@tests t))) t) ;; Check that the copy function exists ,@(when copy-fn `((deftest ,(make-struct-test-name name 8) (and (fboundp (quote ,copy-fn)) (functionp (function ,copy-fn)) (symbol-function (quote ,copy-fn)) t) t) (deftest ,(make-struct-test-name name "ERROR.5") (classify-error (,copy-fn)) program-error) (deftest ,(make-struct-test-name name "ERROR.6") (classify-error (,copy-fn (,make-fn) nil)) program-error) )) ;; Check that the copy function properly copies fields ,@(when copy-fn `((deftest ,(make-struct-test-name name 9) ,(let* ((var 'XTEMP-9) (var2 'YTEMP-9) (var3 'ZTEMP-9)) `(let ((,var (,make-fn ,@(loop for (slot-name . initval) in initial-value-alist nconc (list (intern (string slot-name) "KEYWORD") `(quote ,initval)))))) (let ((,var2 (,copy-fn ,var)) (,var3 (funcall #',copy-fn ,var))) (and (not (eqlt ,var ,var2)) (not (eqlt ,var ,var3)) (not (eqlt ,var2 ,var3)) ,@(loop for (slot-name . nil) in initial-value-alist for fn in field-fns collect `(and (eqlt (,fn ,var) (,fn ,var2)) (eqlt (,fn ,var) (,fn ,var3)))) t)))) t))) ;; When the predicate is not the default, check ;; that the default is not defined. Tests should ;; be designed so that this function name doesn't ;; collide with anything else. ,@(unless (eq p-fn p-fn-default) `((deftest ,(make-struct-test-name name 10) (fboundp (quote ,p-fn-default)) nil))) ;; When the copy function name is not the default, check ;; that the default function is not defined. Tests should ;; be designed so that this name is not accidently defined ;; for something else. ,@(unless (eq copy-fn copy-fn-default) `((deftest ,(make-struct-test-name name 11) (fboundp (quote ,copy-fn-default)) nil))) ;; When there are read-only slots, test that the SETF ;; form for them is not FBOUNDP ,@(when (loop for x in slot-read-only thereis x) `((deftest ,(make-struct-test-name name 12) (and ,@(loop for slot-name in slot-names for read-only in slot-read-only for field-fn in field-fns when read-only collect `(not-mv (fboundp '(setf ,field-fn)))) t) t))) ;; When the structure is a true structure type, check that ;; the various class relationships hold ,@(unless type-option `( (deftest ,(make-struct-test-name name 13) (notnot-mv (typep (,make-fn) (find-class (quote ,name)))) t) (deftest ,(make-struct-test-name name 14) (let ((class (find-class (quote ,name)))) (notnot-mv (typep class 'structure-class))) t) (deftest ,(make-struct-test-name name 15) (notnot-mv (typep (,make-fn) 'structure-object)) t) (deftest ,(make-struct-test-name name 16) (loop for type in *disjoint-types-list* unless (and (equalt (multiple-value-list (subtypep* type (quote ,name))) '(nil t)) (equalt (multiple-value-list (subtypep* (quote ,name) type)) '(nil t))) collect type) nil) (deftest ,(make-struct-test-name name 17) (let ((class (find-class (quote ,name)))) (loop for type in *disjoint-types-list* unless (and (equalt (multiple-value-list (subtypep* type class)) '(nil t)) (equalt (multiple-value-list (subtypep* class type)) '(nil t))) collect type)) nil) (deftest ,(make-struct-test-name name "15A") (let ((class (find-class (quote ,name)))) (notnot-mv (subtypep class 'structure-object))) t t) (deftest ,(make-struct-test-name name "15B") (notnot-mv (subtypep (quote ,name) 'structure-object)) t t) )) ;;; Documentation tests ,(when doc-string `(deftest ,(make-struct-test-name name 18) (let ((doc (documentation ',name 'structure))) (or (null doc) (equalt doc ',doc-string))) t)) ,(when (and doc-string (not type-option)) `(deftest ,(make-struct-test-name name 19) (let ((doc (documentation ',name 'type))) (or (null doc) (equalt doc ',doc-string))) t)) ;; Test that COPY-STRUCTURE works, if this is a structure ;; type ,@(unless type-option `((deftest ,(make-struct-test-name name 20) ,(let* ((var 'XTEMP-20) (var2 'YTEMP-20)) `(let ((,var (,make-fn ,@(loop for (slot-name . initval) in initial-value-alist nconc (list (intern (string slot-name) "KEYWORD") `(quote ,initval)))))) (let ((,var2 (copy-structure ,var))) (and (not (eqlt ,var ,var2)) ,@(loop for (slot-name . nil) in initial-value-alist for fn in field-fns collect `(eqlt (,fn ,var) (,fn ,var2))) t)))) t))) nil ))) (defun defstruct-maketemp (stem suffix1 &optional suffix2) "Make a temporary variable for DEFSTRUCT-WITH-TESTS." (intern (if suffix2 (format nil "~A-~A-~A" stem suffix1 suffix2) (format nil "~A-~A" stem suffix1)))) gcl/ansi-tests/structures-01.lsp000066400000000000000000000044071242227143400171040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 2 21:45:32 1998 ;;;; Contains: Test code for structures, part 01 (in-package :cl-test) (declaim (optimize (safety 3))) ;;; Tests for structures ;;; ;;; The CL Spec leaves undefined just what will happen when a structure is ;;; redefined. These tests don't redefine structures, but reloading a file ;;; with structure definition will do so. I assume that this leaves the ;;; structure type unchanged. ;; Test simple defstruct (fields, no options) (defstruct s-1 foo bar) ;; Test that make-s-1 produces objects ;; of the correct type (deftest structure-1-1 (notnot-mv (typep (make-s-1) 's-1)) t) ;; Test that the -p predicate exists (deftest structure-1-2 (notnot-mv (s-1-p (make-s-1))) t) ;; Test that all the objects in the universe are ;; not of this type (deftest structure-1-3 (count-if #'s-1-p *universe*) 0) (deftest structure-1-4 (count-if #'(lambda (x) (typep x 's-1)) *universe*) 0) ;; Check that the fields can be read after being initialized (deftest structure-1-5 (s-1-foo (make-s-1 :foo 'a)) a) (deftest structure-1-6 (s-1-bar (make-s-1 :bar 'b)) b) (deftest structure-1-7 (let ((s (make-s-1 :foo 'c :bar 'd))) (list (s-1-foo s) (s-1-bar s))) (c d)) ;; Can setf the fields (deftest structure-1-8 (let ((s (make-s-1))) (setf (s-1-foo s) 'e) (setf (s-1-bar s) 'f) (list (s-1-foo s) (s-1-bar s))) (e f)) (deftest structure-1-9 (let ((s (make-s-1 :foo 'a :bar 'b))) (setf (s-1-foo s) 'e) (setf (s-1-bar s) 'f) (list (s-1-foo s) (s-1-bar s))) (e f)) ;; copier function defined (deftest structure-1-10 (let ((s (make-s-1 :foo 'a :bar 'b))) (let ((s2 (copy-s-1 s))) (setf (s-1-foo s) nil) (setf (s-1-bar s) nil) (list (s-1-foo s2) (s-1-bar s2)))) (a b)) ;; Make produces unique items (deftest structure-1-11 (eqt (make-s-1) (make-s-1)) nil) (deftest structure-1-12 (eqt (make-s-1 :foo 'a :bar 'b) (make-s-1 :foo 'a :bar 'b)) nil) ;; More type and class checks (deftest structure-1-13 (notnot-mv (typep (class-of (make-s-1)) 'structure-class)) t) (deftest structure-1-14 (notnot-mv (typep (make-s-1) 'structure-object)) t) (deftest structure-1-15 (subtypep* 's-1 'structure-object) t t) gcl/ansi-tests/structures-02.lsp000066400000000000000000000262551242227143400171120ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 3 22:46:54 1998 ;;;; Contains: Test code for structures, part 02 (in-package :cl-test) (declaim (optimize (safety 3))) ;; Test initializers for fields (defvar *s-2-f6-counter* 0) (defstruct s-2 (f1 0) (f2 'a) (f3 1.21) (f4 #\d) (f5 (list 'a 'b)) (f6 (incf *s-2-f6-counter*))) ;; Standard structure tests ;; Fields have appropriate values (deftest structure-2-1 (let ((*s-2-f6-counter* 0)) (let ((s (make-s-2))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) (= (s-2-f3 s) 1.21) (eqlt (s-2-f4 s) #\d) (equalt (s-2-f5 s) '(a b)) (eqlt (s-2-f6 s) *s-2-f6-counter*) (eqlt *s-2-f6-counter* 1)))) t) ;; Two successive invocations of make-s-2 return different objects (deftest structure-2-2 (let ((*s-2-f6-counter* 0)) (eqt (s-2-f5 (make-s-2)) (s-2-f5 (make-s-2)))) nil) ;; Creation with various fields does the right thing (deftest structure-2-3 (let* ((*s-2-f6-counter* 0) (s (make-s-2 :f1 17))) (and (eqlt (s-2-f1 s) 17) (eqt (s-2-f2 s) 'a) (= (s-2-f3 s) 1.21) (eqlt (s-2-f4 s) #\d) (equalt (s-2-f5 s) '(a b)) (eqlt (s-2-f6 s) *s-2-f6-counter*) (eqlt *s-2-f6-counter* 1))) t) (deftest structure-2-4 (let* ((*s-2-f6-counter* 0) (s (make-s-2 :f2 'z))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'z) (= (s-2-f3 s) 1.21) (eqlt (s-2-f4 s) #\d) (equalt (s-2-f5 s) '(a b)) (eqlt (s-2-f6 s) *s-2-f6-counter*) (eqlt *s-2-f6-counter* 1))) t) (deftest structure-2-5 (let* ((*s-2-f6-counter* 0) (s (make-s-2 :f3 1.0))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) (= (s-2-f3 s) 1.0) (eqlt (s-2-f4 s) #\d) (equalt (s-2-f5 s) '(a b)) (eqlt (s-2-f6 s) *s-2-f6-counter*) (eqlt *s-2-f6-counter* 1))) t) (deftest structure-2-6 (let* ((*s-2-f6-counter* 0) (s (make-s-2 :f4 #\z))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) (= (s-2-f3 s) 1.21) (eqlt (s-2-f4 s) #\z) (equalt (s-2-f5 s) '(a b)) (eqlt (s-2-f6 s) *s-2-f6-counter*) (eqlt *s-2-f6-counter* 1))) t) (deftest structure-2-7 (let* ((*s-2-f6-counter* 0) (s (make-s-2 :f5 '(c d e)))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) (= (s-2-f3 s) 1.21) (eqlt (s-2-f4 s) #\d) (equalt (s-2-f5 s) '(c d e)) (eqlt (s-2-f6 s) *s-2-f6-counter*) (eqlt *s-2-f6-counter* 1))) t) (deftest structure-2-8 (let* ((*s-2-f6-counter* 0) (s (make-s-2 :f6 10))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) (= (s-2-f3 s) 1.21) (eqlt (s-2-f4 s) #\d) (equalt (s-2-f5 s) '(a b)) (eqlt (s-2-f6 s) 10) (eqlt *s-2-f6-counter* 0))) t) ;;; Tests using the defstruct-with-tests infrastructure (defstruct-with-tests struct-test-03 a b c d) (defstruct-with-tests (struct-test-04) a b c) (defstruct-with-tests (struct-test-05 :constructor) a05 b05 c05) (defstruct-with-tests (struct-test-06 (:constructor)) a06 b06 c06) (defstruct-with-tests (struct-test-07 :conc-name) a07 b07) (defstruct-with-tests (struct-test-08 (:conc-name)) a08 b08) (defstruct-with-tests (struct-test-09 (:conc-name nil)) a09 b09) (defstruct-with-tests (struct-test-10 (:conc-name "")) a10 b10) (defstruct-with-tests (struct-test-11 (:conc-name "BLAH-")) a11 b11) (defstruct-with-tests (struct-test-12 (:conc-name BLAH-)) a12 b12) (defstruct-with-tests (struct-test-13 (:conc-name #\X)) foo-a13 foo-b13) (defstruct-with-tests (struct-test-14 (:predicate)) a14 b14) (defstruct-with-tests (struct-test-15 (:predicate nil)) a15 b15) (defstruct-with-tests (struct-test-16 :predicate) a16 b16) (defstruct-with-tests (struct-test-17 (:predicate struct-test-17-alternate-pred)) a17 b17) (defstruct-with-tests (struct-test-18 :copier) a18 b18) (defstruct-with-tests (struct-test-19 (:copier)) a19 b19) (defstruct-with-tests (struct-test-20 (:copier nil)) a20 b20) (defstruct-with-tests (struct-test-21 (:copier struct-test-21-alt-copier)) a21 b21) (defstruct-with-tests struct-test-22 (a22) (b22)) (defstruct-with-tests struct-test-23 (a23 1) (b23 2)) (defstruct-with-tests struct-test-24 (a24 1 :type fixnum) (b24 2 :type integer)) (defstruct-with-tests struct-test-25) (defstruct-with-tests struct-test-26 (a26 nil :read-only nil) (b26 'a :read-only nil)) (defstruct-with-tests struct-test-27 (a27 1 :read-only t) (b27 1.4 :read-only a)) (defstruct-with-tests struct-test-28 (a28 1 :type integer :read-only t) (b28 'xx :read-only a :type symbol)) (defstruct-with-tests struct-test-29 a29 (b29 'xx :read-only 1) c29) (defstruct-with-tests struct-test-30 #:a30 #:b30) (defstruct-with-tests #:struct-test-31 a31 b31) (defpackage struct-test-package (:use)) (defstruct-with-tests struct-test-32 struct-test-package::a32 struct-test-package::b32) ;;; If the :conc-name option is given no argument or ;;; a nil argument, the accessor names are the same as ;;; slot names. Note that this is different from prepending ;;; an empty string, since that may get you a name in ;;; a different package. (defstruct-with-tests (struct-test-33 (:conc-name)) struct-test-package::a33 struct-test-package::b33) (defstruct-with-tests (struct-test-34 :conc-name) struct-test-package::a34 struct-test-package::b34) (defstruct-with-tests (struct-test-35 (:conc-name nil)) struct-test-package::a35 struct-test-package::b35) (defstruct-with-tests (struct-test-36 (:conc-name "")) struct-test-package::st36-a36 struct-test-package::st26-b36) ;;; List and vector structures (defstruct-with-tests (struct-test-37 (:type list)) a37 b37 c37) (deftest structure-37-1 (make-struct-test-37 :a37 1 :b37 2 :c37 4) (1 2 4)) (defstruct-with-tests (struct-test-38 (:type list) :named) a38 b38 c38) (deftest structure-38-1 (make-struct-test-38 :a38 11 :b38 12 :c38 4) (struct-test-38 11 12 4)) (defstruct-with-tests (struct-test-39 (:predicate nil) (:type list) :named) a39 b39 c39) (deftest structure-39-1 (make-struct-test-39 :a39 11 :b39 12 :c39 4) (struct-test-39 11 12 4)) (defstruct-with-tests (struct-test-40 (:type vector)) a40 b40) (defstruct-with-tests (struct-test-41 (:type vector) :named) a41 b41) (defstruct-with-tests (struct-test-42 (:type (vector t))) a42 b42) (defstruct-with-tests (struct-test-43 (:type (vector t)) :named) a43 b43) (defstruct-with-tests (struct-test-44 (:type list)) (a44 0 :type integer) (b44 'a :type symbol)) ;;; Confirm that the defined structure types are all disjoint (deftest structs-are-disjoint (loop for s1 in *defstruct-with-tests-names* sum (loop for s2 in *defstruct-with-tests-names* unless (eq s1 s2) count (not (equalt (multiple-value-list (subtypep* s1 s2)) '(nil t))))) 0) (defstruct-with-tests (struct-test-45 (:type list) (:initial-offset 2)) a45 b45) (deftest structure-45-1 (cddr (make-struct-test-45 :a45 1 :b45 2)) (1 2)) (defstruct-with-tests (struct-test-46 (:type list) (:include struct-test-45)) c46 d46) (deftest structure-46-1 (cddr (make-struct-test-46 :a45 1 :b45 2 :c46 3 :d46 4)) (1 2 3 4)) (defstruct-with-tests (struct-test-47 (:type list) (:initial-offset 3) (:include struct-test-45)) c47 d47) (deftest structure-47-1 (let ((s (make-struct-test-47 :a45 1 :b45 2 :c47 3 :d47 4))) (values (third s) (fourth s) (eighth s) (ninth s))) 1 2 3 4) (defstruct-with-tests (struct-test-48 (:type list) (:initial-offset 0) (:include struct-test-45)) c48 d48) (deftest structure-48-1 (cddr (make-struct-test-48 :a45 1 :b45 2 :c48 3 :d48 4)) (1 2 3 4)) (defstruct-with-tests (struct-test-49 (:type (vector bit))) (a49 0 :type bit) (b49 0 :type bit)) (defstruct-with-tests (struct-test-50 (:type (vector character))) (a50 #\g :type character) (b50 #\k :type character)) (defstruct-with-tests (struct-test-51 (:type (vector (integer 0 255)))) (a51 17 :type (integer 0 255)) (b51 25 :type (integer 0 255))) (defstruct-with-tests (struct-test-52 (:type vector) (:initial-offset 0)) a52 b52) (defstruct-with-tests (struct-test-53 (:type vector) (:initial-offset 5)) "This is struct-test-53" a53 b53) (deftest structure-53-1 (let ((s (make-struct-test-53 :a53 10 :b53 'a))) (values (aref s 5) (aref s 6))) 10 a) (defstruct-with-tests (struct-test-54 (:type vector) (:initial-offset 2) (:include struct-test-53)) "This is struct-test-54" a54 b54) (deftest structure-54-1 (let ((s (make-struct-test-54 :a53 8 :b53 'g :a54 10 :b54 'a))) (values (aref s 5) (aref s 6) (aref s 9) (aref s 10))) 8 g 10 a) (defstruct-with-tests (struct-test-55 (:type list) (:initial-offset 2) :named) a55 b55 c55) (deftest structure-55-1 (let ((s (make-struct-test-55 :a55 'p :c55 'q))) (values (third s) (fourth s) (sixth s))) struct-test-55 p q) (defstruct-with-tests (struct-test-56 (:type list) (:initial-offset 3) (:include struct-test-55) :named) d56 e56) (deftest structure-56-1 (let ((s (make-struct-test-56 :a55 3 :b55 7 :d56 'x :e56 'y))) (mapcar #'(lambda (i) (nth i s)) '(2 3 4 9 10 11))) (struct-test-55 3 7 struct-test-56 x y)) (defstruct-with-tests (struct-test-57 (:include struct-test-22)) c57 d57) (defstruct-with-tests struct-test-58 "This is struct-test-58" a-58 b-58) (defstruct-with-tests (struct-test-59 (:include struct-test-58)) "This is struct-test-59" a-59 b-59) ;;; When a field name of a structure is also a special variable, ;;; the constructor must not bind that name. (defvar *st-60* 100) (defstruct-with-tests struct-test-60 (a60 *st-60* :type integer) (*st-60* 0 :type integer) (b60 *st-60* :type integer)) (deftest structure-60-1 (let ((*st-60* 10)) (let ((s (make-struct-test-60 :*st-60* 200))) (values (struct-test-60-a60 s) (struct-test-60-*st-60* s) (struct-test-60-b60 s)))) 10 200 10) ;;; When default initializers of the wrong type are given, they do not ;;; cause an error unless actually invoked (defstruct struct-test-61 (a nil :type integer) (b 0 :type symbol)) (deftest structure-61-1 (let ((s (make-struct-test-61 :a 10 :b 'c))) (values (struct-test-61-a s) (struct-test-61-b s))) 10 c) ;;; Initializer forms are evaluated only when needed, and are ;;; evaluated in the lexical environment in which they were defined (eval-when (load eval) (let ((x nil)) (flet ((%f () x) (%g (y) (setf x y))) (defstruct struct-test-62 (a (progn (setf x 'a) nil)) (f #'%f) (g #'%g))))) (deftest structure-62-1 (let* ((s (make-struct-test-62 :a 1)) (f (struct-test-62-f s))) (values (struct-test-62-a s) (funcall f))) 1 nil) (deftest structure-62-2 (let* ((s (make-struct-test-62)) (f (struct-test-62-f s)) (g (struct-test-62-g s))) (values (struct-test-62-a s) (funcall f) (funcall g nil) (funcall f))) nil a nil nil) ;;; Keywords are allowed in defstruct (defstruct-with-tests :struct-test-63 a63 b63 c63) (defstruct-with-tests struct-test-64 :a63 :b63 :c63) ;;; Error tests (deftest copy-structure.error.1 (classify-error (copy-structure)) program-error) (deftest copy-structure.error.2 (classify-error (copy-structure (make-s-2) nil)) program-error) gcl/ansi-tests/structures-03.lsp000066400000000000000000000234521242227143400171070ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Dec 20 05:58:06 2002 ;;;; Contains: BOA Constructor Tests (in-package :cl-test) (defun sbt-slots (sname s &rest slots) (loop for slotname in slots collect (let ((fun (intern (concatenate 'string (string sname) "-" (string slotname)) :cl-test))) (funcall (symbol-function fun) s)))) ;;; See the DEFSTRUCT page, and section 3.4.6 (Boa Lambda Lists) (defstruct* (sbt-01 (:constructor sbt-01-con (b a c))) a b c) (deftest structure-boa-test-01/1 (let ((s (sbt-01-con 1 2 3))) (values (sbt-01-a s) (sbt-01-b s) (sbt-01-c s))) 2 1 3) (defstruct* (sbt-02 (:constructor sbt-02-con (a b c)) (:constructor sbt-02-con-2 (a b)) (:constructor sbt-02-con-3 ())) (a 'x) (b 'y) (c 'z)) (deftest structure-boa-test-02/1 (let ((s (sbt-02-con 1 2 3))) (values (sbt-02-a s) (sbt-02-b s) (sbt-02-c s))) 1 2 3) (deftest structure-boa-test-02/2 (let ((s (sbt-02-con-2 'p 'q))) (values (sbt-02-a s) (sbt-02-b s) (sbt-02-c s))) p q z) (deftest structure-boa-test-02/3 (let ((s (sbt-02-con-3))) (values (sbt-02-a s) (sbt-02-b s) (sbt-02-c s))) x y z) ;;; &optional in BOA LL (defstruct* (sbt-03 (:constructor sbt-03-con (a b &optional c))) c b a) (deftest structure-boa-test-03/1 (let ((s (sbt-03-con 1 2))) (values (sbt-03-a s) (sbt-03-b s))) 1 2) (deftest structure-boa-test-03/2 (let ((s (sbt-03-con 1 2 3))) (values (sbt-03-a s) (sbt-03-b s) (sbt-03-c s))) 1 2 3) (defstruct* (sbt-04 (:constructor sbt-04-con (a b &optional c))) (c nil) b (a nil)) (deftest structure-boa-test-04/1 (let ((s (sbt-04-con 1 2))) (values (sbt-04-a s) (sbt-04-b s) (sbt-04-c s))) 1 2 nil) (deftest structure-boa-test-04/2 (let ((s (sbt-04-con 1 2 4))) (values (sbt-04-a s) (sbt-04-b s) (sbt-04-c s))) 1 2 4) (defstruct* (sbt-05 (:constructor sbt-05-con (&optional a b c))) (c 1) (b 2) (a 3)) (deftest structure-boa-test-05/1 (let ((s (sbt-05-con))) (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) 3 2 1) (deftest structure-boa-test-05/2 (let ((s (sbt-05-con 'x))) (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) x 2 1) (deftest structure-boa-test-05/3 (let ((s (sbt-05-con 'x 'y))) (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) x y 1) (deftest structure-boa-test-05/4 (let ((s (sbt-05-con 'x 'y 'z))) (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) x y z) (defstruct* (sbt-06 (:constructor sbt-06-con (&optional (a 'p) (b 'q) (c 'r)))) (c 1) (b 2) (a 3)) (deftest structure-boa-test-06/1 (let ((s (sbt-06-con))) (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) p q r) (deftest structure-boa-test-06/2 (let ((s (sbt-06-con 'x))) (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) x q r) (deftest structure-boa-test-06/3 (let ((s (sbt-06-con 'x 'y))) (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) x y r) (deftest structure-boa-test-06/4 (let ((s (sbt-06-con 'x 'y 'z))) (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) x y z) ;;; Test presence flag in optional parameters (defstruct* (sbt-07 (:constructor sbt-07-con (&optional (a 'p a-p) (b 'q b-p) (c 'r c-p) &aux (d (list (notnot a-p) (notnot b-p) (notnot c-p)))))) a b c d) (deftest structure-boa-test-07/1 (sbt-slots 'sbt-07 (sbt-07-con) :a :b :c :d) (p q r (nil nil nil))) (deftest structure-boa-test-07/2 (sbt-slots 'sbt-07 (sbt-07-con 'x) :a :b :c :d) (x q r (t nil nil))) (deftest structure-boa-test-07/3 (sbt-slots 'sbt-07 (sbt-07-con 'x 'y) :a :b :c :d) (x y r (t t nil))) (deftest structure-boa-test-07/4 (sbt-slots 'sbt-07 (sbt-07-con 'x 'y 'z) :a :b :c :d) (x y z (t t t))) ;;; Keyword arguments (defstruct* (sbt-08 (:constructor sbt-08-con (&key ((:foo a))))) a) (deftest structure-boa-test-08/1 (sbt-slots 'sbt-08 (sbt-08-con :foo 10) :a) (10)) (defstruct* (sbt-09 (:constructor sbt-09-con (&key (a 'p a-p) ((:x b) 'q) (c 'r) d ((:y e)) ((:z f) 's z-p) &aux (g (list (notnot a-p) (notnot z-p)))))) a b c d e f g) (deftest structure-boa-test-09/1 (sbt-slots 'sbt-09 (sbt-09-con) :a :b :c :f :g) (p q r s (nil nil))) (deftest structure-boa-test-09/2 (sbt-slots 'sbt-09 (sbt-09-con :d 1) :a :b :c :d :f :g) (p q r 1 s (nil nil))) (deftest structure-boa-test-09/3 (sbt-slots 'sbt-09 (sbt-09-con :a 1) :a :b :c :f :g) (1 q r s (t nil))) (deftest structure-boa-test-09/4 (sbt-slots 'sbt-09 (sbt-09-con :x 1) :a :b :c :f :g) (p 1 r s (nil nil))) (deftest structure-boa-test-09/5 (sbt-slots 'sbt-09 (sbt-09-con :c 1) :a :b :c :f :g) (p q 1 s (nil nil))) (deftest structure-boa-test-09/6 (sbt-slots 'sbt-09 (sbt-09-con :y 1) :a :b :c :e :f :g) (p q r 1 s (nil nil))) (deftest structure-boa-test-09/7 (sbt-slots 'sbt-09 (sbt-09-con :z 1) :a :b :c :f :g) (p q r 1 (nil t))) ;;; Aux variable overriding a default value (defstruct* (sbt-10 (:constructor sbt-10-con (&aux (a 10) (b (1+ a))))) (a 1) (b 2)) (deftest structure-boa-test-10/1 (sbt-slots 'sbt-10 (sbt-10-con) :a :b) (10 11)) ;;; Aux variables with no value (defstruct* (sbt-11 (:constructor sbt-11-con (&aux a b))) a (b 0 :type integer)) (deftest structure-boa-test-11/1 (let ((s (sbt-11-con))) (setf (sbt-11-a s) 'p) (setf (sbt-11-b s) 10) (sbt-slots 'sbt-11 s :a :b)) (p 10)) ;;; Arguments that correspond to no slots (defstruct* (sbt-12 (:constructor sbt-12-con (a &optional (b 1) &rest c &aux (d (list a b c))))) d) (deftest structure-boa-12/1 (sbt-12-d (sbt-12-con 'x)) (x 1 nil)) (deftest structure-boa-12/2 (sbt-12-d (sbt-12-con 'x 'y)) (x y nil)) (deftest structure-boa-12/3 (sbt-12-d (sbt-12-con 'x 'y 1 2 3)) (x y (1 2 3))) (defstruct* (sbt-13 (:constructor sbt-13-con (&key (a 1) (b 2) c &aux (d (list a b c))))) d) (deftest structure-boa-test-13/1 (sbt-13-d (sbt-13-con)) (1 2 nil)) (deftest structure-boa-test-13/2 (sbt-13-d (sbt-13-con :a 10)) (10 2 nil)) (deftest structure-boa-test-13/3 (sbt-13-d (sbt-13-con :b 10)) (1 10 nil)) (deftest structure-boa-test-13/4 (sbt-13-d (sbt-13-con :c 10)) (1 2 10)) (deftest structure-boa-test-13/5 (sbt-13-d (sbt-13-con :c 10 :a 3)) (3 2 10)) (deftest structure-boa-test-13/6 (sbt-13-d (sbt-13-con :c 10 :b 3)) (1 3 10)) (deftest structure-boa-test-13/7 (sbt-13-d (sbt-13-con :a 10 :b 3)) (10 3 nil)) (deftest structure-boa-test-13/8 (sbt-13-d (sbt-13-con :a 10 :c 'a :b 3)) (10 3 a)) ;;; Allow other keywords (defstruct* (sbt-14 (:constructor sbt-14-con (&key a b c &allow-other-keys))) (a 1) (b 2) (c 3)) (deftest structure-boa-test-14/1 (sbt-slots 'sbt-14 (sbt-14-con) :a :b :c) (1 2 3)) (deftest structure-boa-test-14/2 (sbt-slots 'sbt-14 (sbt-14-con :a 9) :a :b :c) (9 2 3)) (deftest structure-boa-test-14/3 (sbt-slots 'sbt-14 (sbt-14-con :b 9) :a :b :c) (1 9 3)) (deftest structure-boa-test-14/4 (sbt-slots 'sbt-14 (sbt-14-con :c 9) :a :b :c) (1 2 9)) (deftest structure-boa-test-14/5 (sbt-slots 'sbt-14 (sbt-14-con :d 9) :a :b :c) (1 2 3)) ;;; Keywords are in the correct package, and slot names are not ;;; keyword parameters if not specified. (defstruct* (sbt-15 (:constructor sbt-15-con (&key ((:x a) nil) ((y b) nil) (c nil)))) a b c) (deftest structure-boa-test-15/1 (sbt-slots 'sbt-15 (sbt-15-con :x 1 'y 2 :c 3) :a :b :c) (1 2 3)) (deftest structure-boa-test-15/2 (classify-error (sbt-15-con :a 1)) program-error) (deftest structure-boa-test-15/3 (classify-error (sbt-15-con :b 1)) program-error) (deftest structure-boa-test-15/4 (classify-error (sbt-15-con 'x 1)) program-error) (deftest structure-boa-test-15/5 (classify-error (sbt-15-con :y 1)) program-error) (deftest structure-boa-test-15/6 (classify-error (sbt-15-con 'c 1)) program-error) (deftest structure-boa-test-15/7 (classify-error (sbt-15-con 'a 1)) program-error) (deftest structure-boa-test-15/8 (classify-error (sbt-15-con 'b 1)) program-error) ;;; Default constructor w. BOA constructor, and error cases (defstruct* (sbt-16 (:constructor) (:constructor sbt-16-con (a b c))) a b c) (deftest structure-boa-test-16/1 (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :b 2 :c 3) :a :b :c) (1 2 3)) (deftest structure-boa-test-16/2 (sbt-slots 'sbt-16 (sbt-16-con 4 5 6) :a :b :c) (4 5 6)) (deftest structure-boa-test-16/3 (classify-error (make-sbt-16 :d 1)) program-error) (deftest structure-boa-test-16/4 (classify-error (make-sbt-16 :a)) program-error) (deftest structure-boa-test-16/5 (classify-error (make-sbt-16 'a)) program-error) (deftest structure-boa-test-16/6 (classify-error (make-sbt-16 1 1)) program-error) (deftest structure-boa-test-16/7 (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :b 2 :c 3 :d 5 :allow-other-keys t) :a :b :c) (1 2 3)) (deftest structure-boa-test-16/8 (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :a 1 :b 2 :c 3 :d 5) :a :b :c) (1 2 3)) ;;; :allow-other-keys turns off keyword error checking, including ;;; invalid (nonsymbol) keyword arguments ;;;(deftest structure-boa-test-16/9 ;;; (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t ;;; :a 3 :b 6 :c 9 1000 1000) ;;; :a :b :c) ;;; (3 6 9)) ;;; Repeated keyword arguments are allowed; the leftmost one is used (deftest structure-boa-test-16/10 (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :a 2 :b 3 :b 4 :c 5 :c 6) :a :b :c) (1 3 5)) (deftest structure-boa-test-16/11 (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :allow-other-keys nil :a 1 :b 2 :c 3 :d 5) :a :b :c) (1 2 3)) ;; Checking of # of keywords is suppressed when :allow-other-keys is true ;;;(deftest structure-boa-test-16/12 ;;; (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :a 3 :b 6 :c 9 :a) ;;; :a :b :c) ;;; (3 6 9)) gcl/ansi-tests/subseq-aux.lsp000066400000000000000000000154771242227143400165510ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Nov 26 20:01:27 2002 ;;;; Contains: Aux. functions for subseq tests (in-package :cl-test) (defun subseq-list.4-body () (block done (let ((x (loop for i from 0 to 19 collect i))) (loop for i from 0 to 20 do (loop for j from i to 20 do (let ((y (subseq x i j))) (loop for e in y and k from i to (1- j) do (unless (eqlt e k) (return-from done nil))))))) t)) (defun subseq-list.5-body () (block done (let ((x (loop for i from 0 to 29 collect i))) (loop for i from 0 to 30 do (unless (equalt (subseq x i) (loop for j from i to 29 collect j)) (return-from done nil)))) t)) (defun subseq-list.6-body () (let* ((x (make-list 100)) (z (loop for e on x collect e)) (y (subseq x 0))) (loop for e on x and f on y and g in z do (when (or (not (eqt g e)) (not (eqlt (car e) (car f))) (car e) (eqt e f)) (return nil)) finally (return t)))) (defun subseq-vector.1-body () (block nil (let* ((x (make-sequence 'vector 10 :initial-element 'a)) (y (subseq x 4 8))) (unless (every #'(lambda (e) (eqt e 'a)) x) (return 1)) (unless (every #'(lambda (e) (eqt e 'a)) y) (return 2)) (unless (eqlt (length x) 10) (return 3)) (unless (eqlt (length y) 4) (return 4)) (loop for i from 0 to 9 do (setf (aref x i) 'b)) (unless (every #'(lambda (e) (eqt e 'a)) y) (return 5)) (loop for i from 0 to 3 do (setf (aref y i) 'c)) (or (not (not (every #'(lambda (e) (eqt e 'b)) x))) 6)))) (defun subseq-vector.2-body () (block nil (let* ((x (make-sequence '(vector fixnum) 10 :initial-element 1)) (y (subseq x 4 8))) (unless (every #'(lambda (e) (eqlt e 1)) x) (return 1)) (unless (every #'(lambda (e) (eqlt e 1)) y) (return 2)) (unless (eqlt (length x) 10) (return 3)) (unless (eqlt (length y) 4) (return 4)) (loop for i from 0 to 9 do (setf (aref x i) 2)) (unless (every #'(lambda (e) (eqlt e 1)) y) (return 5)) (loop for i from 0 to 3 do (setf (aref y i) 3)) (or (not (not (every #'(lambda (e) (eqlt e 2)) x))) 6)))) (defun subseq-vector.3-body () (block nil (let* ((x (make-sequence '(vector single-float) 10 :initial-element 1.0)) (y (subseq x 4 8))) (unless (every #'(lambda (e) (= e 1.0)) x) (return 1)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 2)) (unless (eqlt (length x) 10) (return 3)) (unless (eqlt (length y) 4) (return 4)) (loop for i from 0 to 9 do (setf (aref x i) 2.0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (aref y i) 3.0)) (or (not (not (every #'(lambda (e) (= e 2.0)) x))) 6)))) (defun subseq-vector.4-body () (block nil (let* ((x (make-sequence '(vector double-float) 10 :initial-element 1.0d0)) (y (subseq x 4 8))) (unless (every #'(lambda (e) (= e 1.0)) x) (return 1)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 2)) (unless (eqlt (length x) 10) (return 3)) (unless (eqlt (length y) 4) (return 4)) (loop for i from 0 to 9 do (setf (aref x i) 2.0d0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (aref y i) 3.0d0)) (or (not (not (every #'(lambda (e) (= e 2.0)) x))) 6)))) (defun subseq-vector.5-body () (block nil (let* ((x (make-sequence '(vector short-float) 10 :initial-element 1.0s0)) (y (subseq x 4 8))) (unless (every #'(lambda (e) (= e 1.0)) x) (return 1)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 2)) (unless (eqlt (length x) 10) (return 3)) (unless (eqlt (length y) 4) (return 4)) (loop for i from 0 to 9 do (setf (aref x i) 2.0s0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (aref y i) 3.0s0)) (or (not (not (every #'(lambda (e) (= e 2.0)) x))) 6)))) (defun subseq-vector.6-body () (block nil (let* ((x (make-sequence '(vector long-float) 10 :initial-element 1.0l0)) (y (subseq x 4 8))) (unless (every #'(lambda (e) (= e 1.0)) x) (return 1)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 2)) (unless (eqlt (length x) 10) (return 3)) (unless (eqlt (length y) 4) (return 4)) (loop for i from 0 to 9 do (setf (aref x i) 2.0l0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (aref y i) 3.0l0)) (or (not (not (every #'(lambda (e) (= e 2.0)) x))) 6)))) (defun subseq-string.1-body () (let* ((s1 "abcdefgh") (len (length s1))) (loop for start from 0 below len always (string= (subseq s1 start) (coerce (loop for i from start to (1- len) collect (aref s1 i)) 'string))))) (defun subseq-string.2-body () (let* ((s1 "abcdefgh") (len (length s1))) (loop for start from 0 below len always (loop for end from (1+ start) to len always (string= (subseq s1 start end) (coerce (loop for i from start below end collect (aref s1 i)) 'string)))))) (defun subseq-string.3-body () (let* ((s1 (make-array '(10) :initial-contents "abcdefghij" :fill-pointer 8 :element-type 'character)) (len (length s1))) (and (eqlt len 8) (loop for start from 0 below len always (string= (subseq s1 start) (coerce (loop for i from start to (1- len) collect (aref s1 i)) 'string))) (loop for start from 0 below len always (loop for end from (1+ start) to len always (string= (subseq s1 start end) (coerce (loop for i from start below end collect (aref s1 i)) 'string))))))) (defun subseq-bit-vector.1-body () (let* ((s1 #*11001000) (len (length s1))) (loop for start from 0 below len always (equalp (subseq s1 start) (coerce (loop for i from start to (1- len) collect (aref s1 i)) 'bit-vector))))) (defun subseq-bit-vector.2-body () (let* ((s1 #*01101011) (len (length s1))) (loop for start from 0 below len always (loop for end from (1+ start) to len always (equalp (subseq s1 start end) (coerce (loop for i from start below end collect (aref s1 i)) 'bit-vector)))))) (defun subseq-bit-vector.3-body () (let* ((s1 (make-array '(10) :initial-contents #*1101100110 :fill-pointer 8 :element-type 'bit)) (len (length s1))) (and (eqlt len 8) (loop for start from 0 below len always (equalp (subseq s1 start) (coerce (loop for i from start to (1- len) collect (aref s1 i)) 'bit-vector))) (loop for start from 0 below len always (loop for end from (1+ start) to len always (equalp (subseq s1 start end) (coerce (loop for i from start below end collect (aref s1 i)) 'bit-vector))))))) gcl/ansi-tests/subseq.lsp000066400000000000000000000110371242227143400157420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 19:41:14 2002 ;;;; Contains: Tests on SUBSEQ (in-package :cl-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; subseq, on lists (deftest subseq-list.1 (subseq '(a b c d e) 0 0) nil) (deftest subseq-list.2 (subseq '(a b c) 0) (a b c)) (deftest subseq-list.3 (subseq '(a b c) 1) (b c)) (deftest subseq-list.4 (subseq-list.4-body) t) (deftest subseq-list.5 (subseq-list.5-body) t) (deftest subseq-list.6 ;; check that no structure is shared (subseq-list.6-body) t) (deftest subseq-list.7 (let ((x (loop for i from 0 to 9 collect i))) (setf (subseq x 0 3) (list 'a 'b 'c)) x) (a b c 3 4 5 6 7 8 9)) (deftest subseq-list.8 (let* ((x '(a b c d e)) (y (copy-seq x))) (setf (subseq y 0) '(f g h)) (list x y)) ((a b c d e) (f g h d e))) (deftest subseq-list.9 (let* ((x '(a b c d e)) (y (copy-seq x))) (setf (subseq y 1 3) '(1 2 3 4 5)) (list x y)) ((a b c d e) (a 1 2 d e))) (deftest subseq-list.10 (let* ((x '(a b c d e)) (y (copy-seq x))) (setf (subseq y 5) '(1 2 3 4 5)) (list x y)) ((a b c d e) (a b c d e))) (deftest subseq-list.11 (let* ((x '(a b c d e)) (y (copy-seq x))) (setf (subseq y 2 5) '(1)) (list x y)) ((a b c d e) (a b 1 d e))) (deftest subseq-list.12 (let* ((x '(a b c d e)) (y (copy-seq x))) (setf (subseq y 0 0) '(1 2)) (list x y)) ((a b c d e) (a b c d e))) ;; subseq on vectors (deftest subseq-vector.1 (subseq-vector.1-body) t) (deftest subseq-vector.2 (subseq-vector.2-body) t) (deftest subseq-vector.3 (subseq-vector.3-body) t) (deftest subseq-vector.4 (subseq-vector.4-body) t) (deftest subseq-vector.5 (subseq-vector.5-body) t) (deftest subseq-vector.6 (subseq-vector.6-body) t) (deftest subseq-vector.7 (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j))) (y (subseq x 2 8))) (equal-array y (make-array '(6) :initial-contents '(c d e f g h)))) t) (deftest subseq-vector.8 (let* ((x (make-array '(200) :initial-element 107 :element-type 'fixnum)) (y (subseq x 17 95))) (and (eqlt (length y) (- 95 17)) (equal-array y (make-array (list (- 95 17)) :initial-element 107 :element-type 'fixnum)))) t) (deftest subseq-vector.9 (let* ((x (make-array '(1000) :initial-element 17.6e-1 :element-type 'single-float)) (lo 164) (hi 873) (y (subseq x lo hi))) (and (eqlt (length y) (- hi lo)) (equal-array y (make-array (list (- hi lo)) :initial-element 17.6e-1 :element-type 'single-float)))) t) (deftest subseq-vector.10 (let* ((x (make-array '(2000) :initial-element 3.1415927d4 :element-type 'double-float)) (lo 731) (hi 1942) (y (subseq x lo hi))) (and (eqlt (length y) (- hi lo)) (equal-array y (make-array (list (- hi lo)) :initial-element 3.1415927d4 :element-type 'double-float)))) t) ;;; subseq on strings (deftest subseq-string.1 (subseq-string.1-body) t) (deftest subseq-string.2 (subseq-string.2-body) t) (deftest subseq-string.3 (subseq-string.3-body) t) ;;; Tests on bit vectors (deftest subseq-bit-vector.1 (subseq-bit-vector.1-body) t) (deftest subseq-bit-vector.2 (subseq-bit-vector.2-body) t) (deftest subseq-bit-vector.3 (subseq-bit-vector.3-body) t) ;;; Order of evaluation (deftest subseq.order.1 (let ((i 0) a b c) (values (subseq (progn (setf a (incf i)) "abcdefgh") (progn (setf b (incf i)) 1) (progn (setf c (incf i)) 4)) i a b c)) "bcd" 3 1 2 3) (deftest subseq.order.2 (let ((i 0) a b) (values (subseq (progn (setf a (incf i)) "abcdefgh") (progn (setf b (incf i)) 1)) i a b)) "bcdefgh" 2 1 2) (deftest subseq.order.3 (let ((i 0) a b c d (s (copy-seq "abcdefgh"))) (values (setf (subseq (progn (setf a (incf i)) s) (progn (setf b (incf i)) 1) (progn (setf c (incf i)) 4)) (progn (setf d (incf i)) "xyz")) s i a b c d)) "xyz" "axyzefgh" 4 1 2 3 4) (deftest subseq.order.4 (let ((i 0) a b c (s (copy-seq "abcd"))) (values (setf (subseq (progn (setf a (incf i)) s) (progn (setf b (incf i)) 1)) (progn (setf c (incf i)) "xyz")) s i a b c)) "xyz" "axyz" 3 1 2 3) ;;; Error cases (deftest subseq.error.1 (classify-error (subseq)) program-error) (deftest subseq.error.2 (classify-error (subseq nil)) program-error) (deftest subseq.error.3 (classify-error (subseq nil 0 0 0)) program-error) gcl/ansi-tests/substitute-if-not.lsp000066400000000000000000000621131242227143400200460ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 31 18:17:09 2002 ;;;; Contains: Tests for SUBSTITUTE-IF-NOT (in-package :cl-test) (deftest substitute-if-not-list.1 (let ((x '())) (values (substitute-if-not 'b #'null x) x)) nil nil) (deftest substitute-if-not-list.2 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x) x)) (b b b c) (a b a c)) (deftest substitute-if-not-list.3 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count nil) x)) (b b b c) (a b a c)) (deftest substitute-if-not-list.4 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2) x)) (b b b c) (a b a c)) (deftest substitute-if-not-list.5 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1) x)) (b b a c) (a b a c)) (deftest substitute-if-not-list.6 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0) x)) (a b a c) (a b a c)) (deftest substitute-if-not-list.7 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1) x)) (a b a c) (a b a c)) (deftest substitute-if-not-list.8 (let ((x '())) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) nil nil) (deftest substitute-if-not-list.9 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) (b b b c) (a b a c)) (deftest substitute-if-not-list.10 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil) x)) (b b b c) (a b a c)) (deftest substitute-if-not-list.11 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t) x)) (b b b c) (a b a c)) (deftest substitute-if-not-list.12 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t) x)) (a b b c) (a b a c)) (deftest substitute-if-not-list.13 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t) x)) (a b a c) (a b a c)) (deftest substitute-if-not-list.14 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t) x)) (a b a c) (a b a c)) (deftest substitute-if-not-list.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-not-list.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-not-list.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-if-not-list.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) (and (equal orig x) (equal y (nconc (make-list (- j c) :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))))) t) ;;; Tests on vectors (deftest substitute-if-not-vector.1 (let ((x #())) (values (substitute-if-not 'b (is-not-eq-p 'a) x) x)) #() #()) (deftest substitute-if-not-vector.2 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x) x)) #(b b b c) #(a b a c)) (deftest substitute-if-not-vector.3 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count nil) x)) #(b b b c) #(a b a c)) (deftest substitute-if-not-vector.4 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2) x)) #(b b b c) #(a b a c)) (deftest substitute-if-not-vector.5 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1) x)) #(b b a c) #(a b a c)) (deftest substitute-if-not-vector.6 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0) x)) #(a b a c) #(a b a c)) (deftest substitute-if-not-vector.7 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1) x)) #(a b a c) #(a b a c)) (deftest substitute-if-not-vector.8 (let ((x #())) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) #() #()) (deftest substitute-if-not-vector.9 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) #(b b b c) #(a b a c)) (deftest substitute-if-not-vector.10 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil) x)) #(b b b c) #(a b a c)) (deftest substitute-if-not-vector.11 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t) x)) #(b b b c) #(a b a c)) (deftest substitute-if-not-vector.12 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t) x)) #(a b b c) #(a b a c)) (deftest substitute-if-not-vector.13 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t) x)) #(a b a c) #(a b a c)) (deftest substitute-if-not-vector.14 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t) x)) #(a b a c) #(a b a c)) (deftest substitute-if-not-vector.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-not-vector.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-not-vector.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-if-not-vector.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array (- j c) :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))))) t) (deftest substitute-if-not-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if-not 'z (is-not-eql-p 'a) x))) result) #(z b z c b)) (deftest substitute-if-not-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if-not 'z (is-not-eql-p 'a) x :from-end t))) result) #(z b z c b)) (deftest substitute-if-not-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if-not 'z (is-not-eql-p 'a) x :count 1))) result) #(z b a c b)) (deftest substitute-if-not-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if-not 'z (is-not-eql-p 'a) x :from-end t :count 1))) result) #(a b z c b)) ;;; Tests on strings (deftest substitute-if-not-string.1 (let ((x "")) (values (substitute-if-not #\b (is-not-eq-p #\a) x) x)) "" "") (deftest substitute-if-not-string.2 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x) x)) "bbbc" "abac") (deftest substitute-if-not-string.3 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count nil) x)) "bbbc" "abac") (deftest substitute-if-not-string.4 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 2) x)) "bbbc" "abac") (deftest substitute-if-not-string.5 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 1) x)) "bbac" "abac") (deftest substitute-if-not-string.6 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 0) x)) "abac" "abac") (deftest substitute-if-not-string.7 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count -1) x)) "abac" "abac") (deftest substitute-if-not-string.8 (let ((x "")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :from-end t) x)) "" "") (deftest substitute-if-not-string.9 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :from-end t) x)) "bbbc" "abac") (deftest substitute-if-not-string.10 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :from-end t :count nil) x)) "bbbc" "abac") (deftest substitute-if-not-string.11 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 2 :from-end t) x)) "bbbc" "abac") (deftest substitute-if-not-string.12 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 1 :from-end t) x)) "abbc" "abac") (deftest substitute-if-not-string.13 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 0 :from-end t) x)) "abac" "abac") (deftest substitute-if-not-string.14 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count -1 :from-end t) x)) "abac" "abac") (deftest substitute-if-not-string.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-if-not-string.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-if-not-string.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 (+ i c)) :initial-element #\a)))))))) t) (deftest substitute-if-not-string.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array (- j c) :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))))) t) (deftest substitute-if-not-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if-not #\z (is-not-eql-p #\a) x))) result) "zbzcb") (deftest substitute-if-not-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if-not #\z (is-not-eql-p #\a) x :from-end t))) result) "zbzcb") (deftest substitute-if-not-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if-not #\z (is-not-eql-p #\a) x :count 1))) result) "zbacb") (deftest substitute-if-not-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if-not #\z (is-not-eql-p #\a) x :from-end t :count 1))) result) "abzcb") ;;; Tests on bitstrings (deftest substitute-if-not-bitstring.1 (let* ((orig #*) (x (copy-seq orig)) (result (substitute-if-not 0 (is-not-eq-p 1) x))) (and (equalp orig x) result)) #*) (deftest substitute-if-not-bitstring.2 (let* ((orig #*) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x))) (and (equalp orig x) result)) #*) (deftest substitute-if-not-bitstring.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 0 (is-not-eq-p 1) x))) (and (equalp orig x) result)) #*000000) (deftest substitute-if-not-bitstring.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x))) (and (equalp orig x) result)) #*111111) (deftest substitute-if-not-bitstring.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :start 1))) (and (equalp orig x) result)) #*011111) (deftest substitute-if-not-bitstring.6 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 0 (is-not-eq-p 1) x :start 2 :end nil))) (and (equalp orig x) result)) #*010000) (deftest substitute-if-not-bitstring.7 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :end 4))) (and (equalp orig x) result)) #*111101) (deftest substitute-if-not-bitstring.8 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 0 (is-not-eq-p 1) x :end nil))) (and (equalp orig x) result)) #*000000) (deftest substitute-if-not-bitstring.9 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 0 (is-not-eq-p 1) x :end 3))) (and (equalp orig x) result)) #*000101) (deftest substitute-if-not-bitstring.10 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 0 (is-not-eq-p 1) x :start 2 :end 4))) (and (equalp orig x) result)) #*010001) (deftest substitute-if-not-bitstring.11 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :start 2 :end 4))) (and (equalp orig x) result)) #*011101) (deftest substitute-if-not-bitstring.12 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count 1))) (and (equalp orig x) result)) #*110101) (deftest substitute-if-not-bitstring.13 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count 0))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-not-bitstring.14 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count -1))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-not-bitstring.15 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count 1 :from-end t))) (and (equalp orig x) result)) #*010111) (deftest substitute-if-not-bitstring.16 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count 0 :from-end t))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-not-bitstring.17 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count -1 :from-end t))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-not-bitstring.18 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count nil))) (and (equalp orig x) result)) #*111111) (deftest substitute-if-not-bitstring.19 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count nil :from-end t))) (and (equalp orig x) result)) #*111111) (deftest substitute-if-not-bitstring.20 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*0000000000) (x (copy-seq orig)) (y (substitute-if-not 1 (complement #'zerop) x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-bit-vector (make-list i :initial-element 0) (make-list c :initial-element 1) (make-list (- 10 (+ i c)) :initial-element 0)))))))) t) (deftest substitute-if-not-bitstring.21 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*1111111111) (x (copy-seq orig)) (y (substitute-if-not 0 (is-not-eq-p 1) x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-bit-vector (make-list (- j c) :initial-element 1) (make-list c :initial-element 0) (make-list (- 10 j) :initial-element 1)))))))) t) ;;; More tests (deftest substitute-if-not-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) (and (equal orig x) result)) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-if-not-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car :start 1 :end 5))) (and (equal orig x) result)) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-if-not-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) (and (equalp orig x) result)) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-if-not-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car :start 1 :end 5))) (and (equalp orig x) result)) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-if-not-string.24 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit))) (and (equalp orig x) result)) "a1a2342a15") (deftest substitute-if-not-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) (and (equalp orig x) result)) "01a2342015") (deftest substitute-if-not-bitstring.26 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if-not 1 (is-not-eq-p 1) x :key #'1+))) (and (equalp orig x) result)) #*11111111111111111) (deftest substitute-if-not-bitstring.27 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if-not 1 (is-not-eq-p 1) x :key #'1+ :start 1 :end 10))) (and (equalp orig x) result)) #*01111111111010110) (deftest substitute-if-not-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if-not 1 #'onep x))) result) #*11111) (deftest substitute-if-not-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if-not 1 #'onep x :from-end t))) result) #*11111) (deftest substitute-if-not-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if-not 1 #'onep x :count 1))) result) #*11011) (deftest substitute-if-not-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if-not 1 #'onep x :from-end t :count 1))) result) #*01111) (deftest substitute-if-not.order.1 (let ((i 0) a b c d e f g h) (values (substitute-if-not (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'identity) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :count (progn (setf d (incf i)) 2) :start (progn (setf e (incf i)) 0) :end (progn (setf f (incf i)) 7) :key (progn (setf g (incf i)) #'identity) :from-end (setf h (incf i)) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 4 5 6 7 8) (deftest substitute-if-not.order.2 (let ((i 0) a b c d e f g h) (values (substitute-if-not (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'identity) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :from-end (setf h (incf i)) :key (progn (setf g (incf i)) #'identity) :end (progn (setf f (incf i)) 7) :start (progn (setf e (incf i)) 0) :count (progn (setf d (incf i)) 2) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 8 7 6 5 4) ;;; Keyword tests (deftest substitute-if-not.allow-other-keys.1 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.2 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.3 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :allow-other-keys nil :bad t) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.4 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t :allow-other-keys nil) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.5 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :key #'1-) (1 a a a 1 a a)) (deftest substitute-if-not.keywords.6 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) (1 a a a 1 a a)) (deftest substitute-if-not.allow-other-keys.7 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t :allow-other-keys nil) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.8 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) (a a 0 a a 0 a)) ;;; Error cases (deftest substitute-if-not.error.1 (classify-error (substitute-if-not)) program-error) (deftest substitute-if-not.error.2 (classify-error (substitute-if-not 'a)) program-error) (deftest substitute-if-not.error.3 (classify-error (substitute-if-not 'a #'null)) program-error) (deftest substitute-if-not.error.4 (classify-error (substitute-if-not 'a #'null nil 'bad t)) program-error) (deftest substitute-if-not.error.5 (classify-error (substitute-if-not 'a #'null nil 'bad t :allow-other-keys nil)) program-error) (deftest substitute-if-not.error.6 (classify-error (substitute-if-not 'a #'null nil :key)) program-error) (deftest substitute-if-not.error.7 (classify-error (substitute-if-not 'a #'null nil 1 2)) program-error) (deftest substitute-if-not.error.8 (classify-error (substitute-if-not 'a #'cons (list 'a 'b 'c))) program-error) (deftest substitute-if-not.error.9 (classify-error (substitute-if-not 'a #'car (list 'a 'b 'c))) type-error) (deftest substitute-if-not.error.10 (classify-error (substitute-if-not 'a #'identity (list 'a 'b 'c) :key #'car)) type-error) (deftest substitute-if-not.error.11 (classify-error (substitute-if-not 'a #'identity (list 'a 'b 'c) :key #'cons)) program-error) gcl/ansi-tests/substitute-if.lsp000066400000000000000000000576431242227143400172640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 31 17:42:04 2002 ;;;; Contains: Tests for SUBSTITUTE-IF (in-package :cl-test) (deftest substitute-if-list.1 (let ((x '())) (values (substitute-if 'b #'identity x) x)) nil nil) (deftest substitute-if-list.2 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x) x)) (b b b c) (a b a c)) (deftest substitute-if-list.3 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count nil) x)) (b b b c) (a b a c)) (deftest substitute-if-list.4 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2) x)) (b b b c) (a b a c)) (deftest substitute-if-list.5 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1) x)) (b b a c) (a b a c)) (deftest substitute-if-list.6 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0) x)) (a b a c) (a b a c)) (deftest substitute-if-list.7 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1) x)) (a b a c) (a b a c)) (deftest substitute-if-list.8 (let ((x '())) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) nil nil) (deftest substitute-if-list.9 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) (b b b c) (a b a c)) (deftest substitute-if-list.10 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t :count nil) x)) (b b b c) (a b a c)) (deftest substitute-if-list.11 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2 :from-end t) x)) (b b b c) (a b a c)) (deftest substitute-if-list.12 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1 :from-end t) x)) (a b b c) (a b a c)) (deftest substitute-if-list.13 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0 :from-end t) x)) (a b a c) (a b a c)) (deftest substitute-if-list.14 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1 :from-end t) x)) (a b a c) (a b a c)) (deftest substitute-if-list.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-list.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-list.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-if-list.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) (and (equal orig x) (equal y (nconc (make-list (- j c) :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))))) t) ;;; Tests on vectors (deftest substitute-if-vector.1 (let ((x #())) (values (substitute-if 'b (is-eq-p 'a) x) x)) #() #()) (deftest substitute-if-vector.2 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x) x)) #(b b b c) #(a b a c)) (deftest substitute-if-vector.3 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count nil) x)) #(b b b c) #(a b a c)) (deftest substitute-if-vector.4 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2) x)) #(b b b c) #(a b a c)) (deftest substitute-if-vector.5 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1) x)) #(b b a c) #(a b a c)) (deftest substitute-if-vector.6 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0) x)) #(a b a c) #(a b a c)) (deftest substitute-if-vector.7 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1) x)) #(a b a c) #(a b a c)) (deftest substitute-if-vector.8 (let ((x #())) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) #() #()) (deftest substitute-if-vector.9 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) #(b b b c) #(a b a c)) (deftest substitute-if-vector.10 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t :count nil) x)) #(b b b c) #(a b a c)) (deftest substitute-if-vector.11 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2 :from-end t) x)) #(b b b c) #(a b a c)) (deftest substitute-if-vector.12 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1 :from-end t) x)) #(a b b c) #(a b a c)) (deftest substitute-if-vector.13 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0 :from-end t) x)) #(a b a c) #(a b a c)) (deftest substitute-if-vector.14 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1 :from-end t) x)) #(a b a c) #(a b a c)) (deftest substitute-if-vector.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-vector.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-vector.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-if-vector.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array (- j c) :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))))) t) (deftest substitute-if-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if 'z (is-eql-p 'a) x))) result) #(z b z c b)) (deftest substitute-if-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if 'z (is-eql-p 'a) x :from-end t))) result) #(z b z c b)) (deftest substitute-if-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if 'z (is-eql-p 'a) x :count 1))) result) #(z b a c b)) (deftest substitute-if-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if 'z (is-eql-p 'a) x :from-end t :count 1))) result) #(a b z c b)) ;;; Tests on strings (deftest substitute-if-string.1 (let ((x "")) (values (substitute-if #\b (is-eq-p #\a) x) x)) "" "") (deftest substitute-if-string.2 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x) x)) "bbbc" "abac") (deftest substitute-if-string.3 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count nil) x)) "bbbc" "abac") (deftest substitute-if-string.4 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 2) x)) "bbbc" "abac") (deftest substitute-if-string.5 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 1) x)) "bbac" "abac") (deftest substitute-if-string.6 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 0) x)) "abac" "abac") (deftest substitute-if-string.7 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count -1) x)) "abac" "abac") (deftest substitute-if-string.8 (let ((x "")) (values (substitute-if #\b (is-eq-p #\a) x :from-end t) x)) "" "") (deftest substitute-if-string.9 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :from-end t) x)) "bbbc" "abac") (deftest substitute-if-string.10 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :from-end t :count nil) x)) "bbbc" "abac") (deftest substitute-if-string.11 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 2 :from-end t) x)) "bbbc" "abac") (deftest substitute-if-string.12 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 1 :from-end t) x)) "abbc" "abac") (deftest substitute-if-string.13 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 0 :from-end t) x)) "abac" "abac") (deftest substitute-if-string.14 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count -1 :from-end t) x)) "abac" "abac") (deftest substitute-if-string.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if #\x (is-eq-p #\a) x :start i :end j))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-if-string.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if #\x (is-eq-p #\a) x :start i :end j :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-if-string.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if #\x (is-eq-p #\a) x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 (+ i c)) :initial-element #\a)))))))) t) (deftest substitute-if-string.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if #\x (is-eq-p #\a) x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array (- j c) :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))))) t) (deftest substitute-if-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if #\z (is-eql-p #\a) x))) result) "zbzcb") (deftest substitute-if-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if #\z (is-eql-p #\a) x :from-end t))) result) "zbzcb") (deftest substitute-if-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if #\z (is-eql-p #\a) x :count 1))) result) "zbacb") (deftest substitute-if-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if #\z (is-eql-p #\a) x :from-end t :count 1))) result) "abzcb") ;;; Tests on bit-vectors (deftest substitute-if-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (substitute-if 0 (is-eq-p 1) x))) (and (equalp orig x) result)) #*) (deftest substitute-if-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (substitute-if 1 'zerop x))) (and (equalp orig x) result)) #*) (deftest substitute-if-bit-vector.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 0 (is-eq-p 1) x))) (and (equalp orig x) result)) #*000000) (deftest substitute-if-bit-vector.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x))) (and (equalp orig x) result)) #*111111) (deftest substitute-if-bit-vector.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :start 1))) (and (equalp orig x) result)) #*011111) (deftest substitute-if-bit-vector.6 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 0 (is-eq-p 1) x :start 2 :end nil))) (and (equalp orig x) result)) #*010000) (deftest substitute-if-bit-vector.7 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :end 4))) (and (equalp orig x) result)) #*111101) (deftest substitute-if-bit-vector.8 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 0 (is-eq-p 1) x :end nil))) (and (equalp orig x) result)) #*000000) (deftest substitute-if-bit-vector.9 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 0 (is-eq-p 1) x :end 3))) (and (equalp orig x) result)) #*000101) (deftest substitute-if-bit-vector.10 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 0 (is-eq-p 1) x :start 2 :end 4))) (and (equalp orig x) result)) #*010001) (deftest substitute-if-bit-vector.11 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :start 2 :end 4))) (and (equalp orig x) result)) #*011101) (deftest substitute-if-bit-vector.12 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count 1))) (and (equalp orig x) result)) #*110101) (deftest substitute-if-bit-vector.13 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count 0))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-bit-vector.14 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count -1))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-bit-vector.15 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count 1 :from-end t))) (and (equalp orig x) result)) #*010111) (deftest substitute-if-bit-vector.16 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count 0 :from-end t))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-bit-vector.17 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count -1 :from-end t))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-bit-vector.18 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count nil))) (and (equalp orig x) result)) #*111111) (deftest substitute-if-bit-vector.19 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count nil :from-end t))) (and (equalp orig x) result)) #*111111) (deftest substitute-if-bit-vector.20 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*0000000000) (x (copy-seq orig)) (y (substitute-if 1 #'zerop x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-bit-vector (make-list i :initial-element 0) (make-list c :initial-element 1) (make-list (- 10 (+ i c)) :initial-element 0)))))))) t) (deftest substitute-if-bit-vector.21 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*1111111111) (x (copy-seq orig)) (y (substitute-if 0 (is-eq-p 1) x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-bit-vector (make-list (- j c) :initial-element 1) (make-list c :initial-element 0) (make-list (- 10 j) :initial-element 1)))))))) t) ;;; More tests (deftest substitute-if-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car))) (and (equal orig x) result)) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-if-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car :start 1 :end 5))) (and (equal orig x) result)) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-if-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car))) (and (equalp orig x) result)) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-if-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car :start 1 :end 5))) (and (equalp orig x) result)) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-if-string.24 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute-if #\a (is-eq-p #\1) x :key #'nextdigit))) (and (equalp orig x) result)) "a1a2342a15") (deftest substitute-if-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute-if #\a (is-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) (and (equalp orig x) result)) "01a2342015") (deftest substitute-if-bit-vector.26 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if 1 (is-eq-p 1) x :key #'1+))) (and (equalp orig x) result)) #*11111111111111111) (deftest substitute-if-bit-vector.27 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if 1 (is-eq-p 1) x :key #'1+ :start 1 :end 10))) (and (equalp orig x) result)) #*01111111111010110) (deftest substitute-if-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if 1 #'zerop x))) result) #*11111) (deftest substitute-if-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if 1 #'zerop x :from-end t))) result) #*11111) (deftest substitute-if-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if 1 #'zerop x :count 1))) result) #*11011) (deftest substitute-if-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if 1 #'zerop x :from-end t :count 1))) result) #*01111) (deftest substitute-if.order.1 (let ((i 0) a b c d e f g h) (values (substitute-if (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'null) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :count (progn (setf d (incf i)) 2) :start (progn (setf e (incf i)) 0) :end (progn (setf f (incf i)) 7) :key (progn (setf g (incf i)) #'identity) :from-end (setf h (incf i)) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 4 5 6 7 8) (deftest substitute-if.order.2 (let ((i 0) a b c d e f g h) (values (substitute-if (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'null) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :from-end (setf h (incf i)) :key (progn (setf g (incf i)) #'identity) :end (progn (setf f (incf i)) 7) :start (progn (setf e (incf i)) 0) :count (progn (setf d (incf i)) 2) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 8 7 6 5 4) ;;; Keyword tests (deftest substitute-if.allow-other-keys.1 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) (1 2 a 3 1 a 3)) (deftest substitute-if.allow-other-keys.2 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) (1 2 a 3 1 a 3)) (deftest substitute-if.allow-other-keys.3 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :allow-other-keys nil :bad t) (1 2 a 3 1 a 3)) (deftest substitute-if.allow-other-keys.4 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest substitute-if.allow-other-keys.5 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :key #'1-) (a 2 0 3 a 0 3)) (deftest substitute-if.keywords.6 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) (a 2 0 3 a 0 3)) (deftest substitute-if.allow-other-keys.7 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest substitute-if.allow-other-keys.8 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) (1 2 a 3 1 a 3)) ;;; Error cases (deftest substitute-if.error.1 (classify-error (substitute-if)) program-error) (deftest substitute-if.error.2 (classify-error (substitute-if 'a)) program-error) (deftest substitute-if.error.3 (classify-error (substitute-if 'a #'null)) program-error) (deftest substitute-if.error.4 (classify-error (substitute-if 'a #'null nil 'bad t)) program-error) (deftest substitute-if.error.5 (classify-error (substitute-if 'a #'null nil 'bad t :allow-other-keys nil)) program-error) (deftest substitute-if.error.6 (classify-error (substitute-if 'a #'null nil :key)) program-error) (deftest substitute-if.error.7 (classify-error (substitute-if 'a #'null nil 1 2)) program-error) (deftest substitute-if.error.8 (classify-error (substitute-if 'a #'cons (list 'a 'b 'c))) program-error) (deftest substitute-if.error.9 (classify-error (substitute-if 'a #'car (list 'a 'b 'c))) type-error) (deftest substitute-if.error.10 (classify-error (substitute-if 'a #'identity (list 'a 'b 'c) :key #'car)) type-error) (deftest substitute-if.error.11 (classify-error (substitute-if 'a #'identity (list 'a 'b 'c) :key #'cons)) program-error) gcl/ansi-tests/substitute.lsp000066400000000000000000000716611242227143400166640ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 28 21:15:33 2002 ;;;; Contains: Tests for SUBSTITUTE (in-package :cl-test) (deftest substitute-list.1 (let ((x '())) (values (substitute 'b 'a x) x)) nil nil) (deftest substitute-list.2 (let ((x '(a b a c))) (values (substitute 'b 'a x) x)) (b b b c) (a b a c)) (deftest substitute-list.3 (let ((x '(a b a c))) (values (substitute 'b 'a x :count nil) x)) (b b b c) (a b a c)) (deftest substitute-list.4 (let ((x '(a b a c))) (values (substitute 'b 'a x :count 2) x)) (b b b c) (a b a c)) (deftest substitute-list.5 (let ((x '(a b a c))) (values (substitute 'b 'a x :count 1) x)) (b b a c) (a b a c)) (deftest substitute-list.6 (let ((x '(a b a c))) (values (substitute 'b 'a x :count 0) x)) (a b a c) (a b a c)) (deftest substitute-list.7 (let ((x '(a b a c))) (values (substitute 'b 'a x :count -1) x)) (a b a c) (a b a c)) (deftest substitute-list.8 (let ((x '())) (values (substitute 'b 'a x :from-end t) x)) nil nil) (deftest substitute-list.9 (let ((x '(a b a c))) (values (substitute 'b 'a x :from-end t) x)) (b b b c) (a b a c)) (deftest substitute-list.10 (let ((x '(a b a c))) (values (substitute 'b 'a x :from-end t :count nil) x)) (b b b c) (a b a c)) (deftest substitute-list.11 (let ((x '(a b a c))) (values (substitute 'b 'a x :count 2 :from-end t) x)) (b b b c) (a b a c)) (deftest substitute-list.12 (let ((x '(a b a c))) (values (substitute 'b 'a x :count 1 :from-end t) x)) (a b b c) (a b a c)) (deftest substitute-list.13 (let ((x '(a b a c))) (values (substitute 'b 'a x :count 0 :from-end t) x)) (a b a c) (a b a c)) (deftest substitute-list.14 (let ((x '(a b a c))) (values (substitute 'b 'a x :count -1 :from-end t) x)) (a b a c) (a b a c)) (deftest substitute-list.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-list.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j :from-end t))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-list.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j :count c))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-list.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j :count c :from-end t))) (and (equal orig x) (equal y (nconc (make-list (- j c) :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))))) t) (deftest substitute-list.19 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) (and (equal orig x) result)) (1 2 x x x x x 8 9)) (deftest substitute-list.20 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) (and (equal orig x) result)) (1 2 x 4 5 6 7 8 9)) (deftest substitute-list.21 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) :from-end t))) (and (equal orig x) result)) (1 2 3 4 5 6 7 x 9)) (deftest substitute-list.22 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) (and (equal orig x) result)) (1 2 x 4 5 6 7 8 9)) (deftest substitute-list.23 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) :from-end t))) (and (equal orig x) result)) (1 2 3 4 5 6 7 x 9)) (deftest substitute-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car))) (and (equal orig x) result)) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) (and (equal orig x) result)) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-list.26 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car :test (complement #'eql)))) (and (equal orig x) result)) ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest substitute-list.27 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car :test-not #'eql))) (and (equal orig x) result)) ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) ;;; Tests on vectors (deftest substitute-vector.1 (let ((x #())) (values (substitute 'b 'a x) x)) #() #()) (deftest substitute-vector.2 (let ((x #(a b a c))) (values (substitute 'b 'a x) x)) #(b b b c) #(a b a c)) (deftest substitute-vector.3 (let ((x #(a b a c))) (values (substitute 'b 'a x :count nil) x)) #(b b b c) #(a b a c)) (deftest substitute-vector.4 (let ((x #(a b a c))) (values (substitute 'b 'a x :count 2) x)) #(b b b c) #(a b a c)) (deftest substitute-vector.5 (let ((x #(a b a c))) (values (substitute 'b 'a x :count 1) x)) #(b b a c) #(a b a c)) (deftest substitute-vector.6 (let ((x #(a b a c))) (values (substitute 'b 'a x :count 0) x)) #(a b a c) #(a b a c)) (deftest substitute-vector.7 (let ((x #(a b a c))) (values (substitute 'b 'a x :count -1) x)) #(a b a c) #(a b a c)) (deftest substitute-vector.8 (let ((x #())) (values (substitute 'b 'a x :from-end t) x)) #() #()) (deftest substitute-vector.9 (let ((x #(a b a c))) (values (substitute 'b 'a x :from-end t) x)) #(b b b c) #(a b a c)) (deftest substitute-vector.10 (let ((x #(a b a c))) (values (substitute 'b 'a x :from-end t :count nil) x)) #(b b b c) #(a b a c)) (deftest substitute-vector.11 (let ((x #(a b a c))) (values (substitute 'b 'a x :count 2 :from-end t) x)) #(b b b c) #(a b a c)) (deftest substitute-vector.12 (let ((x #(a b a c))) (values (substitute 'b 'a x :count 1 :from-end t) x)) #(a b b c) #(a b a c)) (deftest substitute-vector.13 (let ((x #(a b a c))) (values (substitute 'b 'a x :count 0 :from-end t) x)) #(a b a c) #(a b a c)) (deftest substitute-vector.14 (let ((x #(a b a c))) (values (substitute 'b 'a x :count -1 :from-end t) x)) #(a b a c) #(a b a c)) (deftest substitute-vector.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-vector.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-vector.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-vector.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array (- j c) :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))))) t) (deftest substitute-vector.19 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) (and (equalp orig x) result)) #(1 2 x x x x x 8 9)) (deftest substitute-vector.20 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) (and (equalp orig x) result)) #(1 2 x 4 5 6 7 8 9)) (deftest substitute-vector.21 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) :from-end t))) (and (equalp orig x) result)) #(1 2 3 4 5 6 7 x 9)) (deftest substitute-vector.22 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) (and (equalp orig x) result)) #(1 2 x 4 5 6 7 8 9)) (deftest substitute-vector.23 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) :from-end t))) (and (equalp orig x) result)) #(1 2 3 4 5 6 7 x 9)) (deftest substitute-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car))) (and (equalp orig x) result)) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) (and (equalp orig x) result)) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-vector.26 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car :test (complement #'eql)))) (and (equalp orig x) result)) #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest substitute-vector.27 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car :test-not #'eql))) (and (equalp orig x) result)) #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest substitute-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute 'z 'a x))) result) #(z b z c b)) (deftest substitute-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute 'z 'a x :from-end t))) result) #(z b z c b)) (deftest substitute-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute 'z 'a x :count 1))) result) #(z b a c b)) (deftest substitute-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute 'z 'a x :from-end t :count 1))) result) #(a b z c b)) ;;; Tests on strings (deftest substitute-string.1 (let ((x "")) (values (substitute #\b #\a x) x)) "" "") (deftest substitute-string.2 (let ((x "abac")) (values (substitute #\b #\a x) x)) "bbbc" "abac") (deftest substitute-string.3 (let ((x "abac")) (values (substitute #\b #\a x :count nil) x)) "bbbc" "abac") (deftest substitute-string.4 (let ((x "abac")) (values (substitute #\b #\a x :count 2) x)) "bbbc" "abac") (deftest substitute-string.5 (let ((x "abac")) (values (substitute #\b #\a x :count 1) x)) "bbac" "abac") (deftest substitute-string.6 (let ((x "abac")) (values (substitute #\b #\a x :count 0) x)) "abac" "abac") (deftest substitute-string.7 (let ((x "abac")) (values (substitute #\b #\a x :count -1) x)) "abac" "abac") (deftest substitute-string.8 (let ((x "")) (values (substitute #\b #\a x :from-end t) x)) "" "") (deftest substitute-string.9 (let ((x "abac")) (values (substitute #\b #\a x :from-end t) x)) "bbbc" "abac") (deftest substitute-string.10 (let ((x "abac")) (values (substitute #\b #\a x :from-end t :count nil) x)) "bbbc" "abac") (deftest substitute-string.11 (let ((x "abac")) (values (substitute #\b #\a x :count 2 :from-end t) x)) "bbbc" "abac") (deftest substitute-string.12 (let ((x "abac")) (values (substitute #\b #\a x :count 1 :from-end t) x)) "abbc" "abac") (deftest substitute-string.13 (let ((x "abac")) (values (substitute #\b #\a x :count 0 :from-end t) x)) "abac" "abac") (deftest substitute-string.14 (let ((x "abac")) (values (substitute #\b #\a x :count -1 :from-end t) x)) "abac" "abac") (deftest substitute-string.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute #\x #\a x :start i :end j))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-string.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute #\x #\a x :start i :end j :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-string.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute #\x #\a x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 (+ i c)) :initial-element #\a)))))))) t) (deftest substitute-string.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute #\x #\a x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array (- j c) :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))))) t) (deftest substitute-string.19 (let* ((orig "123456789") (x (copy-seq orig)) (result (substitute #\x #\5 x :test #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (<= (abs (- a b)) 2))))) (and (equalp orig x) result)) "12xxxxx89") (deftest substitute-string.20 (let* ((orig "123456789") (x (copy-seq orig)) (c -4) (result (substitute #\x #\5 x :test #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c 2) (= (+ b c) a))))) (and (equalp orig x) result)) "12x456789") (deftest substitute-string.21 (let* ((orig "123456789") (x (copy-seq orig)) (c 5) (result (substitute #\x #\9 x :test #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c -2) (= (+ b c) a)) :from-end t))) (and (equalp orig x) result)) "1234567x9") (deftest substitute-string.22 (let* ((orig "123456789") (x (copy-seq orig)) (c -4) (result (substitute #\x #\5 x :test-not #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c 2) (/= (+ b c) a))))) (and (equalp orig x) result)) "12x456789") (deftest substitute-string.23 (let* ((orig "123456789") (x (copy-seq orig)) (c 5) (result (substitute #\x #\9 x :test-not #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c -2) (/= (+ b c) a)) :from-end t))) (and (equalp orig x) result)) "1234567x9") (deftest substitute-string.24 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute #\a #\1 x :key #'nextdigit))) (and (equalp orig x) result)) "a1a2342a15") (deftest substitute-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) (and (equalp orig x) result)) "01a2342015") (deftest substitute-string.26 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute #\a #\1 x :key #'nextdigit :test (complement #'eql)))) (and (equalp orig x) result)) "0a0aaaa0aa") (deftest substitute-string.27 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute #\a #\1 x :key #'nextdigit :test-not #'eql))) (and (equalp orig x) result)) "0a0aaaa0aa") (deftest substitute-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute #\z #\a x))) result) "zbzcb") (deftest substitute-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute #\z #\a x :from-end t))) result) "zbzcb") (deftest substitute-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute #\z #\a x :count 1))) result) "zbacb") (deftest substitute-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute #\z #\a x :from-end t :count 1))) result) "abzcb") ;;; Tests on bit-vectors (deftest substitute-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (substitute 0 1 x))) (and (equalp orig x) result)) #*) (deftest substitute-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (substitute 1 0 x))) (and (equalp orig x) result)) #*) (deftest substitute-bit-vector.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 0 1 x))) (and (equalp orig x) result)) #*000000) (deftest substitute-bit-vector.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x))) (and (equalp orig x) result)) #*111111) (deftest substitute-bit-vector.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :start 1))) (and (equalp orig x) result)) #*011111) (deftest substitute-bit-vector.6 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 0 1 x :start 2 :end nil))) (and (equalp orig x) result)) #*010000) (deftest substitute-bit-vector.7 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :end 4))) (and (equalp orig x) result)) #*111101) (deftest substitute-bit-vector.8 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 0 1 x :end nil))) (and (equalp orig x) result)) #*000000) (deftest substitute-bit-vector.9 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 0 1 x :end 3))) (and (equalp orig x) result)) #*000101) (deftest substitute-bit-vector.10 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 0 1 x :start 2 :end 4))) (and (equalp orig x) result)) #*010001) (deftest substitute-bit-vector.11 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :start 2 :end 4))) (and (equalp orig x) result)) #*011101) (deftest substitute-bit-vector.12 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count 1))) (and (equalp orig x) result)) #*110101) (deftest substitute-bit-vector.13 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count 0))) (and (equalp orig x) result)) #*010101) (deftest substitute-bit-vector.14 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count -1))) (and (equalp orig x) result)) #*010101) (deftest substitute-bit-vector.15 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count 1 :from-end t))) (and (equalp orig x) result)) #*010111) (deftest substitute-bit-vector.16 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count 0 :from-end t))) (and (equalp orig x) result)) #*010101) (deftest substitute-bit-vector.17 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count -1 :from-end t))) (and (equalp orig x) result)) #*010101) (deftest substitute-bit-vector.18 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count nil))) (and (equalp orig x) result)) #*111111) (deftest substitute-bit-vector.19 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count nil :from-end t))) (and (equalp orig x) result)) #*111111) (deftest substitute-bit-vector.20 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*0000000000) (x (copy-seq orig)) (y (substitute 1 0 x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-bit-vector (make-list i :initial-element 0) (make-list c :initial-element 1) (make-list (- 10 (+ i c)) :initial-element 0)))))))) t) (deftest substitute-bit-vector.21 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*1111111111) (x (copy-seq orig)) (y (substitute 0 1 x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-bit-vector (make-list (- j c) :initial-element 1) (make-list c :initial-element 0) (make-list (- 10 j) :initial-element 1)))))))) t) (deftest substitute-bit-vector.22 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) (and (equalp orig x) result)) #*0111110101) (deftest substitute-bit-vector.23 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) (not (and (<= 2 c 5) (= a b))))))) (and (equalp orig x) result)) #*0111110101) (deftest substitute-bit-vector.24 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) :from-end t))) (and (equalp orig x) result)) #*0101011111) (deftest substitute-bit-vector.25 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) (not (and (<= 2 c 5) (= a b)))) :from-end t))) (and (equalp orig x) result)) #*0101011111) (deftest substitute-bit-vector.26 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute 1 1 x :key #'1+))) (and (equalp orig x) result)) #*11111111111111111) (deftest substitute-bit-vector.27 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute 1 1 x :key #'1+ :start 1 :end 10))) (and (equalp orig x) result)) #*01111111111010110) (deftest substitute-bit-vector.28 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute 0 1 x :key #'1+ :test (complement #'eql)))) (and (equalp orig x) result)) #*00000000000000000) (deftest substitute-bit-vector.29 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute 0 1 x :key #'1+ :test-not #'eql))) (and (equalp orig x) result)) #*00000000000000000) (deftest substitute-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute 1 0 x))) result) #*11111) (deftest substitute-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute 1 0 x :from-end t))) result) #*11111) (deftest substitute-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute 1 0 x :count 1))) result) #*11011) (deftest substitute-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute 1 0 x :from-end t :count 1))) result) #*01111) (deftest substitute.order.1 (let ((i 0) a b c d e f g h) (values (substitute (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) nil) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :count (progn (setf d (incf i)) 2) :start (progn (setf e (incf i)) 0) :end (progn (setf f (incf i)) 7) :key (progn (setf g (incf i)) #'identity) :from-end (setf h (incf i)) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 4 5 6 7 8) (deftest substitute.order.2 (let ((i 0) a b c d e f g h) (values (substitute (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) nil) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :from-end (setf h (incf i)) :key (progn (setf g (incf i)) #'identity) :end (progn (setf f (incf i)) 7) :start (progn (setf e (incf i)) 0) :count (progn (setf d (incf i)) 2) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 8 7 6 5 4) ;;; Keyword tests (deftest substitute.allow-other-keys.1 (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) (1 2 a 3 1 a 3)) (deftest substitute.allow-other-keys.2 (substitute 'a 0 (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) (1 2 a 3 1 a 3)) (deftest substitute.allow-other-keys.3 (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :allow-other-keys nil :bad t) (1 2 a 3 1 a 3)) (deftest substitute.allow-other-keys.4 (substitute 'a 0 (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest substitute.allow-other-keys.5 (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :key #'1-) (a 2 0 3 a 0 3)) (deftest substitute.keywords.6 (substitute 'a 0 (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) (a 2 0 3 a 0 3)) (deftest substitute.allow-other-keys.7 (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest substitute.allow-other-keys.8 (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys nil) (1 2 a 3 1 a 3)) ;;; Error cases (deftest substitute.error.1 (classify-error (substitute)) program-error) (deftest substitute.error.2 (classify-error (substitute 'a)) program-error) (deftest substitute.error.3 (classify-error (substitute 'a 'b)) program-error) (deftest substitute.error.4 (classify-error (substitute 'a 'b nil 'bad t)) program-error) (deftest substitute.error.5 (classify-error (substitute 'a 'b nil 'bad t :allow-other-keys nil)) program-error) (deftest substitute.error.6 (classify-error (substitute 'a 'b nil :key)) program-error) (deftest substitute.error.7 (classify-error (substitute 'a 'b nil 1 2)) program-error) (deftest substitute.error.8 (classify-error (substitute 'a 'b (list 'a 'b 'c) :test #'identity)) program-error) (deftest substitute.error.9 (classify-error (substitute 'a 'b (list 'a 'b 'c) :test-not #'identity)) program-error) (deftest substitute.error.10 (classify-error (substitute 'a 'b (list 'a 'b 'c) :key #'cons)) program-error) (deftest substitute.error.11 (classify-error (substitute 'a 'b (list 'a 'b 'c) :key #'car)) type-error) gcl/ansi-tests/subtypep-array.lsp000066400000000000000000000051651242227143400174340ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 1 16:23:57 2003 ;;;; Contains: Tests of SUBTYPEP on array types (in-package :cl-test) ;;; *array-element-types* is defined in ansi-aux.lsp (deftest subtypep.array.1 (let ((array-types (cons (find-class 'array) '(array (array) (array *) (array * *))))) (loop for tp1 in array-types append (loop for tp2 in array-types unless (subtypep tp1 tp2) collect (list tp1 tp2)))) nil) (deftest subtypep.array.2 (and (subtypep* '(array t) '(array t *)) (subtypep* '(array t *) '(array t)) t) t) (deftest subtypep.array.3 (loop for i from 0 below (min 16 array-rank-limit) for type = `(array * ,i) for type2 = `(array * ,(make-list i :initial-element '*)) unless (and (subtypep type 'array) (subtypep type '(array)) (subtypep type '(array *)) (subtypep type '(array * *)) (subtypep type type2)) collect type) nil) (deftest subtypep.array.4 (loop for i from 0 below (min 16 array-rank-limit) for type = `(array t ,i) for type2 = `(array t ,(make-list i :initial-element '*)) unless (and (subtypep type '(array t)) (subtypep type '(array t *)) (subtypep type type2)) collect type) nil) (deftest subtypep.array.5 (loop for element-type in (cons '* *array-element-types*) nconc (loop for i from 0 below (min 16 array-rank-limit) for type = `(array ,element-type ,i) for type2 = `(array ,element-type ,(make-list i :initial-element '0)) for type3 = `(array ,element-type ,(make-list i :initial-element '1)) unless (and (subtypep type2 type) (subtypep type3 type) (loop for j from 0 to i always (and (subtypep `(array ,element-type (,@(make-list j :initial-element '*) ,@(make-list (- i j) :initial-element 2))) type) (subtypep `(array ,element-type (,@(make-list j :initial-element 2) ,@(make-list (- i j) :initial-element '*))) type)))) collect type)) nil) (deftest subtypep.aray.6 (loop for etype in (cons '* *array-element-types*) append (check-equivalence `(and (array ,etype (* 10 * * *)) (array ,etype (* * * 29 *))) `(array ,etype (* 10 * 29 *)))) nil) (deftest subtypep.aray.7 (let ((etypes *array-element-types*)) (loop for etp1 in etypes for uaetp1 = (upgraded-array-element-type etp1) append (loop for etp2 in etypes for uaetp2 = (upgraded-array-element-type etp2) when (equal (multiple-value-list (subtypep* uaetp1 uaetp2)) '(nil t)) append (check-disjointness `(array ,etp1) `(array ,etp2))))) nil) gcl/ansi-tests/subtypep-cons.lsp000066400000000000000000000120571242227143400172560ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 11:57:03 2003 ;;;; Contains: Tests for subtype relationships on cons types (in-package :cl-test) ;;; SUBTYPEP on CONS types (defvar *cons-types* '(cons (cons) (cons *) (cons * *) (cons t) (cons t t) (cons t *) (cons * t))) (deftest subtypep.cons.1 (loop for t1 in *cons-types* append (loop for t2 in *cons-types* unless (equal (mapcar #'notnot (multiple-value-list (subtypep t1 t2))) '(t t)) collect (list t1 t2))) nil) (deftest subtypep.cons.2 (loop for t1 in '((cons nil) (cons nil *) (cons nil t) (cons * nil) (cons t nil) (cons nil nil)) unless (subtypep t1 nil) collect t1) nil) (deftest subtypep.cons.3 (check-equivalence '(and (cons symbol *) (cons * symbol)) '(cons symbol symbol)) nil) (deftest subtypep.cons.4 (check-equivalence '(and (cons (integer 0 10) *) (cons (integer 5 15) (integer 10 20)) (cons * (integer 15 25))) '(cons (integer 5 10) (integer 15 20))) nil) (deftest subtypep.cons.5 (check-equivalence '(and cons (not (cons symbol symbol))) '(or (cons (not symbol) *) (cons * (not symbol)))) nil) (deftest subtypep.cons.6 (check-equivalence '(or (cons integer symbol) (cons integer integer) (cons symbol integer) (cons symbol symbol)) '(cons (or integer symbol) (or integer symbol))) nil) (deftest subtypep.cons.7 (check-equivalence '(or (cons (integer 0 8) (integer 5 15)) (cons (integer 0 7) (integer 0 6)) (cons (integer 6 15) (integer 0 9)) (cons (integer 3 15) (integer 4 15))) '(cons (integer 0 15) (integer 0 15))) nil) (deftest subtypep.cons.8 (check-equivalence '(or (cons integer (cons symbol integer)) (cons symbol (cons integer symbol)) (cons symbol (cons symbol integer)) (cons symbol (cons integer integer)) (cons integer (cons integer symbol)) (cons symbol (cons symbol symbol)) (cons integer (cons integer integer)) (cons integer (cons symbol symbol))) '(cons (or symbol integer) (cons (or symbol integer) (or symbol integer)))) nil) (deftest subtypep.cons.9 (check-equivalence '(or (cons (integer 0 (3)) (integer 0 (6))) (cons (integer 3 (9)) (integer 0 (3))) (cons (integer 0 (6)) (integer 6 (9))) (cons (integer 6 (9)) (integer 3 (9))) (cons (integer 3 (6)) (integer 3 (6)))) '(cons (integer 0 (9)) (integer 0 (9)))) nil) (deftest subtypep.cons.10 (check-equivalence '(or (cons (rational 0 (3)) (rational 0 (6))) (cons (rational 3 (9)) (rational 0 (3))) (cons (rational 0 (6)) (rational 6 (9))) (cons (rational 6 (9)) (rational 3 (9))) (cons (rational 3 (6)) (rational 3 (6)))) '(cons (rational 0 (9)) (rational 0 (9)))) nil) (deftest subtypep.cons.11 (check-equivalence '(or (cons (real 0 (3)) (real 0 (6))) (cons (real 3 (9)) (real 0 (3))) (cons (real 0 (6)) (real 6 (9))) (cons (real 6 (9)) (real 3 (9))) (cons (real 3 (6)) (real 3 (6)))) '(cons (real 0 (9)) (real 0 (9)))) nil) ;;; Test suggested by C.R. (deftest subtypep.cons.12 (check-all-not-subtypep '(cons (or integer symbol) (or integer symbol)) '(or (cons integer symbol) (cons symbol integer))) nil) (deftest subtypep.cons.13 (check-all-not-subtypep '(not list) 'cons) nil) ;;; a -> b, a ==> b (deftest subtypep.cons.14 (check-all-subtypep '(and (or (cons (not symbol)) (cons * integer)) (cons symbol)) '(cons * integer)) nil) ;;; a -> b, not b ==> not a (deftest subtypep.cons.15 (check-all-subtypep '(and (or (cons (not symbol)) (cons * integer)) (cons * (not integer))) '(cons (not symbol))) nil) ;;; (and (or a b) (or (not b) c)) ==> (or a c) (deftest subtypep.cons.16 (check-all-subtypep '(and (or (cons symbol (cons * *)) (cons * (cons integer *))) (or (cons * (cons (not integer) *)) (cons * (cons * float)))) '(or (cons symbol (cons * *)) (cons * (cons * float)))) nil) (deftest subtypep.cons.17 (check-all-subtypep '(and (or (cons symbol (cons * *)) (cons * (cons integer *))) (or (cons * (cons (not integer))) (cons * (cons * float))) (or (cons * (cons * (not float))) (cons symbol (cons * *)))) '(cons symbol)) nil) (deftest subtypep.cons.18 (check-all-subtypep '(cons symbol) '(or (cons symbol (not integer)) (cons * integer))) nil) (deftest subtypep.cons.19 (check-equivalence '(or (cons (eql a) (eql x)) (cons (eql b) (eql y)) (cons (eql c) (eql z)) (cons (eql a) (eql y)) (cons (eql b) (eql z)) (cons (eql c) (eql x)) (cons (eql a) (eql z)) (cons (eql b) (eql x)) (cons (eql c) (eql y))) '(cons (member a b c) (member x y z))) nil) (deftest subtypep.cons.20 (check-equivalence '(or (cons (eql a) (eql x)) (cons (eql b) (eql y)) (cons (eql a) (eql y)) (cons (eql b) (eql z)) (cons (eql c) (eql x)) (cons (eql a) (eql z)) (cons (eql b) (eql x)) (cons (eql c) (eql y))) '(and (cons (member a b c) (member x y z)) (not (cons (eql c) (eql z))))) nil) gcl/ansi-tests/subtypep-eql.lsp000066400000000000000000000024541242227143400170750ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 11:58:43 2003 ;;;; Contains: Tests for subtype relationships on EQL types (in-package :cl-test) (deftest subtypep.eql.1 (let ((s1 (copy-seq "abc")) (s2 (copy-seq "abc"))) (let ((t1 `(eql ,s1)) (t2 `(eql ,s2))) (cond ((subtypep t1 t2) "T1 is subtype of T2") ((subtypep t2 t1) "T2 is subtype of T1") (t (check-disjointness t1 t2))))) nil) (deftest subtypep.eql.2 (let ((s1 (copy-seq '(a b c))) (s2 (copy-seq '(a b c)))) (let ((t1 `(eql ,s1)) (t2 `(eql ,s2))) (cond ((subtypep t1 t2) "T1 is subtype of T2") ((subtypep t2 t1) "T2 is subtype of T1") (t (check-disjointness t1 t2))))) nil) (deftest subtypep.eql.3 (let ((i1 (1+ most-positive-fixnum)) (i2 (1+ most-positive-fixnum))) (check-equivalence `(eql ,i1) `(eql ,i2))) nil) (deftest subtypep.eql.4 (check-equivalence '(and (eql a) (eql b)) nil) nil) (deftest subtypep.eql.5 (check-all-subtypep '(eql a) '(satisfies symbolp)) nil) (deftest subtypep.eql.6 (check-disjointness '(eql 17) '(satisfies symbolp)) nil) (deftest subtypep.eql.7 (check-all-subtypep '(eql nil) '(satisfies symbolp)) nil) (deftest subtypep.eql.8 (check-all-not-subtypep '(satisfies symbolp) '(eql a)) nil) gcl/ansi-tests/subtypep-float.lsp000066400000000000000000000117611242227143400174220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 11:55:37 2003 ;;;; Contains: Tests for subtype relationships on float types (in-package :cl-test) ;;;;;;; (deftest subtypep.float.1 (loop for tp in +float-types+ append (check-subtypep tp 'float t t)) nil) (deftest subtypep.float.2 (if (subtypep 'short-float 'long-float) (loop for tp in +float-types+ append (loop for tp2 in +float-types+ append (check-subtypep tp tp2 t t))) nil) nil) (deftest subtypep.float.3 (if (and (not (subtypep 'short-float 'single-float)) (subtypep 'single-float 'long-float)) (append (check-equivalence 'single-float 'double-float) (check-equivalence 'single-float 'long-float) (check-equivalence 'double-float 'long-float) (classes-are-disjoint 'short-float 'single-float) (classes-are-disjoint 'short-float 'double-float) (classes-are-disjoint 'short-float 'long-float)) nil) nil) (deftest subtypep.float.4 (if (and (subtypep 'single-float 'short-float) (subtypep 'double-float 'long-float) (not (subtypep 'short-float 'double-float))) (append (check-equivalence 'short-float 'single-float) (check-equivalence 'double-float 'long-float) (loop for tp in '(short-float single-float) append (loop for tp2 in '(double-float long-float) append (classes-are-disjoint tp tp2)))) nil) nil) (deftest subtypep.float.5 (if (and (not (subtypep 'single-float 'short-float)) (not (subtypep 'single-float 'double-float)) (subtypep 'double-float 'long-float)) (append (classes-are-disjoint 'short-float 'single-float) (classes-are-disjoint 'short-float 'double-float) (classes-are-disjoint 'short-float 'long-float) (classes-are-disjoint 'single-float 'double-float) (classes-are-disjoint 'single-float 'long-float) (check-equivalence 'double-float 'long-float)) nil) nil) (deftest subtypep.float.6 (if (and (subtypep 'single-float 'short-float) (not (subtypep 'single-float 'double-float)) (not (subtypep 'double-float 'long-float))) (append (check-equivalence 'short-float 'single-float) (classes-are-disjoint 'single-float 'double-float) (classes-are-disjoint 'single-float 'long-float) (classes-are-disjoint 'double-float 'long-float)) nil) nil) (deftest subtypep.float.7 (if (and (not (subtypep 'single-float 'short-float)) (not (subtypep 'single-float 'double-float)) (not (subtypep 'double-float 'long-float))) (loop for tp in +float-types+ append (loop for tp2 in +float-types+ unless (eq tp tp2) append (classes-are-disjoint tp tp2))) nil) nil) (deftest subtypep.float.8 (subtypep* '(short-float 0.0s0 10.0s0) '(short-float 0.0s0 11.0s0)) t t) (deftest subtypep.float.9 (subtypep* '(single-float 0.0f0 10.0f0) '(single-float 0.0f0 11.0f0)) t t) (deftest subtypep.float.10 (subtypep* '(double-float 0.0d0 10.0d0) '(double-float 0.0d0 11.0d0)) t t) (deftest subtypep.float.11 (subtypep* '(long-float 0.0l0 10.0l0) '(long-float 0.0l0 11.0l0)) t t) (deftest subtypep.float.12 (subtypep* '(short-float 0.0s0 11.0s0) '(short-float 0.0s0 10.0s0)) nil t) (deftest subtypep.float.13 (subtypep* '(single-float 0.0f0 11.0f0) '(single-float 0.0f0 10.0f0)) nil t) (deftest subtypep.float.14 (subtypep* '(double-float 0.0d0 11.0d0) '(double-float 0.0d0 10.0d0)) nil t) (deftest subtypep.float.15 (subtypep* '(long-float 0.0l0 11.0l0) '(long-float 0.0l0 10.0l0)) nil t) (deftest subtypep.float.16 (subtypep* '(short-float 0.0s0 (10.0s0)) '(short-float 0.0s0 10.0s0)) t t) (deftest subtypep.float.17 (subtypep* '(single-float 0.0f0 (10.0f0)) '(single-float 0.0f0 10.0f0)) t t) (deftest subtypep.float.18 (subtypep* '(double-float 0.0d0 (10.0d0)) '(double-float 0.0d0 10.0d0)) t t) (deftest subtypep.float.19 (subtypep* '(long-float 0.0l0 (10.0l0)) '(long-float 0.0l0 10.0l0)) t t) (deftest subtypep.float.20 (subtypep* '(short-float 0.0s0 10.0s0) '(short-float 0.0s0 (10.0s0))) nil t) (deftest subtypep.float.21 (subtypep* '(single-float 0.0f0 10.0f0) '(single-float 0.0f0 (10.0f0))) nil t) (deftest subtypep.float.22 (subtypep* '(double-float 0.0d0 10.0d0) '(double-float 0.0d0 (10.0d0))) nil t) (deftest subtypep.float.23 (subtypep* '(long-float 0.0l0 10.0l0) '(long-float 0.0l0 (10.0l0))) nil t) (deftest subtypep.float.24 (check-equivalence '(and (short-float 0.0s0 2.0s0) (short-float 1.0s0 3.0s0)) '(short-float 1.0s0 2.0s0)) nil) (deftest subtypep.float.25 (check-equivalence '(and (single-float 0.0f0 2.0f0) (single-float 1.0f0 3.0f0)) '(single-float 1.0f0 2.0f0)) nil) (deftest subtypep.float.26 (check-equivalence '(and (double-float 0.0d0 2.0d0) (double-float 1.0d0 3.0d0)) '(double-float 1.0d0 2.0d0)) nil) (deftest subtypep.float.27 (check-equivalence '(and (long-float 0.0l0 2.0l0) (long-float 1.0l0 3.0l0)) '(long-float 1.0l0 2.0l0)) nil) gcl/ansi-tests/subtypep-integer.lsp000066400000000000000000000240211242227143400177430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 11:54:05 2003 ;;;; Contains: Tests for subtype relationships on integer types (in-package :cl-test) (deftest subtypep.fixnum-or-bignum (check-equivalence '(or fixnum bignum) 'integer) nil) (deftest subtypep.fixnum.integer (check-equivalence `(integer ,most-negative-fixnum ,most-positive-fixnum) 'fixnum) nil) (deftest subtypep.bignum.integer (check-equivalence `(or (integer * (,most-negative-fixnum)) (integer (,most-positive-fixnum) *)) 'bignum) nil) ;;;;;;; (deftest subtypep.integer.1 (subtypep* '(integer 0 10) '(integer 0 20)) t t) (deftest subtypep.integer.2 (subtypep* '(integer 0 10) '(integer 0 (10))) nil t) (deftest subtypep.integer.3 (subtypep* '(integer 10 100) 'integer) t t) (deftest subtypep.integer.3a (subtypep* '(integer 10 100) '(integer)) t t) (deftest subtypep.integer.3b (subtypep* '(integer 10 100) '(integer *)) t t) (deftest subtypep.integer.3c (subtypep* '(integer 10 100) '(integer * *)) t t) (deftest subtypep.integer.4 (subtypep* 'integer '(integer 10 100)) nil t) (deftest subtypep.integer.4a (subtypep* '(integer) '(integer 10 100)) nil t) (deftest subtypep.integer.4b (subtypep* '(integer *) '(integer 10 100)) nil t) (deftest subtypep.integer.4c (subtypep* '(integer * *) '(integer 10 100)) nil t) (deftest subtypep.integer.5 (subtypep* '(integer 10 *) 'integer) t t) (deftest subtypep.integer.5a (subtypep* '(integer 10 *) '(integer)) t t) (deftest subtypep.integer.5b (subtypep* '(integer 10 *) '(integer *)) t t) (deftest subtypep.integer.5c (subtypep* '(integer 10 *) '(integer * *)) t t) (deftest subtypep.integer.6 (subtypep* 'integer '(integer 10 *)) nil t) (deftest subtypep.integer.6a (subtypep* '(integer) '(integer 10 *)) nil t) (deftest subtypep.integer.6b (subtypep* '(integer *) '(integer 10 *)) nil t) (deftest subtypep.integer.6c (subtypep* '(integer * *) '(integer 10 *)) nil t) (deftest subtypep.integer.7 (subtypep* '(integer 10) 'integer) t t) (deftest subtypep.integer.7a (subtypep* '(integer 10) '(integer)) t t) (deftest subtypep.integer.7b (subtypep* '(integer 10) '(integer *)) t t) (deftest subtypep.integer.7c (subtypep* '(integer 10) '(integer * *)) t t) (deftest subtypep.integer.8 (subtypep* 'integer '(integer 10)) nil t) (deftest subtypep.integer.8a (subtypep* '(integer) '(integer 10)) nil t) (deftest subtypep.integer.8b (subtypep* '(integer *) '(integer 10)) nil t) (deftest subtypep.integer.8c (subtypep* '(integer * *) '(integer 10)) nil t) (deftest subtypep.integer.9 (subtypep* '(integer * 10) 'integer) t t) (deftest subtypep.integer.9a (subtypep* '(integer * 10) '(integer)) t t) (deftest subtypep.integer.9b (subtypep* '(integer * 10) '(integer *)) t t) (deftest subtypep.integer.9c (subtypep* '(integer * 10) '(integer * *)) t t) (deftest subtypep.integer.10 (subtypep* 'integer '(integer * 10)) nil t) (deftest subtypep.integer.10a (subtypep* '(integer) '(integer * 10)) nil t) (deftest subtypep.integer.10b (subtypep* '(integer *) '(integer * 10)) nil t) (deftest subtypep.integer.10c (subtypep* '(integer * *) '(integer * 10)) nil t) (deftest subtypep.integer.11 (subtypep* '(integer 10) '(integer 5)) t t) (deftest subtypep.integer.12 (subtypep* '(integer 5) '(integer 10)) nil t) (deftest subtypep.integer.13 (subtypep* '(integer 10 *) '(integer 5)) t t) (deftest subtypep.integer.14 (subtypep* '(integer 5) '(integer 10 *)) nil t) (deftest subtypep.integer.15 (subtypep* '(integer 10) '(integer 5 *)) t t) (deftest subtypep.integer.16 (subtypep* '(integer 5 *) '(integer 10)) nil t) (deftest subtypep.integer.17 (subtypep* '(integer 10 *) '(integer 5 *)) t t) (deftest subtypep.integer.18 (subtypep* '(integer 5 *) '(integer 10 *)) nil t) (deftest subtypep.integer.19 (subtypep* '(integer * 5) '(integer * 10)) t t) (deftest subtypep.integer.20 (subtypep* '(integer * 10) '(integer * 5)) nil t) (deftest subtypep.integer.21 (subtypep* '(integer 10 *) '(integer * 10)) nil t) (deftest subtypep.integer.22 (subtypep* '(integer * 10) '(integer 10 *)) nil t) (deftest subtypep.integer.23 (check-equivalence '(integer (9)) '(integer 10)) nil) (deftest subtypep.integer.24 (check-equivalence '(integer * (11)) '(integer * 10)) nil) (deftest subtypep.integer.25 (check-equivalence '(and (or (integer 0 10) (integer 20 30)) (or (integer 5 15) (integer 25 35))) '(or (integer 5 10) (integer 25 30))) nil) (deftest subtypep.integer.26 (check-equivalence '(and (integer 0 10) (integer 5 15)) '(integer 5 10)) nil) (deftest subtypep.integer.27 (check-equivalence '(or (integer 0 10) (integer 5 15)) '(integer 0 15)) nil) (deftest subtypep.integer.28 (check-equivalence '(and integer (not (eql 10))) '(or (integer * 9) (integer 11 *))) nil) (deftest subtypep.integer.29 (check-equivalence '(and integer (not (integer 1 10))) '(or (integer * 0) (integer 11 *))) nil) (deftest subtypep.integer.30 (check-equivalence '(and (integer -100 100) (not (integer 1 10))) '(or (integer -100 0) (integer 11 100))) nil) ;;; Relations between integer and real types (deftest subtypep.integer.real.1 (check-equivalence '(and integer (real 4 10)) '(integer 4 10)) nil) (deftest subtypep.integer.real.2 (check-equivalence '(and (integer 4 *) (real * 10)) '(integer 4 10)) nil) (deftest subtypep.integer.real.3 (check-equivalence '(and (integer * 10) (real 4)) '(integer 4 10)) nil) (deftest subtypep.integer.real.4 (loop for int-type in '(integer (integer) (integer *) (integer * *)) append (loop for real-type in '(real (real) (real *) (real * *)) unless (equal (multiple-value-list (subtypep* int-type real-type)) '(t t)) collect (list int-type real-type))) nil) (deftest subtypep.integer.real.5 (loop for int-type in '((integer 10) (integer 10 *)) append (loop for real-type in '(real (real) (real *) (real * *) (real 10.0) (real 10.0 *) (real 10) (real 10 *)) unless (equal (multiple-value-list (subtypep* int-type real-type)) '(t t)) collect (list int-type real-type))) nil) (deftest subtypep.integer.real.6 (loop for int-type in '((integer * 10) (integer * 5)) append (loop for real-type in '(real (real) (real *) (real * *) (real * 10.0) (real * 10) (real * 1000000000000)) unless (equal (multiple-value-list (subtypep* int-type real-type)) '(t t)) collect (list int-type real-type))) nil) (deftest subtypep.integer.real.7 (loop for int-type in '((integer 0 10) (integer 2 5)) append (loop for real-type in '(real (real) (real *) (real * *) (real * 10) (real * 1000000000000) (real -10) (real -10.0) (real -10 *) (real -10.0 *) (real 0) (real 0.0) (real 0 10) (real * 10) (real 0 *) (real 0 10)) unless (equal (multiple-value-list (subtypep* int-type real-type)) '(t t)) collect (list int-type real-type))) nil) (deftest subtypep.integer.real.8 (check-equivalence '(and (integer 4) (real * 10)) '(integer 4 10)) nil) (deftest subtypep.integer.real.9 (check-equivalence '(and (integer * 10) (real 4)) '(integer 4 10)) nil) (deftest subtypep.integer.real.10 (check-equivalence '(and (integer 4) (real * (10))) '(integer 4 9)) nil) (deftest subtypep.integer.real.11 (check-equivalence '(and (integer * 10) (real (4))) '(integer 5 10)) nil) ;;; Between integer and rational types (deftest subtypep.integer.rational.1 (check-equivalence '(and integer (rational 4 10)) '(integer 4 10)) nil) (deftest subtypep.integer.rational.2 (check-equivalence '(and (integer 4 *) (rational * 10)) '(integer 4 10)) nil) (deftest subtypep.integer.rational.3 (check-equivalence '(and (integer * 10) (rational 4)) '(integer 4 10)) nil) (deftest subtypep.integer.rational.4 (loop for int-type in '(integer (integer) (integer *) (integer * *)) append (loop for rational-type in '(rational (rational) (rational *) (rational * *)) unless (equal (multiple-value-list (subtypep* int-type rational-type)) '(t t)) collect (list int-type rational-type))) nil) (deftest subtypep.integer.rational.5 (loop for int-type in '((integer 10) (integer 10 *)) append (loop for rational-type in '(rational (rational) (rational *) (rational * *) (rational 19/2) (rational 19/2 *) (rational 10) (rational 10 *)) unless (equal (multiple-value-list (subtypep* int-type rational-type)) '(t t)) collect (list int-type rational-type))) nil) (deftest subtypep.integer.rational.6 (loop for int-type in '((integer * 10) (integer * 5)) append (loop for rational-type in '(rational (rational) (rational *) (rational * *) (rational * 21/2) (rational * 10) (rational * 1000000000000)) unless (equal (multiple-value-list (subtypep* int-type rational-type)) '(t t)) collect (list int-type rational-type))) nil) (deftest subtypep.integer.rational.7 (loop for int-type in '((integer 0 10) (integer 2 5)) append (loop for rational-type in '(rational (rational) (rational *) (rational * *) (rational * 10) (rational * 1000000000000) (rational -1) (rational -1/2) (rational -1 *) (rational -1/2 *) (rational 0) (rational 0 10) (rational * 10) (rational 0 *) (rational 0 10)) unless (equal (multiple-value-list (subtypep* int-type rational-type)) '(t t)) collect (list int-type rational-type))) nil) (deftest subtypep.integer.rational.8 (check-equivalence '(and integer (rational (4) 10)) '(integer 5 10)) nil) (deftest subtypep.integer.rational.9 (check-equivalence '(and (integer 4 *) (rational * (10))) '(integer 4 9)) nil) (deftest subtypep.integer.rational.10 (check-equivalence '(and (integer * 10) (rational (4))) '(integer 5 10)) nil) gcl/ansi-tests/subtypep-member.lsp000066400000000000000000000125461242227143400175660ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 11:58:06 2003 ;;;; Contains: Tests for subtype relationships on member types (in-package :cl-test) ;;; SUBTYPEP on MEMBER types (deftest subtypep.member.1 (check-all-subtypep '(member a b c) '(member a b c d)) nil) (deftest subtypep.member.2 (check-all-not-subtypep '(member a b c) '(member a b)) nil) (deftest subtypep.member.3 (check-equivalence '(member) nil) nil) (deftest subtypep.member.4 (check-all-subtypep '(eql b) '(member a b c)) nil) (deftest subtypep.member.5 (check-all-subtypep '(member a b c d e) 'symbol) nil) (deftest subtypep.member.6 (check-all-not-subtypep '(member a b 10 d e) 'symbol) nil) (deftest subtypep.member.7 (check-all-subtypep 'null '(member a b nil c d e)) nil) (deftest subtypep.member.8 (check-all-not-subtypep 'null '(member a b c d e)) nil) (deftest subtypep.member.9 (let ((b1 (1+ most-positive-fixnum)) (b2 (1+ most-positive-fixnum))) (check-all-subtypep `(member 10 ,b1 20) `(member 10 20 ,b2))) nil) (deftest subtypep.member.10 (check-all-subtypep '(member :a :b :c) 'keyword) nil) (deftest subtypep.member.11 (let ((b1 (copy-list '(a))) (b2 (copy-list '(a)))) (check-all-not-subtypep `(member 10 ,b1 20) `(member 10 20 ,b2))) nil) (deftest subtypep.member.12 (let ((b1 '(a))) (check-all-subtypep `(member 10 ,b1 20) `(member 10 20 ,b1))) nil) (deftest subtypep.member.13 (check-all-subtypep '(member 10 20 30) '(integer 0 100)) nil) (deftest subtypep.member.14 (check-all-subtypep '(integer 3 6) '(member 0 1 2 3 4 5 6 7 8 100)) nil) (deftest subtypep.member.15 (check-all-not-subtypep '(integer 3 6) '(member 0 1 2 3 5 6 7 8)) nil) (deftest subtypep.member.16 (check-equivalence '(integer 2 5) '(member 2 5 4 3)) nil) (deftest subtypep.member.17 (let ((s1 (copy-seq "abc")) (s2 (copy-seq "abc"))) (let ((t1 `(member ,s1)) (t2 `(member ,s2))) (cond ((subtypep t1 t2) "T1 is subtype of T2") ((subtypep t2 t1) "T2 is subtype of T1") (t (check-disjointness t1 t2))))) nil) (deftest subtypep.member.18 (let ((s1 (copy-seq '(a b c))) (s2 (copy-seq '(a b c)))) (let ((t1 `(member ,s1)) (t2 `(member ,s2))) (cond ((subtypep t1 t2) "T1 is subtype of T2") ((subtypep t2 t1) "T2 is subtype of T1") (t (check-disjointness t1 t2))))) nil) (deftest subtypep.member.19 (let ((i1 (1+ most-positive-fixnum)) (i2 (1+ most-positive-fixnum))) (check-equivalence `(member 0 ,i1) `(member 0 ,i2))) nil) (deftest subtypep.member.20 (check-equivalence '(and (member a b c d) (member e d b f g)) '(member b d)) nil) (deftest subtypep.member.21 (check-equivalence '(and (member a b c d) (member e d f g)) '(eql d)) nil) (deftest subtypep.member.22 (check-equivalence '(and (member a b c d) (member e f g)) nil) nil) (deftest subtypep.member.23 (check-equivalence '(or (member a b c) (member z b w)) '(member z a b w c)) nil) (deftest subtypep.member.24 (check-equivalence '(or (member a b c) (eql d)) '(member d c b a)) nil) (deftest subtypep.member.25 (check-equivalence 'boolean '(member nil t)) nil) (deftest subtypep.member.26 (check-equivalence '(or (eql a) (eql b)) '(member a b)) nil) (deftest subtypep.member.27 (check-all-subtypep '(member a b c d) '(satisfies symbolp)) nil) (deftest subtypep.member.28 (check-all-subtypep '(member a b c d) t) nil) (deftest subtypep.member.29 (check-all-not-subtypep '(member a b 10 z) '(satisfies symbolp)) nil) (deftest subtypep.member.30 (check-disjointness '(member 1 6 10) '(satisfies symbolp)) nil) (deftest subtypep.member.31 (check-equivalence '(member a b c d) '(member c d b a)) nil) (deftest subtypep.member.32 (check-all-not-subtypep '(not (member a b 10 z)) '(satisfies symbolp)) nil) (deftest subtypep.member.33 (check-all-not-subtypep '(satisfies symbolp) '(member a b 10 z)) nil) (deftest subtypep.member.34 (check-all-not-subtypep '(member a b 10 z) '(not (satisfies symbolp))) nil) (deftest subtypep.member.35 (check-all-not-subtypep '(satisfies symbolp) '(member a b c d)) nil) (deftest subtypep.member.36 (check-disjointness '(eql a) '(or (member b c d) (eql e))) nil) (deftest subtypep.member.37 (check-equivalence '(and (member a b c d) (not (eql c))) '(member a b d)) nil) (deftest subtypep.member.38 (check-equivalence '(and (member a b c d e f g) (not (member b f))) '(member a c d e g)) nil) (deftest subtypep.member.39 (check-equivalence '(and (not (member b d e f g)) (not (member x y b z d))) '(not (member b d e f g x y z))) nil) (deftest subtypep.member.40 (check-equivalence '(and (not (eql a)) (not (eql b))) '(not (member a b))) nil) (deftest subtypep.member.41 (check-equivalence '(and (not (eql a)) (not (eql b)) (not (eql c))) '(not (member c b a))) nil) (deftest subtypep.member.42 (check-equivalence '(and (not (member a b)) (not (member b c))) '(not (member c b a))) nil) (deftest subtypep.member.43 (check-equivalence '(and (not (member a g b k e)) (not (member b h k c f))) '(not (member c b k a e f g h))) nil) (deftest subtypep.member.44 (check-equivalence '(and (integer 0 30) (not (member 3 4 5 9 10 11 17 18 19))) '(or (integer 0 2) (integer 6 8) (integer 12 16) (integer 20 30))) nil) gcl/ansi-tests/subtypep-rational.lsp000066400000000000000000000102711242227143400201210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 11:56:19 2003 ;;;; Contains: Tests for subtype relationships on rational types (in-package :cl-test) ;;; SUBTYPEP on rational types (deftest subtypep.rational.1 (loop for tp1 in '((rational 10) (rational 10 *) (rational 10 20) (rational (10) 20) (rational 10 (20)) (rational (10) (20)) (rational 10 1000000000000000) (rational (10)) (rational (10) *)) append (loop for tp2 in '(rational (rational) (rational *) (rational * *) (rational 10) (rational 10 *) (rational 0) (rational 0 *) (rational 19/2) (rational 19/2 *) (rational -1000000000000000) real (real) (real *) (real * *) (real 10) (real 10 *) (real 0) (real 0 *) (real 19/2) (real 19/2 *) (real -1000000000000000)) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(t t)) collect (list tp1 tp2))) nil) (deftest subtypep.rational.2 (loop for tp1 in '((rational * 10) (rational 0 10) (rational 0 (10)) (rational (0) 10) (rational (0) (10)) (rational -1000000000000000 10) (rational * (10))) append (loop for tp2 in '(rational (rational) (rational *) (rational * *) (rational * 10) (rational * 21/2) (rational * 1000000000000000) real (real) (real *) (real * *) (real * 10) (real * 21/2) (real * 1000000000000000)) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(t t)) collect (list tp1 tp2))) nil) (deftest subtypep.rational.3 (loop for tp1 in '((rational 10) (rational 10 *) (rational 10 20) (rational 10 (21)) (rational 10 1000000000000000)) append (loop for tp2 in '((rational 11) (rational 11 *) (rational (10)) (rational (10) *) (integer 10) (integer 10 *) (real 11) (real (10)) (real 11 *) (real (10) *) (rational * (20)) (rational * 19) (real * (20)) (real * 19)) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(nil t)) collect (list tp1 tp2))) nil) (deftest subtypep.rational.4 (loop for tp1 in '((rational * 10) (rational 0 10) (rational (0) 10) (rational -1000000000000000 10)) append (loop for tp2 in '((rational * 9) (rational * (10)) (integer * 10) (real * 9) (real * (10))) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(nil t)) collect (list tp1 tp2))) nil) (deftest subtypep.rational.5 (check-equivalence '(or (rational 0 0) (rational (0))) '(rational 0)) nil) (deftest subtypep.rational.6 (check-equivalence '(and (rational 0 10) (rational 5 15)) '(rational 5 10)) nil) (deftest subtypep.rational.7 (check-equivalence '(and (rational (0) 10) (rational 5 15)) '(rational 5 10)) nil) (deftest subtypep.rational.8 (check-equivalence '(and (rational 0 (10)) (rational 5 15)) '(rational 5 (10))) nil) (deftest subtypep.rational.9 (check-equivalence '(and (rational (0) (10)) (rational 5 15)) '(rational 5 (10))) nil) (deftest subtypep.rational.10 (check-equivalence '(and (rational 0 10) (rational (5) 15)) '(rational (5) 10)) nil) (deftest subtypep.rational.11 (check-equivalence '(and (rational 0 (10)) (rational (5) 15)) '(rational (5) (10))) nil) (deftest subtypep.rational.12 (check-equivalence '(and integer (rational 0 10) (not (rational (0) (10)))) '(member 0 10)) nil) (deftest subtypep.rational.13 (check-equivalence '(and integer (rational -1/2 1/2)) '(integer 0 0)) nil) (deftest subtypep.rational.14 (check-equivalence '(and integer (rational -1/2 1/2)) '(eql 0)) nil) (deftest subtypep.rational.15 (check-equivalence '(and integer (rational (-1/2) 1/2)) '(integer 0 0)) nil) (deftest subtypep.rational.16 (check-equivalence '(and integer (rational (-1/2) (1/2))) '(integer 0 0)) nil) (deftest subtypep.rational.17 (check-all-subtypep '(not (rational -1/2 1/2)) '(not (integer 0 0))) nil) (deftest subtypep.rational.18 (check-all-subtypep '(not (rational -1/2 1/2)) '(not (eql 0))) nil) gcl/ansi-tests/subtypep-real.lsp000066400000000000000000000103341242227143400172330ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Feb 18 18:38:55 2003 ;;;; Contains: Tests of SUBTYPEP on REAL types. (in-package :cl-test) ;;; SUBTYPEP on real types (deftest subtypep.real.1 (loop for tp1 in '((real 10) (real 10 *) (real 10 20) (real (10) 20) (real 10 (20)) (real (10) (20)) (real 10 1000000000000000) (real (10)) (real (10) *)) append (loop for tp2 in '(real (real) (real *) (real * *) (real 10) (real 10 *) (real 0) (real 0 *) (real 19/2) (real 19/2 *) (real 9.5) (real 9.5 *) (real -1000000000000000)) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(t t)) collect (list tp1 tp2))) nil) (deftest subtypep.real.2 (loop for tp1 in '((real * 10) (real 0 10) (real 0 (10)) (real (0) 10) (real (0) (10)) (real -1000000000000000 10) (real * (10))) append (loop for tp2 in '(real (real) (real *) (real * *) (real * 10) (real * 21/2) (real * 10.5) (real * 1000000000000000)) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(t t)) collect (list tp1 tp2))) nil) (deftest subtypep.real.3 (loop for tp1 in '((real 10) (real 10 *) (real 10 20) (real 10 (21)) (real 10 1000000000000000)) append (loop for tp2 in '((real 11) (real 11 *) (real (10)) (real (10) *) (integer 10) (integer 10 *) (real 11) (real (10)) (real 11 *) (real (10) *) (real * (20)) (real * 19) (real * (20)) (real * 19)) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(nil t)) collect (list tp1 tp2))) nil) (deftest subtypep.real.4 (loop for tp1 in '((real * 10) (real 0 10) (real (0) 10) (real -1000000000000000 10)) append (loop for tp2 in '((real * 9) (real * (10)) (integer * 10) (real * 9) (real * (10))) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(nil t)) collect (list tp1 tp2))) nil) (deftest subtypep.real.5 (check-equivalence '(or (real 0 0) (real (0))) '(real 0)) nil) (deftest subtypep.real.6 (check-equivalence '(and (real 0 10) (real 5 15)) '(real 5 10)) nil) (deftest subtypep.real.7 (check-equivalence '(and (real (0) 10) (real 5 15)) '(real 5 10)) nil) (deftest subtypep.real.8 (check-equivalence '(and (real 0 (10)) (real 5 15)) '(real 5 (10))) nil) (deftest subtypep.real.9 (check-equivalence '(and (real (0) (10)) (real 5 15)) '(real 5 (10))) nil) (deftest subtypep.real.10 (check-equivalence '(and (real 0 10) (real (5) 15)) '(real (5) 10)) nil) (deftest subtypep.real.11 (check-equivalence '(and (real 0 (10)) (real (5) 15)) '(real (5) (10))) nil) (deftest subtypep.real.12 (check-equivalence '(and integer (real 0 10) (not (real (0) (10)))) '(member 0 10)) nil) (deftest subtypep.real.13 (check-equivalence '(and integer (real -1/2 1/2)) '(integer 0 0)) nil) (deftest subtypep.real.14 (check-equivalence '(and integer (real -1/2 1/2)) '(eql 0)) nil) (deftest subtypep.real.15 (check-equivalence '(and integer (real (-1/2) 1/2)) '(integer 0 0)) nil) (deftest subtypep.real.16 (check-equivalence '(and integer (real (-1/2) (1/2))) '(integer 0 0)) nil) (deftest subtypep.real.17 (check-equivalence '(real 0 10) '(real 0.0 10.0)) nil) (deftest subtypep.real.18 (check-equivalence '(and rational (real 0 10)) '(rational 0 10)) nil) (deftest subtypep.real.19 (check-equivalence '(and rational (real 0 (10))) '(rational 0 (10))) nil) (deftest subtypep.real.20 (check-equivalence '(and rational (real (0) (10))) '(rational (0) (10))) nil) (deftest subtypep.real.21 (check-equivalence '(and rational (real 1/2 7/3)) '(rational 1/2 7/3)) nil) (deftest subtypep.real.22 (check-equivalence '(and rational (real (1/11) (8/37))) '(rational (1/11) (8/37))) nil) (deftest subtypep.real.23 (check-all-subtypep '(not (real -1/2 1/2)) '(not (integer 0 0))) nil) (deftest subtypep.real.24 (check-all-subtypep '(not (real -1/2 1/2)) '(not (eql 0))) nil) gcl/ansi-tests/subtypep.lsp000066400000000000000000000107561242227143400163220ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 29 17:28:19 2003 ;;;; Contains: Tests of SUBTYPEP (in-package :cl-test) ;;; More subtypep tests are in types-and-class.lsp (deftest subtypep.order.1 (let ((i 0) x y) (values (notnot (subtypep (progn (setf x (incf i)) t) (progn (setf y (incf i)) t))) i x y)) t 2 1 2) (deftest simple-base-string-is-sequence (subtypep* 'simple-base-string 'sequence) t t) (deftest subtype.env.1 (mapcar #'notnot (multiple-value-list (subtypep 'bit 'integer nil))) (t t)) (deftest subtype.env.2 (macrolet ((%foo (&environment env) (list 'quote (mapcar #'notnot (multiple-value-list (subtypep 'bit 'integer env)))))) (%foo)) (t t)) (deftest subtype.env.3 (macrolet ((%foo (&environment env) (multiple-value-bind (sub good) (subtypep nil (type-of env)) (or (not good) (notnot sub))))) (%foo)) t) (deftest subtype.env.4 (macrolet ((%foo (&environment env) (multiple-value-bind (sub good) (subtypep (type-of env) (type-of env)) (or (not good) (notnot sub))))) (%foo)) t) (deftest subtype.env.5 (macrolet ((%foo (&environment env) (multiple-value-bind (sub good) (subtypep (type-of env) t) (or (not good) (notnot sub))))) (%foo)) t) (deftest subtypep.error.1 (classify-error (subtypep)) program-error) (deftest subtypep.error.2 (classify-error (subtypep t)) program-error) (deftest subtypep.error.3 (classify-error (subtypep t t nil nil)) program-error) ;;; Special cases of types-6 that are/were causing problems in CMU CL (deftest keyword-is-subtype-of-atom (subtypep* 'keyword 'atom) t t) (deftest ratio-is-subtype-of-atom (subtypep* 'ratio 'atom) t t) (deftest extended-char-is-subtype-of-atom (subtypep* 'extended-char 'atom) t t) (deftest string-is-not-simple-vector (subtypep* 'string 'simple-vector) nil t) (deftest base-string-is-not-simple-vector (subtypep* 'base-string 'simple-vector) nil t) (deftest simple-string-is-not-simple-vector (subtypep* 'simple-string 'simple-vector) nil t) (deftest simple-base-string-is-not-simple-vector (subtypep* 'simple-base-string 'simple-vector) nil t) (deftest bit-vector-is-not-simple-vector (subtypep* 'bit-vector 'simple-vector) nil t) (deftest simple-bit-vector-is-not-simple-vector (subtypep* 'simple-bit-vector 'simple-vector) nil t) (deftest subtypep.extended-char.1 (if (subtypep* 'character 'base-char) (subtypep* 'extended-char nil) (values t t)) t t) (deftest subtypep.and/or.1 (check-equivalence '(and (or symbol (integer 0 15)) (or symbol (integer 10 25))) '(or symbol (integer 10 15))) nil) (deftest subtypep.and/or.2 (check-equivalence '(and (or (not symbol) (integer 0 10)) (or symbol (integer 11 25))) '(integer 11 25)) nil) (deftest subtypep.and.1 (loop for type in *types-list3* append (check-equivalence `(and ,type ,type) type)) nil) (deftest subtypep.or.1 (loop for type in *types-list3* append (check-equivalence `(or ,type ,type) type)) nil) (deftest subtypep.and.2 (check-equivalence t '(and)) nil) (deftest subtypep.or.2 (check-equivalence nil '(or)) nil) (deftest subtypep.and.3 (loop for type in *types-list3* append (check-equivalence `(and ,type) type)) nil) (deftest subtypep.or.3 (loop for type in *types-list3* append (check-equivalence `(or ,type) type)) nil) (deftest subtypep.and.4 (let* ((n (length *types-list3*)) (a (make-array n :initial-contents *types-list3*))) (trim-list (loop for i below 1000 for tp1 = (aref a (random n)) for tp2 = (aref a (random n)) append (check-equivalence `(and ,tp1 ,tp2) `(and ,tp2 ,tp1))) 100)) nil) (deftest subtypep.or.4 (let* ((n (length *types-list3*)) (a (make-array n :initial-contents *types-list3*))) (trim-list (loop for i below 1000 for tp1 = (aref a (random n)) for tp2 = (aref a (random n)) append (check-equivalence `(or ,tp1 ,tp2) `(or ,tp2 ,tp1))) 100)) nil) ;;; Check that types that are supposed to be nonempty are ;;; not subtypes of NIL (deftest subtypep.nil.1 (loop for (type) in *subtype-table* unless (member type '(nil extended-char)) append (check-all-not-subtypep type nil)) nil) (deftest subtypep.nil.2 (loop for (type) in *subtype-table* for class = (find-class type nil) unless (or (not class) (member type '(nil extended-char))) append (check-all-not-subtypep class nil)) nil) gcl/ansi-tests/svref.lsp000066400000000000000000000022321242227143400155620ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 22 21:39:30 2003 ;;;; Contains: Tests of SVREF (in-package :cl-test) (deftest svref.1 (let ((a (vector 1 2 3 4))) (loop for i below 4 collect (svref a i))) (1 2 3 4)) (deftest svref.2 (let ((a (vector 1 2 3 4))) (values (loop for i below 4 collect (setf (svref a i) (+ i 10))) a)) (10 11 12 13) #(10 11 12 13)) (deftest svref.order.1 (let ((v (vector 'a 'b 'c 'd)) (i 0) a b) (values (svref (progn (setf a (incf i)) v) (progn (setf b (incf i)) 2)) i a b)) c 2 1 2) (deftest svref.order.2 (let ((v (vector 'a 'b 'c 'd)) (i 0) a b c) (values (setf (svref (progn (setf a (incf i)) v) (progn (setf b (incf i)) 2)) (progn (setf c (incf i)) 'w)) v i a b c)) w #(a b w d) 3 1 2 3) ;;; Error tests (deftest svref.error.1 (classify-error (svref)) program-error) (deftest svref.error.2 (classify-error (svref (vector 1))) program-error) (deftest svref.error.3 (classify-error (svref (vector 1) 0 0)) program-error) (deftest svref.error.4 (classify-error (svref (vector 1) 0 nil)) program-error) gcl/ansi-tests/t.lsp000066400000000000000000000006021242227143400146770ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 06:44:45 2002 ;;;; Contains: Tests of T (in-package :cl-test) (deftest t.1 t t) (deftest t.2 (not-mv (constantp t)) nil) (deftest t.3 (eqt t 't) t) (deftest t.4 (symbol-value t) t) ;;; Tests for use of T in case forms, as a stream designator, or as a class ;;; designator will be elsewhere gcl/ansi-tests/tagbody.lsp000066400000000000000000000045041242227143400160720ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 13:27:22 2002 ;;;; Contains: Tests of TAGBODY (in-package :cl-test) (deftest tagbody.1 (tagbody) nil) (deftest tagbody.2 (tagbody 'a) nil) (deftest tagbody.3 (tagbody (values)) nil) (deftest tagbody.4 (tagbody (values 1 2 3 4 5)) nil) (deftest tagbody.5 (let ((x 0)) (values (tagbody (setq x 1) (go a) (setq x 2) a) x)) nil 1) (deftest tagbody.6 (let ((x 0)) (tagbody (setq x 1) (go a) b (setq x 2) (go c) a (setq x 3) (go b) c) x) 2) ;;; Macroexpansion occurs after tag determination (deftest tagbody.7 (let ((x 0)) (macrolet ((%m () 'a)) (tagbody (tagbody (go a) (%m) (setq x 1)) a )) x) 0) (deftest tagbody.8 (let ((x 0)) (tagbody (flet ((%f (y) (setq x y) (go a))) (%f 10)) (setq x 1) a) x) 10) ;;; Tag names are in their own name space (deftest tagbody.9 (let (result) (tagbody (flet ((a (x) x)) (setq result (a 10)) (go a)) a) result) 10) (deftest tagbody.10 (let (result) (tagbody (block a (setq result 10) (go a)) (setq result 20) a) result) 10) (deftest tagbody.11 (let (result) (tagbody (catch 'a (setq result 10) (go a)) (setq result 20) a) result) 10) (deftest tagbody.12 (let (result) (tagbody (block a (setq result 10) (return-from a nil)) (setq result 20) a) result) 20) ;;; Test that integers are accepted as go tags (deftest tagbody.13 (block done (tagbody (go around) 10 (return-from done 'good) around (go 10))) good) (deftest tagbody.14 (block done (tagbody (go around) -10 (return-from done 'good) around (go -10))) good) (deftest tagbody.15 (block done (tagbody (go around) #.(1+ most-positive-fixnum) (return-from done 'good) around (go #.(1+ most-positive-fixnum)))) good) (deftest tagbody.16 (let* ((t1 (1+ most-positive-fixnum)) (t2 (1+ most-positive-fixnum)) (form `(block done (tagbody (go around) ,t1 (return-from done 'good) around (go ,t2))))) (eval form)) good) gcl/ansi-tests/typecase.lsp000066400000000000000000000023221242227143400162520ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 22:51:25 2002 ;;;; Contains: Tests for TYPECASE (in-package :cl-test) (deftest typecase.1 (typecase 1 (integer 'a) (t 'b)) a) (deftest typecase.2 (typecase 1 (symbol 'a)) nil) (deftest typecase.3 (typecase 1 (symbol 'a) (t 'b)) b) (deftest typecase.4 (typecase 1 (t (values)))) (deftest typecase.5 (typecase 1 (integer (values)) (t 'a))) (deftest typecase.6 (typecase 1 (bit 'a) (integer 'b)) a) (deftest typecase.7 (typecase 1 (otherwise 'a)) a) (deftest typecase.8 (typecase 1 (t (values 'a 'b 'c))) a b c) (deftest typecase.9 (typecase 1 (integer (values 'a 'b 'c)) (t nil)) a b c) (deftest typecase.10 (let ((x 0)) (values (typecase 1 (bit (incf x) 'a) (integer (incf x 2) 'b) (t (incf x 4) 'c)) x)) a 1) (deftest typecase.11 (typecase 1 (otherwise 'a)) a) (deftest typecase.12 (typecase 1 (integer) (t 'a)) nil) (deftest typecase.13 (typecase 1 (symbol 'a) (t)) nil) (deftest typecase.14 (typecase 1 (symbol 'a) (otherwise)) nil) (deftest typecase.15 (typecase 'a (number 'bad) (#.(find-class 'symbol nil) 'good)) good) gcl/ansi-tests/types-and-class-2.lsp000066400000000000000000000101141242227143400176010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 5 21:20:05 2003 ;;;; Contains: More tests of types and classes (in-package :cl-test) ;;; Union of a type with its complement is universal (deftest type-or-not-type-is-everything (loop for l in *disjoint-types-list2* append (loop for type in l append (check-subtypep t `(or ,type (not ,type)) t) append (check-subtypep t `(or (not ,type) ,type) t))) nil) (defclass tac-1-class () (a b c)) (defclass tac-1a-class (tac-1-class) (d e)) (defclass tac-1b-class (tac-1-class) (f g)) (deftest user-class-disjointness (loop for l in *disjoint-types-list2* append (loop for type in l append (classes-are-disjoint type 'tac-1-class))) nil) (deftest user-class-disjointness-2 (check-disjointness 'tac-1a-class 'tac-1b-class) nil) (defstruct tac-2-struct a b c) (defstruct (tac-2a-struct (:include tac-2-struct)) d e) (defstruct (tac-2b-struct (:include tac-2-struct)) f g) (deftest user-struct-disjointness (loop for l in *disjoint-types-list2* append (loop for type in l append (check-disjointness type 'tac-2-struct))) nil) (deftest user-struct-disjointness-2 (check-disjointness 'tac-2a-struct 'tac-2b-struct) nil) (defclass tac-3-a () (x)) (defclass tac-3-b () (y)) (defclass tac-3-c () (z)) (defclass tac-3-ab (tac-3-a tac-3-b) ()) (defclass tac-3-ac (tac-3-a tac-3-c) ()) (defclass tac-3-bc (tac-3-b tac-3-c) ()) (defclass tac-3-abc (tac-3-ab tac-3-ac tac-3-bc) ()) (deftest tac-3.1 (subtypep* 'tac-3-ab 'tac-3-a) t t) (deftest tac-3.2 (subtypep* 'tac-3-ab 'tac-3-b) t t) (deftest tac-3.3 (subtypep* 'tac-3-ab 'tac-3-c) nil t) (deftest tac-3.4 (subtypep* 'tac-3-a 'tac-3-ab) nil t) (deftest tac-3.5 (subtypep* 'tac-3-b 'tac-3-ab) nil t) (deftest tac-3.6 (subtypep* 'tac-3-c 'tac-3-ab) nil t) (deftest tac-3.7 (subtypep* 'tac-3-abc 'tac-3-a) t t) (deftest tac-3.8 (subtypep* 'tac-3-abc 'tac-3-b) t t) (deftest tac-3.9 (subtypep* 'tac-3-abc 'tac-3-c) t t) (deftest tac-3.10 (subtypep* 'tac-3-abc 'tac-3-ab) t t) (deftest tac-3.11 (subtypep* 'tac-3-abc 'tac-3-ac) t t) (deftest tac-3.12 (subtypep* 'tac-3-abc 'tac-3-bc) t t) (deftest tac-3.13 (subtypep* 'tac-3-ab 'tac-3-abc) nil t) (deftest tac-3.14 (subtypep* 'tac-3-ac 'tac-3-abc) nil t) (deftest tac-3.15 (subtypep* 'tac-3-bc 'tac-3-abc) nil t) (deftest tac-3.16 (check-equivalence '(and tac-3-a tac-3-b) 'tac-3-ab) nil) (deftest tac-3.17 (check-equivalence '(and (or tac-3-a tac-3-b) (or (not tac-3-a) (not tac-3-b)) (or tac-3-a tac-3-c) (or (not tac-3-a) (not tac-3-c)) (or tac-3-b tac-3-c) (or (not tac-3-b) (not tac-3-c))) nil) nil) ;;; ;;; Check that disjointness of types in *disjoint-types-list* ;;; is respected by all the elements of *universe* ;;; (deftest universe-elements-in-at-most-one-disjoint-type (loop for e in *universe* for types = (remove-if-not #'(lambda (x) (typep e x)) *disjoint-types-list*) when (> (length types) 1) collect (list e types)) nil) ;;;;; (deftest integer-and-ratio-are-disjoint (classes-are-disjoint 'integer 'ratio) nil) (deftest bignum-and-ratio-are-disjoint (classes-are-disjoint 'bignum 'ratio) nil) (deftest bignum-and-fixnum-are-disjoint (classes-are-disjoint 'bignum 'fixnum) nil) (deftest fixnum-and-ratio-are-disjoint (classes-are-disjoint 'fixnum 'ratio) nil) (deftest byte8-and-ratio-are-disjoint (classes-are-disjoint '(unsigned-byte 8) 'ratio) nil) (deftest bit-and-ratio-are-disjoint (classes-are-disjoint 'bit 'ratio) nil) (deftest integer-and-float-are-disjoint (classes-are-disjoint 'integer 'float) nil) (deftest ratio-and-float-are-disjoint (classes-are-disjoint 'ratio 'float) nil) (deftest complex-and-float-are-disjoint (classes-are-disjoint 'complex 'float) nil) (deftest integer-subranges-are-disjoint (classes-are-disjoint '(integer 0 (10)) '(integer 10 (20))) nil) (deftest keyword-and-null-are-disjoint (classes-are-disjoint 'keyword 'null) nil) (deftest keyword-and-boolean-are-disjoint (classes-are-disjoint 'keyword 'boolean) nil) gcl/ansi-tests/types-and-class.lsp000066400000000000000000000234571242227143400174600ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Mar 19 21:48:39 1998 ;;;; Contains: Data for testing type and class inclusions ;; We should check for every type that NIL is a subtype, and T a supertype (in-package :cl-test) (declaim (optimize (safety 3))) (deftest boolean-type.1 (notnot-mv (typep nil 'boolean)) t) (deftest boolean-type.2 (notnot-mv (typep t 'boolean)) t) (deftest boolean-type.3 (check-type-predicate 'is-t-or-nil 'boolean) 0) ;; Two type inclusions on booleans ;; have been conditionalized to prevent ;; some tests from doing too badly on CMU CL on x86 ;; These should get removed when I get a more up to date ;; image for that platform -- pfd (deftest types.3 (loop for (t1 t2) in *subtype-table* for m1 = (check-subtypep t1 t2 t t) for m2 = (check-subtypep `(and ,t1 ,t2) t1 t) for m3 = (check-subtypep `(and ,t2 ,t1) t1 t) for m4 = (check-subtypep `(and ,t1 (not ,t2)) nil t) for m5 = (check-subtypep `(and (not ,t2) ,t1) nil t) when m1 collect m1 when m2 collect m2 when m3 collect m3 when m4 collect m4 when m5 collect m5) nil) (declaim (special +float-types+ *subtype-table*)) ;;; This next test is all screwed up. Basically, it assumes ;;; incorrectly that certain subtype relationships that are ;;; not specified in the spec cannot occur. #| (defun types.4-body () (let ((parent-table (make-hash-table :test #'equal)) (types nil)) (loop for p in *subtype-table* do (let ((tp (first p)) (parent (second p))) (pushnew tp types) (pushnew parent types) (let ((parents (gethash tp parent-table))) (pushnew parent parents) ;; (format t "~S ==> ~S~%" tp parent) (loop for pp in (gethash parent parent-table) do ;; (format t "~S ==> ~S~%" tp pp) (pushnew pp parents)) (setf (gethash tp parent-table) parents)))) ;; parent-table now contains lists of ancestors (loop for tp in types sum (let ((parents (gethash tp parent-table))) (loop for tp2 in types sum (cond ((and (not (eqt tp tp2)) (not (eqt tp2 'standard-object)) (not (eqt tp2 'structure-object)) (not (member tp2 parents)) (subtypep* tp tp2) (not (and (member tp +float-types+) (member tp2 +float-types+))) (not (and (eqt tp2 'structure-object) (member 'standard-object parents)))) (format t "~%Improper subtype: ~S of ~S" tp tp2) 1) (t 0))))) )) (deftest types.4 (types.4-body) 0) |# (deftest types.6 (types.6-body) nil) (declaim (special *disjoint-types-list*)) ;;; Check that the disjoint types really are disjoint (deftest types.7b (loop for e on *disjoint-types-list* for tp1 = (first e) append (loop for tp2 in (rest e) append (classes-are-disjoint tp1 tp2))) nil) (deftest types.7c (loop for e on *disjoint-types-list2* for list1 = (first e) append (loop for tp1 in list1 append (loop for list2 in (rest e) append (loop for tp2 in list2 append (classes-are-disjoint tp1 tp2))))) nil) (deftest types.8 (loop for tp in *disjoint-types-list* count (cond ((and (not (eqt tp 'cons)) (not (subtypep* tp 'atom))) (format t "~%Should be atomic, but isn't: ~S" tp) t))) 0) (declaim (special *type-list* *supertype-table*)) ;;; ;;; TYPES.9 checks the transitivity of SUBTYPEP on pairs of types ;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM, ;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used ;;; here.) ;;; (deftest types.9 (types.9-body) nil) ;;; ;;; TYPES.9A takes the supertype relationship computed by test TYPE.9 ;;; and checks that TYPEP respects it for all elements of *UNIVERSE*. ;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*, ;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2). ;;; ;;; The function prints error messages when this fails, and returns the ;;; number of occurences of failure. ;;; ;;; Test TYPES.9 must be run before this test. ;;; (deftest types.9a (types.9a-body) 0) ;;; All class names in CL denote classes that are subtypep ;;; equivalent to themselves (deftest all-classes-are-type-equivalent-to-their-names (loop for sym being the external-symbols of "COMMON-LISP" for class = (find-class sym nil) when class append (check-equivalence sym class)) nil) ;;; Check that all class names in CL that name standard-classes or ;;; structure-classes are subtypes of standard-object and structure-object, ;;; respectively (deftest all-standard-classes-are-subtypes-of-standard-object (loop for sym being the external-symbols of "COMMON-LISP" for class = (find-class sym nil) when (and class (typep class 'standard-class) (or (not (subtypep sym 'standard-object)) (not (subtypep class 'standard-object)))) collect sym) nil) (deftest all-structure-classes-are-subtypes-of-structure-object (loop for sym being the external-symbols of "COMMON-LISP" for class = (find-class sym nil) when (and class (typep class 'structure-class) (or (not (subtypep sym 'structure-object)) (not (subtypep class 'structure-object)))) collect sym) nil) ;;; Confirm that only the symbols exported from CL that are supposed ;;; to be types are actually classes (see section 11.1.2.1.1) (deftest all-exported-cl-class-names-are-valid (loop for sym being the external-symbols of "COMMON-LISP" when (and (find-class sym nil) (not (member sym *cl-all-type-symbols* :test #'eq))) collect sym) nil) ;;; Confirm that all standard generic functions are instances of ;;; the class standard-generic-function. (deftest all-standard-generic-functions-are-instances-of-that-class (loop for sym in *cl-standard-generic-function-symbols* for fun = (and (fboundp sym) (symbol-function sym)) unless (and (typep fun 'generic-function) (typep fun 'standard-generic-function)) collect (list sym fun)) nil) ;;; Canonical metaobjects are in the right classes (deftest structure-object-is-in-structure-class (notnot-mv (typep (find-class 'structure-object) 'structure-class)) t) (deftest standard-object-is-in-standard-class (notnot-mv (typep (find-class 'standard-object) 'standard-class)) t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; deftype (deftype even-array (&optional type size) `(and (array ,type ,size) (satisfies even-size-p))) (deftest deftype.1 (typep 1 '(even-array integer (10))) nil) (deftest deftype.2 (typep nil '(even-array t (*))) nil) (deftest deftype.3 (notnot-mv (typep (make-array '(10)) '(even-array t (*)))) t) (deftest deftype.4 (typep (make-array '(5)) '(even-array t (*))) nil) (deftest deftype.5 (notnot-mv (typep (make-string 10) '(even-array character (*)))) t) (deftest deftype.6 (notnot-mv (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8)) '(even-array (unsigned-byte 8)))) t) ;; This should be greatly expanded (defparameter *type-and-class-fns* '(coerce subtypep type-of typep type-error-datum type-error-expected-type)) (deftest type-and-class-fns (remove-if #'fboundp *type-and-class-fns*) nil) (deftest type-and-class-macros (notnot-mv (macro-function 'deftype)) t) (deftest typep-nil-null (notnot-mv (typep nil 'null)) t) (deftest typep-t-null (typep t 'null) nil) ;;; Error checking of type-related functions (deftest type-of.error.1 (classify-error (type-of)) program-error) (deftest type-of.error.2 (classify-error (type-of nil nil)) program-error) (deftest typep.error.1 (classify-error (typep)) program-error) (deftest typep.error.2 (classify-error (typep nil)) program-error) (deftest typep.error.3 (classify-error (typep nil t nil nil)) program-error) (deftest type-error-datum.error.1 (classify-error (type-error-datum)) program-error) (deftest type-error-datum.error.2 (classify-error (let ((c (make-condition 'type-error :datum nil :expected-type t))) (type-error-datum c nil))) program-error) (deftest type-error-expected-type.error.1 (classify-error (type-error-expected-type)) program-error) (deftest type-error-expected-type.error.2 (classify-error (let ((c (make-condition 'type-error :datum nil :expected-type t))) (type-error-expected-type c nil))) program-error) ;;; Tests of env arguments to typep (deftest typep.env.1 (notnot-mv (typep 0 'bit nil)) t) (deftest typep.env.2 (macrolet ((%foo (&environment env) (notnot-mv (typep 0 'bit env)))) (%foo)) t) (deftest typep.env.3 (macrolet ((%foo (&environment env) (notnot-mv (typep env (type-of env))))) (%foo)) t) ;;; Other typep tests (deftest typep.1 (notnot-mv (typep 'a '(eql a))) t) (deftest typep.2 (notnot-mv (typep 'a '(and (eql a)))) t) (deftest typep.3 (notnot-mv (typep 'a '(or (eql a)))) t) (deftest typep.4 (typep 'a '(eql b)) nil) (deftest typep.5 (typep 'a '(and (eql b))) nil) (deftest typep.6 (typep 'a '(or (eql b))) nil) (deftest typep.7 (notnot-mv (typep 'a '(satisfies symbolp))) t) (deftest typep.8 (typep 10 '(satisfies symbolp)) nil) (deftest typep.9 (let ((class (find-class 'symbol))) (notnot-mv (typep 'a class))) t) (deftest typep.10 (let ((class (find-class 'symbol))) (notnot-mv (typep 'a `(and ,class)))) t) (deftest typep.11 (let ((class (find-class 'symbol))) (typep 10 class)) nil) (deftest typep.12 (let ((class (find-class 'symbol))) (typep 10 `(and ,class))) nil) (deftest typep.13 (typep 'a '(and symbol integer)) nil) (deftest typep.14 (notnot-mv (typep 'a '(or symbol integer))) t) (deftest typep.15 (notnot-mv (typep 'a '(or integer symbol))) t) (deftest typep.16 (let ((c1 (find-class 'number)) (c2 (find-class 'symbol))) (notnot-mv (typep 'a `(or ,c1 ,c2)))) t) (deftest typep.17 (let ((c1 (find-class 'number)) (c2 (find-class 'symbol))) (notnot-mv (typep 'a `(or ,c2 ,c1)))) t) gcl/ansi-tests/universe.lsp000066400000000000000000000240371242227143400163040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Apr 9 19:32:56 1998 ;;;; Contains: A global variable containing a list of ;;;; as many kinds of CL objects as we can think of ;;;; This list is used to test many other CL functions (in-package :cl-test) (defvar *condition-types* '(arithmetic-error cell-error condition control-error division-by-zero end-of-file error file-error floating-point-inexact floating-point-invalid-operation floating-point-underflow floating-point-overflow package-error parse-error print-not-readable program-error reader-error serious-condition simple-condition simple-error simple-type-error simple-warning storage-condition stream-error style-warning type-error unbound-slot unbound-variable undefined-function warning)) (defvar *condition-objects* (loop for tp in *condition-types* append (handler-case (list (make-condition tp)) (error () nil)))) (defvar *standard-package-names* '("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD")) (defvar *package-objects* (loop for pname in *standard-package-names* append (handler-case (let ((pkg (find-package pname))) (and pkg (list pkg))) (error () nil)))) (defvar *integers* (remove-duplicates `( 0 ;; Integers near the fixnum/bignum boundaries ,@(loop for i from -5 to 5 collect (+ i most-positive-fixnum)) ,@(loop for i from -5 to 5 collect (+ i most-negative-fixnum)) ;; Powers of two, negatives, and off by one. ,@(loop for i from 1 to 64 collect (ash 1 i)) ,@(loop for i from 1 to 64 collect (1- (ash 1 i))) ,@(loop for i from 1 to 64 collect (ash -1 i)) ,@(loop for i from 1 to 64 collect (1+ (ash -1 i))) ;; A big integer ,(expt 17 50) ;; Some arbitrarily chosen integers 12387131 1272314 231 -131 -561823 23713 -1234611312123 444121 991))) (defvar *floats* (append (loop for sym in '(pi most-positive-short-float least-positive-short-float least-positive-normalized-short-float most-positive-double-float least-positive-double-float least-positive-normalized-double-float most-positive-long-float least-positive-long-float least-positive-normalized-long-float most-positive-single-float least-positive-single-float least-positive-normalized-single-float most-negative-short-float least-negative-short-float least-negative-normalized-short-float most-negative-single-float least-negative-single-float least-negative-normalized-single-float most-negative-double-float least-negative-double-float least-negative-normalized-double-float most-negative-long-float least-negative-long-float least-negative-normalized-long-float short-float-epsilon short-float-negative-epsilon single-float-epsilon single-float-negative-epsilon double-float-epsilon double-float-negative-epsilon long-float-epsilon long-float-negative-epsilon) when (boundp sym) collect (symbol-value sym)) (list 0.0 1.0 -1.0 313123.13 283143.231 -314781.9 1.31283d2 834.13812D-45 8131238.1E14 -4618926.231e-2 -37818.131F3 81.318231f-19 1.31273s3 12361.12S-7 6124.124l0 13123.1L-23))) (defvar *ratios* '(1/3 1/1000 1/1000000000000000 -10/3 -1000/7 -987129387912381/13612986912361 189729874978126783786123/1234678123487612347896123467851234671234)) (defvar *complexes* '(#C(0.0 0.0) #C(1.0 0.0) #C(0.0 1.0) #C(1.0 1.0) #C(-1.0 -1.0) #C(1289713.12312 -9.12681271) #C(1.0D100 1.0D100) #C(-1.0D-100 -1.0D-100))) (defvar *numbers* (append *integers* *floats* *ratios* *complexes*)) (defun try-to-read-chars (&rest namelist) (loop for name in namelist append (handler-case (list (read-from-string (concatenate 'string "\#\\" name))) (error () nil)))) (defvar *characters* (remove-duplicates `(#\Newline #\Space ,@(try-to-read-chars "Rubout" "Page" "Tab" "Backspace" "Return" "Linefeed" "Null") #\a #\A #\0 #\9 #\. #\( #\) #\[ #\] ))) (defvar *strings* (append (and (code-char 0) (list (make-string 1 :initial-element (code-char 0)) (make-string 10 :initial-element (code-char 0)))) (list "" "A" "a" "0" "abcdef" "~!@#$%^&*()_+`1234567890-=<,>.?/:;\"'{[}]|\\ abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWYXZ" (make-string 100000 :initial-element #\g) (let ((s (make-string 256))) (loop for i from 0 to 255 do (let ((c (code-char i))) (when c (setf (elt s i) c)))) s) ))) (defvar *conses* (list (list 'a 'b) (list nil) (list 1 2 3 4 5 6))) (defvar *circular-conses* (list (let ((s (copy-list '(a b c d)))) (nconc s s) s) (let ((s (list nil))) (setf (car s) s) s) (let ((s (list nil))) (setf (car s) s) (setf (cdr s) s)))) (defvar *booleans* '(nil t)) (defvar *keywords* '(:a :b :|| :|a| :|1234|)) (defvar *uninterned-symbols* (list '#:nil '#:t '#:foo '#:||)) (defvar *cl-test-symbols* `(,(intern "a" :cl-test) ,(intern "" :cl-test) ,@(and (code-char 0) (list (intern (make-string 1 :initial-element (code-char 0)) :cl-test))) ,@(and (code-char 0) (let* ((s (make-string 10 :initial-element (code-char 0))) (s2 (copy-seq s)) (s3 (copy-seq s))) (setf (subseq s 3 4) "a") (setf (subseq s2 4 5) "a") (setf (subseq s3 4 5) "a") (setf (subseq s3 7 8) "b") (list (intern s :cl-test) (intern s2 :cl-test) (intern s3 :cl-test)))) )) (defvar *cl-user-symbols* '(cl-user::foo cl-user::x cl-user::cons cl-user::lambda cl-user::*print-readably* cl-user::push)) (defvar *symbols* (append *booleans* *keywords* *uninterned-symbols* *cl-test-symbols* *cl-user-symbols*)) (defvar *array-dimensions* (loop for i from 0 to 8 collect (loop for j from 1 to i collect 2))) (defvar *default-array-target* (make-array '(300))) (defvar *arrays* (append (list (make-array '10)) (mapcar #'make-array *array-dimensions*) ;; typed arrays (loop for tp in '(fixnum float bit character base-char (signed-byte 8) (unsigned-byte 8)) append (loop for d in *array-dimensions* collect (make-array d :element-type tp))) ;; adjustable arrays (loop for d in *array-dimensions* collect (make-array d :adjustable t)) ;; Displaced arrays (loop for d in *array-dimensions* for i from 1 collect (make-array d :displaced-to *default-array-target* :displaced-index-offset i)) (list #() #* #*00000 #*1010101010101101) ;; Integer arrays (list (make-array '(10) :element-type '(integer 0 (256)) :initial-contents '(8 9 10 11 12 1 2 3 4 5)) (make-array '(10) :element-type '(integer -128 (128)) :initial-contents '(8 9 -10 11 -12 1 -2 -3 4 5)) (make-array '(6) :element-type '(integer 0 (#.(ash 1 16))) :initial-contents '(5 9 100 1312 23432 87)) (make-array '(4) :element-type '(integer 0 (#.(ash 1 28))) :initial-contents '(100000 231213 8123712 19)) (make-array '(4) :element-type '(integer 0 (#.(ash 1 32))) :initial-contents '(#.(1- (ash 1 32)) 0 872312 10000000)) (make-array nil :element-type '(integer 0 (256)) :initial-element 14) (make-array '(2 2) :element-type '(integer 0 (256)) :initial-contents '((34 98)(14 119))) ) ;; Float arrays (list (make-array '(5) :element-type 'short-float :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) (make-array '(5) :element-type 'single-float :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) (make-array '(5) :element-type 'double-float :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) (make-array '(5) :element-type 'long-float :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) ) ;; more kinds of arrays here later )) (defvar *hash-tables* (list (make-hash-table) (make-hash-table :test #'eq) (make-hash-table :test #'eql) (make-hash-table :test #'equal) #-(or GCL CMU ECL) (make-hash-table :test #'equalp) )) (defvar *pathnames* (list (make-pathname :name "foo") (make-pathname :name "bar") (make-pathname :name "foo" :type "txt") (make-pathname :name "bar" :type "txt") (make-pathname :name :wild) (make-pathname :name :wild :type "txt") )) (defvar *streams* (remove-duplicates (remove-if #'null (list *debug-io* *error-output* *query-io* *standard-input* *standard-output* *terminal-io* *trace-output*)))) (defvar *readtables* (list *readtable* (copy-readtable))) (defstruct foo-structure x y z) (defstruct bar-structure x y z) (defvar *structures* (list (make-foo-structure :x 1 :y 'a :z nil) (make-foo-structure :x 1 :y 'a :z nil) (make-bar-structure :x 1 :y 'a :z nil) )) (defvar *functions* (list #'cons #'car #'append #'values (macro-function 'cond) #'(lambda (x) x))) (defvar *random-states* (list (make-random-state))) (defvar *universe* (remove-duplicates (append *symbols* *numbers* *characters* (mapcar #'copy-seq *strings*) *conses* *condition-objects* *package-objects* *arrays* *hash-tables* *pathnames* *streams* *readtables* *structures* *functions* *random-states* nil))) (defvar *mini-universe* (remove-duplicates (mapcar #'first (list *symbols* *numbers* *characters* (mapcar #'copy-seq *strings*) *conses* *condition-objects* *package-objects* *arrays* *hash-tables* *pathnames* *streams* *readtables* *structures* *functions* *random-states*)))) gcl/ansi-tests/unless.lsp000066400000000000000000000013011242227143400157420ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 19:39:34 2002 ;;;; Contains: Tests of UNLESS (in-package :cl-test) (deftest unless.1 (unless t) nil) (deftest unless.2 (unless nil) nil) (deftest unless.3 (unless 'b 'a) nil) (deftest unless.4 (unless nil 'a) a) (deftest unless.5 (unless nil (values))) (deftest unless.6 (unless nil (values 1 2 3 4)) 1 2 3 4) (deftest unless.7 (unless 1 (values)) nil) (deftest unless.8 (unless #() (values 1 2 3 4)) nil) (deftest unless.9 (let ((x 0)) (values (unless nil (incf x) 'a) x)) a 1) ;;; (deftest unless.error.1 ;;; (classify-error (unless)) ;;; program-error) gcl/ansi-tests/unwind-protect.lsp000066400000000000000000000032241242227143400174210ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 14:41:16 2002 ;;;; Contains: Tests of UNWIND-PROTECT (in-package :cl-test) (deftest unwind-protect.1 (let ((x nil)) (unwind-protect (push 1 x) (incf (car x)))) (2)) (deftest unwind-protect.2 (let ((x nil)) (block foo (unwind-protect (progn (push 1 x) (return-from foo x)) (incf (car x))))) (2)) (deftest unwind-protect.3 (let ((x nil)) (tagbody (unwind-protect (progn (push 1 x) (go done)) (incf (car x))) done) x) (2)) (deftest unwind-protect.4 (let ((x nil)) (catch 'done (unwind-protect (progn (push 1 x) (throw 'done x)) (incf (car x))))) (2)) (deftest unwind-protect.5 (let ((x nil)) (ignore-errors (unwind-protect (progn (push 1 x) (error "Boo!")) (incf (car x)))) x) (2)) (deftest unwind-protect.6 (let ((x nil)) (block done (flet ((%f () (return-from done nil))) (unwind-protect (%f) (push 'a x)))) x) (a)) (deftest unwind-protect.7 (let ((x nil)) (block done (flet ((%f () (return-from done nil))) (unwind-protect (unwind-protect (%f) (push 'b x)) (push 'a x)))) x) (a b)) (deftest unwind-protect.8 (let ((x nil)) (block done (unwind-protect (flet ((%f () (return-from done nil))) (unwind-protect (unwind-protect (%f) (push 'b x)) (push 'a x))) (push 'c x))) x) (c a b)) (deftest unwind-protect.9 (let ((x nil)) (handler-case (flet ((%f () (error 'type-error :datum 'foo :expected-type nil))) (unwind-protect (handler-case (%f)) (push 'a x))) (type-error () x))) (a)) gcl/ansi-tests/upgraded-array-element-type.lsp000066400000000000000000000056671242227143400217710ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 22 20:43:55 2003 ;;;; Contains: Tests of UPGRADED-ARRAY-ELEMENT-TYPE (in-package :cl-test) (deftest upgraded-array-element-type.1 (let ((upgraded-bit (upgraded-array-element-type 'bit))) (and (empirical-subtypep 'bit upgraded-bit) (empirical-subtypep upgraded-bit 'bit))) t) (deftest upgraded-array-element-type.2 (let ((upgraded-base-char (upgraded-array-element-type 'base-char))) (and (empirical-subtypep 'base-char upgraded-base-char) (empirical-subtypep upgraded-base-char 'base-char))) t) (deftest upgraded-array-element-type.3 (let ((upgraded-character (upgraded-array-element-type 'character))) (and (empirical-subtypep 'character upgraded-character) (empirical-subtypep upgraded-character 'character))) t) (defparameter *upgraded-array-types-to-check* `(boolean base-char character t ,@(loop for i from 0 to 32 collect `(integer 0 (,(ash 1 i)))) symbol ,@(loop for i from 0 to 32 collect `(integer ,(- (ash 1 i)) (,(ash 1 i)))) (integer -10000000000000000000000000000000000 10000000000000000000000000000000000) float short-float single-float double-float complex rational fixnum function sequence list cons atom symbol)) (deftest upgraded-array-element-type.4 (loop for type in *upgraded-array-types-to-check* for upgraded-type = (upgraded-array-element-type type) always (empirical-subtypep type upgraded-type)) t) ;; Include an environment (NIL, denoting the default null lexical ;; environment) (deftest upgraded-array-element-type.5 (loop for type in *upgraded-array-types-to-check* for upgraded-type = (upgraded-array-element-type type nil) always (empirical-subtypep type upgraded-type)) t) (deftest upgraded-array-element-type.6 (macrolet ((%foo (&environment env) (empirical-subtypep 'bit (upgraded-array-element-type 'bit env)))) (%foo)) t) (deftest upgraded-array-element-type.7 (let ((upgraded-types (mapcar #'upgraded-array-element-type *upgraded-array-types-to-check*))) (loop for type in *upgraded-array-types-to-check* for upgraded-type in upgraded-types append (loop for type2 in *upgraded-array-types-to-check* for upgraded-type2 in upgraded-types when (and (subtypep type type2) (equal (subtypep* upgraded-type upgraded-type) '(nil t))) collect (list type type2)))) nil) ;;; Tests of upgrading NIL (it should be type equivalent to NIL) (deftest upgraded-array-element-type.nil.1 (let ((uaet-nil (upgraded-array-element-type nil))) (loop for e in *universe* when (typep e uaet-nil) collect e)) nil) ;;; Error tests (deftest upgraded-array-element-type.error.1 (classify-error (upgraded-array-element-type)) program-error) (deftest upgraded-array-element-type.error.2 (classify-error (upgraded-array-element-type 'bit nil nil)) program-error) gcl/ansi-tests/values-list.lsp000066400000000000000000000014121242227143400167040ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 16:53:39 2003 ;;;; Contains: Tests for VALUES-LIST (in-package :cl-test) (deftest values-list.error.1 (classify-error (values-list)) program-error) (deftest values-list.error.2 (classify-error (values-list nil nil)) program-error) (deftest values-list.1 (values-list nil)) (deftest values-list.2 (values-list '(1)) 1) (deftest values-list.3 (values-list '(1 2)) 1 2) (deftest values-list.4 (values-list '(a b c d e f g h i j)) a b c d e f g h i j) (deftest values-list.5 (let ((x (loop for i from 1 to (min 1000 (1- call-arguments-limit) (1- multiple-values-limit)) collect i))) (equalt x (multiple-value-list (values-list x)))) t) gcl/ansi-tests/values.lsp000066400000000000000000000023001242227143400157300ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 08:18:50 2002 ;;;; Contains: Tests of VALUES (in-package :cl-test) (deftest values.0 (values)) (deftest values.1 (values 1) 1) (deftest values.2 (values 1 2) 1 2) (deftest values.3 (values 1 2 3) 1 2 3) (deftest values.4 (values 1 2 3 4) 1 2 3 4) (deftest values.10 (values 1 2 3 4 5 6 7 8 9 10) 1 2 3 4 5 6 7 8 9 10) (deftest values.15 (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) (deftest values.19 (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) (deftest values.A (values (values 1 2) (values 3 4 5) (values) (values 10)) 1 3 nil 10) (deftest values.B (funcall #'values 1 2 3 4) 1 2 3 4) (deftest values.C (let ((x (loop for i from 1 to (min 1000 (1- call-arguments-limit) (1- multiple-values-limit)) collect i))) (equalt x (multiple-value-list (apply #'values x)))) t) (deftest values.order.1 (let ((i 0) a b c) (values (multiple-value-list (values (setf a (incf i)) (setf b (incf i)) (setf c (incf i)))) i a b c)) (1 2 3) 3 1 2 3) gcl/ansi-tests/vector-pop.lsp000066400000000000000000000017641242227143400165440ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jan 24 07:46:29 2003 ;;;; Contains: Tests for VECTOR-POP (in-package :cl-test) (deftest vector-pop.1 (let ((v (make-array '(5) :initial-contents '(a b c d e) :fill-pointer 3))) (values (length v) (check-values (vector-pop v)) (fill-pointer v) (length v) v)) 3 c 2 2 #(a b)) ;;; Error cases (deftest vector-pop.error.1 (classify-error (vector-pop (vector 1 2 3))) type-error) (deftest vector-pop.error.2 (let ((v (make-array '(5) :initial-element 'x :fill-pointer 0))) (handler-case (vector-pop v) (error () 'error))) error) (deftest vector-pop.error.3 (classify-error (vector-pop)) program-error) (deftest vector-pop.error.4 (classify-error (let ((v (make-array '(5) :fill-pointer t :initial-element 'x))) (vector-pop v nil))) program-error) (deftest vector-pop.error.5 (classify-error (locally (vector-pop (vector 1 2 3)) t)) type-error) gcl/ansi-tests/vector-push-extend.lsp000066400000000000000000000220141242227143400202010ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 25 08:04:35 2003 ;;;; Contains: Tests for VECTOR-PUSH-EXTEND (in-package :cl-test) (deftest vector-push-extend.1 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(a b c d e))) (i 0) x y) (values (fill-pointer a) (vector-push-extend (progn (setf x (incf i)) 'x) (progn (setf y (incf i)) a)) (fill-pointer a) a i x y)) 2 2 3 #(a b x) 2 1 2) (deftest vector-push-extend.2 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(a b c d e)))) (values (fill-pointer a) (vector-push-extend 'x a) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(a b c d e x)) (deftest vector-push-extend.3 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents "abcde" :element-type 'base-char))) (values (fill-pointer a) (vector-push-extend #\x a) (fill-pointer a) a)) 2 2 3 "abx") (deftest vector-push-extend.4 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents "abcde" :element-type 'base-char)) (i 0) x y z) (values (fill-pointer a) (vector-push-extend (progn (setf x (incf i)) #\x) (progn (setf y (incf i)) a) (progn (setf z (incf i)) 1)) (fill-pointer a) (<= (array-total-size a) 5) a i x y z)) 5 5 6 nil "abcdex" 3 1 2 3) (deftest vector-push-extend.5 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents "abcde" :element-type 'character))) (values (fill-pointer a) (vector-push-extend #\x a) (fill-pointer a) a)) 2 2 3 "abx") (deftest vector-push-extend.6 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents "abcde" :element-type 'character))) (values (fill-pointer a) (vector-push-extend #\x a 10) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil "abcdex") (deftest vector-push-extend.7 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(0 1 1 0 0) :element-type 'bit))) (values (fill-pointer a) (vector-push-extend 0 a) (fill-pointer a) a)) 2 2 3 #*010) (deftest vector-push-extend.8 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(0 0 0 0 0) :element-type 'bit))) (values (fill-pointer a) (vector-push-extend 1 a 100) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #*000001) (deftest vector-push-extend.9 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1 2 3 4 5) :element-type 'fixnum))) (values (fill-pointer a) (vector-push-extend 0 a) (fill-pointer a) a)) 2 2 3 #(1 2 0)) (deftest vector-push-extend.10 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(1 2 3 4 5) :element-type 'fixnum))) (values (fill-pointer a) (vector-push-extend 0 a 1) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(1 2 3 4 5 0)) (deftest vector-push-extend.11 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1 2 3 4 5) :element-type '(integer 0 (256))))) (values (fill-pointer a) (vector-push-extend 0 a) (fill-pointer a) a)) 2 2 3 #(1 2 0)) (deftest vector-push-extend.12 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(1 2 3 4 5) :element-type '(integer 0 (256))))) (values (fill-pointer a) (vector-push-extend 0 a 1) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(1 2 3 4 5 0)) (deftest vector-push-extend.13 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) :element-type 'short-float))) (values (fill-pointer a) (vector-push-extend 0.0s0 a) (fill-pointer a) a)) 2 2 3 #(1.0s0 2.0s0 0.0s0)) (deftest vector-push-extend.14 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) :element-type 'short-float))) (values (fill-pointer a) (vector-push-extend 0.0s0 a 1) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0 0.0s0)) (deftest vector-push-extend.15 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) :element-type 'single-float))) (values (fill-pointer a) (vector-push-extend 0.0f0 a) (fill-pointer a) a)) 2 2 3 #(1.0f0 2.0f0 0.0f0)) (deftest vector-push-extend.16 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) :element-type 'single-float))) (values (fill-pointer a) (vector-push-extend 0.0f0 a 1) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0 0.0f0)) (deftest vector-push-extend.17 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) :element-type 'double-float))) (values (fill-pointer a) (vector-push-extend 0.0d0 a) (fill-pointer a) a)) 2 2 3 #(1.0d0 2.0d0 0.0d0)) (deftest vector-push-extend.18 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) :element-type 'double-float))) (values (fill-pointer a) (vector-push-extend 0.0d0 a 1) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0 0.0d0)) (deftest vector-push-extend.19 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) :element-type 'long-float))) (values (fill-pointer a) (vector-push-extend 0.0l0 a) (fill-pointer a) a)) 2 2 3 #(1.0l0 2.0l0 0.0l0)) (deftest vector-push-extend.20 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) :element-type 'long-float))) (values (fill-pointer a) (vector-push-extend 0.0l0 a 1) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0 0.0l0)) ;;; Error tests (defun vector-push-extend-error-test (seq val) (declare (optimize (safety 3))) (handler-case (eval `(let ((a (copy-seq ,seq))) (declare (optimize (safety 3))) (or (notnot (array-has-fill-pointer-p a)) (vector-push-extend ',val a 1)))) (error () t))) (deftest vector-push-extend.error.1 (vector-push-extend-error-test #(a b c d) 'x) t) (deftest vector-push-extend.error.2 (vector-push-extend-error-test #*00000 1) t) (deftest vector-push-extend.error.3 (vector-push-extend-error-test "abcde" #\x) t) (deftest vector-push-extend.error.4 (vector-push-extend-error-test #() 'x) t) (deftest vector-push-extend.error.5 (vector-push-extend-error-test #* 1) t) (deftest vector-push-extend.error.6 (vector-push-extend-error-test "" #\x) t) (deftest vector-push-extend.error.7 (vector-push-extend-error-test (make-array '5 :element-type 'base-char :initial-element #\a) #\x) t) (deftest vector-push-extend.error.8 (vector-push-extend-error-test (make-array '5 :element-type '(integer 0 (256)) :initial-element 0) 17) t) (deftest vector-push-extend.error.9 (vector-push-extend-error-test (make-array '5 :element-type 'float :initial-element 1.0) 2.0) t) (deftest vector-push-extend.error.10 (vector-push-extend-error-test (make-array '5 :element-type 'short-float :initial-element 1.0s0) 2.0s0) t) (deftest vector-push-extend.error.11 (vector-push-extend-error-test (make-array '5 :element-type 'long-float :initial-element 1.0l0) 2.0l0) t) (deftest vector-push-extend.error.12 (vector-push-extend-error-test (make-array '5 :element-type 'single-float :initial-element 1.0f0) 2.0f0) t) (deftest vector-push-extend.error.13 (vector-push-extend-error-test (make-array '5 :element-type 'double-float :initial-element 1.0d0) 2.0d0) t) (deftest vector-push-extend.error.14 (classify-error (vector-push-extend)) program-error) (deftest vector-push-extend.error.15 (classify-error (vector-push-extend (vector 1 2 3))) program-error) (deftest vector-push-extend.error.16 (classify-error (vector-push-extend (vector 1 2 3) 4 1 nil)) program-error) (deftest vector-push-extend.error.17 (handler-case (eval `(locally (declare (optimize (safety 3))) (let ((a (make-array '5 :fill-pointer t :adjustable nil :initial-element nil))) (or (notnot (adjustable-array-p a)) ; It's actually adjustable, or... (vector-push-extend a 'x) ; ... this fails )))) (error () t)) t) gcl/ansi-tests/vector-push.lsp000066400000000000000000000166211242227143400167230ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 25 00:55:43 2003 ;;;; Contains: Tests for VECTOR-PUSH (in-package :cl-test) (deftest vector-push.1 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(a b c d e))) (i 0) x y) (values (fill-pointer a) (vector-push (progn (setf x (incf i)) 'x) (progn (setf y (incf i)) a)) (fill-pointer a) a i x y)) 2 2 3 #(a b x) 2 1 2) (deftest vector-push.2 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(a b c d e)))) (values (fill-pointer a) (vector-push 'x a) (fill-pointer a) a)) 5 nil 5 #(a b c d e)) (deftest vector-push.3 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents "abcde" :element-type 'base-char))) (values (fill-pointer a) (vector-push #\x a) (fill-pointer a) a)) 2 2 3 "abx") (deftest vector-push.4 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents "abcde" :element-type 'base-char))) (values (fill-pointer a) (vector-push #\x a) (fill-pointer a) a)) 5 nil 5 "abcde") (deftest vector-push.5 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents "abcde" :element-type 'character))) (values (fill-pointer a) (vector-push #\x a) (fill-pointer a) a)) 2 2 3 "abx") (deftest vector-push.6 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents "abcde" :element-type 'character))) (values (fill-pointer a) (vector-push #\x a) (fill-pointer a) a)) 5 nil 5 "abcde") (deftest vector-push.7 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(0 1 1 0 0) :element-type 'bit))) (values (fill-pointer a) (vector-push 0 a) (fill-pointer a) a)) 2 2 3 #*010) (deftest vector-push.8 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(0 0 0 0 0) :element-type 'bit))) (values (fill-pointer a) (vector-push 1 a) (fill-pointer a) a)) 5 nil 5 #*00000) (deftest vector-push.9 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1 2 3 4 5) :element-type 'fixnum))) (values (fill-pointer a) (vector-push 0 a) (fill-pointer a) a)) 2 2 3 #(1 2 0)) (deftest vector-push.10 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(1 2 3 4 5) :element-type 'fixnum))) (values (fill-pointer a) (vector-push 0 a) (fill-pointer a) a)) 5 nil 5 #(1 2 3 4 5)) (deftest vector-push.11 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1 2 3 4 5) :element-type '(integer 0 (256))))) (values (fill-pointer a) (vector-push 0 a) (fill-pointer a) a)) 2 2 3 #(1 2 0)) (deftest vector-push.12 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(1 2 3 4 5) :element-type '(integer 0 (256))))) (values (fill-pointer a) (vector-push 0 a) (fill-pointer a) a)) 5 nil 5 #(1 2 3 4 5)) (deftest vector-push.13 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) :element-type 'short-float))) (values (fill-pointer a) (vector-push 0.0s0 a) (fill-pointer a) a)) 2 2 3 #(1.0s0 2.0s0 0.0s0)) (deftest vector-push.14 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) :element-type 'short-float))) (values (fill-pointer a) (vector-push 0.0s0 a) (fill-pointer a) a)) 5 nil 5 #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) (deftest vector-push.15 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) :element-type 'single-float))) (values (fill-pointer a) (vector-push 0.0f0 a) (fill-pointer a) a)) 2 2 3 #(1.0f0 2.0f0 0.0f0)) (deftest vector-push.16 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) :element-type 'single-float))) (values (fill-pointer a) (vector-push 0.0f0 a) (fill-pointer a) a)) 5 nil 5 #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) (deftest vector-push.17 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) :element-type 'double-float))) (values (fill-pointer a) (vector-push 0.0d0 a) (fill-pointer a) a)) 2 2 3 #(1.0d0 2.0d0 0.0d0)) (deftest vector-push.18 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) :element-type 'double-float))) (values (fill-pointer a) (vector-push 0.0d0 a) (fill-pointer a) a)) 5 nil 5 #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) (deftest vector-push.19 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) :element-type 'long-float))) (values (fill-pointer a) (vector-push 0.0l0 a) (fill-pointer a) a)) 2 2 3 #(1.0l0 2.0l0 0.0l0)) (deftest vector-push.20 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) :element-type 'long-float))) (values (fill-pointer a) (vector-push 0.0l0 a) (fill-pointer a) a)) 5 nil 5 #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) ;;; Error tests (defun vector-push-error-test (seq val) (declare (optimize (safety 3))) (handler-case (eval `(let ((a (copy-seq ,seq))) (declare (optimize (safety 3))) (or (notnot (array-has-fill-pointer-p a)) (vector-push ',val a)))) (error () t))) (deftest vector-push.error.1 (vector-push-error-test #(a b c d) 'x) t) (deftest vector-push.error.2 (vector-push-error-test #*00000 1) t) (deftest vector-push.error.3 (vector-push-error-test "abcde" #\x) t) (deftest vector-push.error.4 (vector-push-error-test #() 'x) t) (deftest vector-push.error.5 (vector-push-error-test #* 1) t) (deftest vector-push.error.6 (vector-push-error-test "" #\x) t) (deftest vector-push.error.7 (vector-push-error-test (make-array '5 :element-type 'base-char :initial-element #\a) #\x) t) (deftest vector-push.error.8 (vector-push-error-test (make-array '5 :element-type '(integer 0 (256)) :initial-element 0) 17) t) (deftest vector-push.error.9 (vector-push-error-test (make-array '5 :element-type 'float :initial-element 1.0) 2.0) t) (deftest vector-push.error.10 (vector-push-error-test (make-array '5 :element-type 'short-float :initial-element 1.0s0) 2.0s0) t) (deftest vector-push.error.11 (vector-push-error-test (make-array '5 :element-type 'long-float :initial-element 1.0l0) 2.0l0) t) (deftest vector-push.error.12 (vector-push-error-test (make-array '5 :element-type 'single-float :initial-element 1.0f0) 2.0f0) t) (deftest vector-push.error.13 (vector-push-error-test (make-array '5 :element-type 'double-float :initial-element 1.0d0) 2.0d0) t) (deftest vector-push.error.14 (classify-error (vector-push)) program-error) (deftest vector-push.error.15 (classify-error (vector-push (vector 1 2 3))) program-error) (deftest vector-push.error.16 (classify-error (vector-push (vector 1 2 3) 4 nil)) program-error) gcl/ansi-tests/vector.lsp000066400000000000000000000145121242227143400157430ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 23 06:32:02 2003 ;;;; Contains: Tests of VECTOR (type and function) (in-package :cl-test) ;;; More tests of type vector in make-array.lsp (deftest vector.type.1 (notnot-mv (typep #(a b c) 'vector)) t) (deftest vector.type.2 (notnot-mv (typep #() 'vector)) t) (deftest vector.type.3 (notnot-mv (typep "" 'vector)) t) (deftest vector.type.4 (notnot-mv (typep "abcdef" 'vector)) t) (deftest vector.type.5 (notnot-mv (typep #* 'vector)) t) (deftest vector.type.6 (notnot-mv (typep #*011011101011 'vector)) t) (deftest vector.type.7 (typep #0aNIL 'vector) nil) (deftest vector.type.8 (typep #2a((a b c d)) 'vector) nil) (deftest vector.type.9 (subtypep* 'vector 'array) t t) (deftest vector.type.10 (notnot-mv (typep #(a b c) '(vector *))) t) (deftest vector.type.11 (notnot-mv (typep #(a b c) '(vector t))) t) (deftest vector.type.12 (notnot-mv (typep "abcde" '(vector *))) t) (deftest vector.type.13 (typep "abcdef" '(vector t)) nil) (deftest vector.type.14 (notnot-mv (typep #*00110 '(vector *))) t) (deftest vector.type.15 (typep #*00110 '(vector t)) nil) (deftest vector.type.16 (notnot-mv (typep #(a b c) '(vector * 3))) t) (deftest vector.type.17 (typep #(a b c) '(vector * 2)) nil) (deftest vector.type.18 (typep #(a b c) '(vector * 4)) nil) (deftest vector.type.19 (notnot-mv (typep #(a b c) '(vector t 3))) t) (deftest vector.type.20 (typep #(a b c) '(vector t 2)) nil) (deftest vector.type.21 (typep #(a b c) '(vector t 4)) nil) (deftest vector.type.23 (notnot-mv (typep #(a b c) '(vector t *))) t) (deftest vector.type.23a (notnot-mv (typep "abcde" '(vector * 5))) t) (deftest vector.type.24 (typep "abcde" '(vector * 4)) nil) (deftest vector.type.25 (typep "abcde" '(vector * 6)) nil) (deftest vector.type.26 (notnot-mv (typep "abcde" '(vector * *))) t) (deftest vector.type.27 (typep "abcde" '(vector t 5)) nil) (deftest vector.type.28 (typep "abcde" '(vector t 4)) nil) (deftest vector.type.29 (typep "abcde" '(vector t 6)) nil) (deftest vector.type.30 (typep "abcde" '(vector t *)) nil) (deftest vector.type.31 (let ((s (coerce "abc" 'simple-base-string))) (notnot-mv (typep s '(vector base-char)))) t) (deftest vector.type.32 (let ((s (coerce "abc" 'simple-base-string))) (notnot-mv (typep s '(vector base-char 3)))) t) (deftest vector.type.33 (let ((s (coerce "abc" 'simple-base-string))) (typep s '(vector base-char 2))) nil) (deftest vector.type.34 (let ((s (coerce "abc" 'simple-base-string))) (typep s '(vector base-char 4))) nil) (deftest vector.type.35 (let ((s (coerce "abc" 'simple-base-string))) (notnot-mv (typep s 'vector))) t) (deftest vector.type.36 (let ((s (coerce "abc" 'simple-base-string))) (notnot-mv (typep s '(vector *)))) t) (deftest vector.type.37 (let ((s (coerce "abc" 'simple-base-string))) (notnot-mv (typep s '(vector * 3)))) t) (deftest vector.type.38 (let ((s (coerce "abc" 'simple-base-string))) (notnot-mv (typep s '(vector * *)))) t) (deftest vector.type.39 (let ((s (coerce "abc" 'simple-base-string))) (typep s '(vector t))) nil) (deftest vector.type.40 (let ((s (coerce "abc" 'simple-base-string))) (typep s '(vector t *))) nil) (deftest vector.type.41 (notnot-mv (typep (make-array '10 :element-type 'short-float) 'vector)) t) (deftest vector.type.42 (notnot-mv (typep (make-array '10 :element-type 'single-float) 'vector)) t) (deftest vector.type.43 (notnot-mv (typep (make-array '10 :element-type 'double-float) 'vector)) t) (deftest vector.type.44 (notnot-mv (typep (make-array '10 :element-type 'long-float) 'vector)) t) ;;; Tests of vector as class (deftest vector-as-class.1 (notnot-mv (find-class 'vector)) t) (deftest vector-as-class.2 (notnot-mv (typep #() (find-class 'vector))) t) (deftest vector-as-class.3 (notnot-mv (typep #(a b c) (find-class 'vector))) t) (deftest vector-as-class.4 (notnot-mv (typep "" (find-class 'vector))) t) (deftest vector-as-class.5 (notnot-mv (typep "abcd" (find-class 'vector))) t) (deftest vector-as-class.6 (notnot-mv (typep #* (find-class 'vector))) t) (deftest vector-as-class.7 (notnot-mv (typep #*01101010100 (find-class 'vector))) t) (deftest vector-as-class.8 (typep #0aNIL (find-class 'vector)) nil) (deftest vector-as-class.9 (typep #2a((a b)(c d)) (find-class 'vector)) nil) (deftest vector-as-class.10 (typep (make-array '(1 0)) (find-class 'vector)) nil) (deftest vector-as-class.11 (typep (make-array '(0 1)) (find-class 'vector)) nil) (deftest vector-as-class.12 (typep 1 (find-class 'vector)) nil) (deftest vector-as-class.13 (typep nil (find-class 'vector)) nil) (deftest vector-as-class.14 (typep 'x (find-class 'vector)) nil) (deftest vector-as-class.15 (typep '(a b c) (find-class 'vector)) nil) (deftest vector-as-class.16 (typep 10.0 (find-class 'vector)) nil) (deftest vector-as-class.17 (typep 3/5 (find-class 'vector)) nil) (deftest vector-as-class.18 (typep (1+ most-positive-fixnum) (find-class 'vector)) nil) ;;;; Tests of the function VECTOR (deftest vector.1 (vector) #()) (deftest vector.2 (vector 1 2 3) #(1 2 3)) (deftest vector.3 (let* ((len (min 1000 (1- call-arguments-limit))) (args (make-int-list len)) (v (apply #'vector args))) (and (typep v '(vector t)) (typep v '(vector t *)) (typep v `(vector t ,len)) (typep v 'simple-vector) (typep v `(simple-vector ,len)) (eql (length v) len) (loop for i from 0 for e across v always (eql i e)) t)) t) (deftest vector.4 (notnot-mv (typep (vector) '(vector t 0))) t) (deftest vector.5 (notnot-mv (typep (vector) 'simple-vector)) t) (deftest vector.6 (notnot-mv (typep (vector) '(simple-vector 0))) t) (deftest vector.7 (notnot-mv (typep (vector 1 2 3) 'simple-vector)) t) (deftest vector.8 (notnot-mv (typep (vector 1 2 3) '(simple-vector 3))) t) (deftest vector.9 (typep (vector #\a #\b #\c) 'string) nil) (deftest vector.10 (notnot-mv (typep (vector 1 2 3) '(simple-vector *))) t) (deftest vector.order.1 (let ((i 0) a b c) (values (vector (setf a (incf i)) (setf b (incf i)) (setf c (incf i))) i a b c)) #(1 2 3) 3 1 2 3) gcl/ansi-tests/vectorp.lsp000066400000000000000000000021221242227143400161150ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 13:17:05 2003 ;;;; Contains: Tests for VECTORP (in-package :cl-test) (deftest vectorp.1 (vectorp 1) nil) (deftest vectorp.2 (vectorp (1+ most-positive-fixnum)) nil) (deftest vectorp.3 (vectorp #\a) nil) (deftest vectorp.4 (vectorp 10.0) nil) (deftest vectorp.5 (vectorp #'(lambda (x y) (cons y x))) nil) (deftest vectorp.6 (vectorp '(a b)) nil) (deftest vectorp.7 (vectorp #0aT) nil) (deftest vectorp.8 (vectorp #2a((a b)(c d))) nil) (deftest vectorp.9 (notnot-mv (vectorp "abcd")) t) (deftest vectorp.10 (notnot-mv (vectorp #*)) t) (deftest vectorp.11 (notnot-mv (vectorp #*1101)) t) (deftest vectorp.12 (notnot-mv (vectorp "")) t) (deftest vectorp.13 (notnot-mv (vectorp #(1 2 3))) t) (deftest vectorp.14 (notnot-mv (vectorp #())) t) (deftest vectorp.15 (vectorp #b11010) nil) ;;; Error tests (deftest vectorp.error.1 (classify-error (vectorp)) program-error) (deftest vectorp.error.2 (classify-error (vectorp #() #())) program-error) gcl/ansi-tests/warn.lsp000066400000000000000000000070371242227143400154140ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 23 20:48:12 2003 ;;;; Contains: Tests for WARN (in-package :cl-test) (deftest warn.1 (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn "This is a warning")) warned))) (nil) t) (deftest warn.2 (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning)))) (values (multiple-value-list (warn "This is a warning")) warned))) (nil) t) (deftest warn.3 (with-output-to-string (*error-output*) (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (warn "Foo!")))) "") (deftest warn.4 (let ((str (with-output-to-string (*error-output*) (warn "Foo!")))) (not (string= str ""))) t) (deftest warn.5 (let ((warned nil)) (handler-bind ((simple-warning #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn "This is a warning")) warned))) (nil) t) (deftest warn.6 (let ((warned nil)) (handler-bind ((simple-condition #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn "This is a warning")) warned))) (nil) t) (deftest warn.7 (let ((warned nil)) (handler-bind ((condition #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn "This is a warning")) warned))) (nil) t) (deftest warn.8 (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn 'simple-warning :format-control "Foo!")) warned))) (nil) t) (deftest warn.9 (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn 'warning)) warned))) (nil) t) (deftest warn.10 (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn (make-condition 'simple-warning :format-control "Foo!"))) warned))) (nil) t) (deftest warn.11 (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn (make-condition 'warning))) warned))) (nil) t) (deftest warn.12 (classify-error (warn 'condition)) type-error) (deftest warn.13 (classify-error (warn 'simple-condition)) type-error) (deftest warn.14 (classify-error (warn (make-condition 'simple-warning) :format-control "Foo")) type-error) (deftest warn.15 (classify-error (warn)) program-error) (deftest warn.16 (classify-error (warn (make-condition 'condition))) type-error) (deftest warn.17 (classify-error (warn (make-condition 'simple-condition))) type-error) (deftest warn.18 (classify-error (warn (make-condition 'simple-error))) type-error) gcl/ansi-tests/when.lsp000066400000000000000000000011011242227143400153700ustar00rootroot00000000000000;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 19:36:57 2002 ;;;; Contains: Tests of WHEN (in-package :cl-test) (deftest when.1 (when t) nil) (deftest when.2 (when nil 'a) nil) (deftest when.3 (when t (values))) (deftest when.4 (when t (values 'a 'b 'c 'd)) a b c d) (deftest when.5 (when nil (values)) nil) (deftest when.6 (when nil (values 'a 'b 'c 'd)) nil) (deftest when.7 (let ((x 0)) (values (when t (incf x) 'a) x)) a 1) ;;; (deftest when.error.1 ;;; (classify-error (when)) ;;; program-error) gcl/bfdtest.c000066400000000000000000000324311242227143400134260ustar00rootroot00000000000000#define IN_GCC #include #include #include #include static bfd *exe_bfd = NULL; struct bfd_link_info link_info; int build_symbol_table_bfd ( char *oname ) { int u,v; asymbol **q; if ( ! ( exe_bfd = bfd_openr ( oname, 0 ) ) ) { fprintf ( stderr, "Cannot open self.\n" ); exit ( 0 ); } if ( ! bfd_check_format ( exe_bfd, bfd_object ) ) { fprintf ( stderr, "I'm not an object.\n" ); exit ( 0 ); } if (!(link_info.hash = bfd_link_hash_table_create (exe_bfd))) { fprintf ( stderr, "Cannot make hash table.\n" ); exit ( 0 ); } if (!bfd_link_add_symbols(exe_bfd,&link_info)) { fprintf ( stderr, "Cannot add self symbols\n.\n" ); exit ( 0 ); } if ((u=bfd_get_symtab_upper_bound(exe_bfd))<0) { fprintf ( stderr, "Cannot get self's symtab upper bound.\n" ); exit ( 0 ); } fprintf ( stderr, "Allocating symbol table (%d bytes)\n", u ); q = (asymbol **) malloc ( u ); if ( ( v = bfd_canonicalize_symtab ( exe_bfd, q ) ) < 0 ) { fprintf ( stderr, "Cannot canonicalize self's symtab.\n" ); exit ( 0 ); } #ifdef _WIN32 for ( u=0; u < v; u++ ) { char *c; if ( ( c = (char *) strstr ( q[u]->name, "_" ) ) ) { struct bfd_link_hash_entry *h; if ( ! ( h = bfd_link_hash_lookup ( link_info.hash, q[u]->name, true, true, true ) ) ) fprintf ( stderr, "Cannot make new hash entry.\n" ); h->type=bfd_link_hash_defined; if ( !q[u]->section ) fprintf ( stderr, "Symbol is missing section.\n" ); h->u.def.value = q[u]->value + q[u]->section->vma; h->u.def.section = q[u]->section; fprintf ( stderr, "Processed %s\n", q[u]->name ); } } #else for (u=0;uname,"@@GLIBC\n" ))) { struct bfd_link_hash_entry *h; *c=0; if (!(h=bfd_link_hash_lookup(link_info.hash,q[u]->name,true,true,true))) fprintf ( stderr, "Cannot make new hash entry.\n" ); h->type=bfd_link_hash_defined; if (!q[u]->section) fprintf ( stderr, "Symbol is missing section.\n" ); h->u.def.value=q[u]->value+q[u]->section->vma; h->u.def.section=q[u]->section; *c='@'; } } #endif bfd_close ( exe_bfd ); free(q); return 0; } /* align for power of two n */ static void * round_up(void *address, unsigned long n) { fprintf ( stderr, "round_up: address = %d, n = %d, returning %d\n", address, n, (void *)(((unsigned long)address + n -1) & ~(n-1)) ); fflush ( stderr ); return (void *)(((unsigned long)address + n -1) & ~(n-1)) ; } #define ROUND_UP(a,b) round_up(a,b) static boolean madd_archive_element (struct bfd_link_info * link_info, bfd *abfd, const char *name) { fprintf ( stderr, "madd_archive_element\n"); return false; } static boolean mmultiple_definition (struct bfd_link_info * link_info, const char *name, bfd *obfd, asection *osec, bfd_vma oval, bfd *nbfd, asection *nsec, bfd_vma nval) { fprintf ( stderr, "mmultiple_definition\n"); return false; } static boolean mmultiple_common (struct bfd_link_info * link_info, const char *name, bfd *obfd, enum bfd_link_hash_type otype, bfd_vma osize, bfd *nbfd, enum bfd_link_hash_type ntype, bfd_vma nsize) { fprintf ( stderr, " mmultiple_common\n"); return false; } static boolean madd_to_set (struct bfd_link_info * link_info, struct bfd_link_hash_entry *entry, bfd_reloc_code_real_type reloc, bfd *abfd, asection *sec, bfd_vma value) { fprintf ( stderr, "madd_to_set\n"); return false; } static boolean mconstructor (struct bfd_link_info * link_info,boolean constructor, const char *name, bfd *abfd, asection *sec, bfd_vma value) { fprintf ( stderr, "mconstructor\n"); return false; } static boolean mwarning (struct bfd_link_info * link_info, const char *warning, const char *symbol, bfd *abfd, asection *section, bfd_vma address) { fprintf ( stderr, "mwarning\n"); return false; } static boolean mundefined_symbol (struct bfd_link_info * link_info, const char *name, bfd *abfd, asection *section, bfd_vma address, boolean fatal) { printf("mundefined_symbol %s is undefined\n",name); return false; } static boolean mreloc_overflow (struct bfd_link_info * link_info, const char *name, const char *reloc_name, bfd_vma addend, bfd *abfd, asection *section, bfd_vma address) { printf("mreloc_overflow reloc for %s is overflowing\n",name); return false; } static boolean mreloc_dangerous (struct bfd_link_info * link_info, const char *message, bfd *abfd, asection *section, bfd_vma address) { printf("mreloc_dangerous reloc is dangerous %s\n",message); return false; } static boolean munattached_reloc (struct bfd_link_info * link_info, const char *name, bfd *abfd, asection *section, bfd_vma address) { fprintf ( stderr, " munattached_reloc\n"); return false; } static boolean mnotice (struct bfd_link_info * link_info, const char *name, bfd *abfd, asection *section, bfd_vma address) { fprintf ( stderr, "mnotice\n"); return false; } int main ( int argc, char ** argv ) { int init_address=-1; int max_align = 0; unsigned long curr_size = 0; bfd *obj_bfd = NULL; bfd_error_type myerr; unsigned u = 0, v = 0; asymbol **q = NULL; asection *s = NULL; static struct bfd_link_callbacks link_callbacks; static struct bfd_link_order link_order; void *current = NULL; void *cfd_self = NULL; void *cfd_start = NULL; int cfd_size = 0; void *the_start = NULL; void *start_address = NULL; void *m = NULL; fprintf ( stderr, "In BFD fast load test.\n" ); if ( argc < 3 ) { fprintf ( stderr, "Need an executable and an object file as arguments.\n" ); } else { memset ( &link_info, 0, sizeof (link_info) ); memset ( &link_order, 0, sizeof (link_order) ); memset ( &link_callbacks, 0, sizeof (link_callbacks) ); bfd_init(); fprintf ( stderr, "BUILDING EXECUTABLE SYMBOL TABLE (ARGV[1]) \n\n" ); build_symbol_table_bfd ( argv[1] ); link_callbacks.add_archive_element=madd_archive_element; link_callbacks.multiple_definition=mmultiple_definition; link_callbacks.multiple_common=mmultiple_common; link_callbacks.add_to_set=madd_to_set; link_callbacks.constructor=mconstructor; link_callbacks.warning=mwarning; link_callbacks.undefined_symbol=mundefined_symbol; link_callbacks.reloc_overflow=mreloc_overflow; link_callbacks.reloc_dangerous=mreloc_dangerous; link_callbacks.unattached_reloc=munattached_reloc; link_callbacks.notice = mnotice; link_info.callbacks = &link_callbacks; link_order.type = bfd_indirect_link_order; if ( ! ( obj_bfd = bfd_openr ( argv[2], 0 ) ) ) { fprintf ( stderr, "Cannot open bfd.\n" ); } if ( ( myerr = bfd_get_error () ) && myerr != 3 ) { fprintf ( stderr, "Unknown bfd error code on openr %s %d\n.", argv[2], myerr ); } fflush ( stderr ); if ( ! bfd_check_format ( obj_bfd, bfd_object ) ) { fprintf ( stderr, "Unknown bfd format %s.\n", argv[2] ); } if ( ( myerr = bfd_get_error () ) && myerr != 3 ) { fprintf ( stderr, "Unknown bfd error code on check_format %s\n", argv[2] ); } bfd_set_error(0); current = NULL; fprintf ( stderr, "CALCULATING CURRENT, MAX_ALIGN and ALLOCATING \n\n" ); for ( s= obj_bfd->sections;s;s=s->next) { s->owner = obj_bfd; s->output_section = ( s->flags & SEC_ALLOC) ? s : obj_bfd->sections; s->output_offset=0; if (!(s->flags & SEC_ALLOC)) continue; if (max_alignalignment_power) max_align=s->alignment_power; current=round_up(current,1<alignment_power); current+=s->_raw_size; fprintf ( stderr, "Section %s: owner = %x, output_offset = %x, output_section = %x (%s)\n", s->name, s->owner, s->output_offset, s->output_section, s->output_section->name ); } fprintf ( stderr, "1\n"); curr_size=(unsigned long)current; max_align=1< sizeof(char *) ? max_align :0); cfd_start = (void *) malloc ( cfd_size ); the_start = start_address = cfd_start; fprintf ( stderr, "ALLOCATED %d bytes \n\n", cfd_size ); fprintf ( stderr, "max_align = %d, current = %d, cfd_self = %x, " "cfd_size = %x, cfd_start = %x\n", max_align, current, cfd_self, cfd_size, cfd_start ); start_address = ROUND_UP ( start_address, max_align ); cfd_size = cfd_size - ( start_address - the_start ); cfd_start = (void *) start_address; fprintf ( stderr, "max_align = %d, current = %d, cfd_self = %x, " "cfd_size = %x, cfd_start = %x\n", max_align, current, cfd_self, cfd_size, cfd_start ); memset ( cfd_start, 0, cfd_size ); for ( m = start_address, s = obj_bfd->sections; s; s=s->next ) { if (!(s->flags & SEC_ALLOC)) continue; m=round_up(m,1<alignment_power); s->output_section->vma=(unsigned long)m; m+=s->_raw_size; fprintf ( stderr, "Section address %x\n", s ); fprintf ( stderr, "m loop Section %s: owner = %x, output_offset = %x, " "output_section = %x (%s), vma = %x, m = %x\n", s->name, s->owner, s->output_offset, s->output_section, s->output_section->name, s->output_section->vma, m ); } fprintf ( stderr, "\n\nDOING SOMETHING WITH THE HASHED SYMBOLS\n\n" ); if ((u=bfd_get_symtab_upper_bound(obj_bfd))<0) fprintf ( stderr, "Cannot get symtab uppoer bound.\n" ); q = (asymbol **) alloca ( u ); if ( ( v = bfd_canonicalize_symtab ( obj_bfd, q ) ) < 0 ) fprintf ( stderr, "cannot canonicalize symtab.\n" ); fprintf ( stderr, "u = %d, v = %d\n", u, v ); for (u=0;uname = %s\n", u, q[u]->name ); if (!strncmp("init_",q[u]->name,5)) { init_address=q[u]->value; continue; } if (!(h=bfd_link_hash_lookup(link_info.hash,q[u]->name, false, false, true))) continue; if (h->type!=bfd_link_hash_defined) fprintf ( stderr, "Undefined symbol.\n" ); if (h->u.def.section) { q[u]->value=h->u.def.value+h->u.def.section->vma; q[u]->flags|=BSF_WEAK; } else fprintf ( stderr, "Symbol without section.\n" ); } fprintf ( stderr, "\n\nDOING RELOCATIONS\n\n", cfd_size ); fflush ( stderr ); for ( s = obj_bfd->sections; s; s = s->next ) { fprintf ( stderr, "s->name %s, s->flags = %x\n", s->name, s->flags ); if ( ! ( s->flags & SEC_LOAD ) ) continue; link_order.u.indirect.section=s; fprintf ( stderr, "About to get reloc section contents\n" ); fprintf ( stderr, "obj_bfd = %x, section %s, s->output_section = %x, q = %x\n", obj_bfd, s->name, s->output_section, q); fflush ( stderr ); if (!bfd_get_relocated_section_contents(obj_bfd, &link_info,&link_order, (void *)(unsigned long)s->output_section->vma,0,q)) fprintf ( stderr, "Cannot get relocated section contents\n"); } bfd_close ( obj_bfd ); printf("start address -T %x \n", cfd_start); } } gcl/bin/000077500000000000000000000000001242227143400123745ustar00rootroot00000000000000gcl/bin/append.c000077500000000000000000000012411242227143400140100ustar00rootroot00000000000000#include /* usage: append a b c equivalent to cat a b >> c if only cat were binary... but by some wonderful dos like deicision, it is not under cygnus.. */ int main(int argc,char *argv[]) { int i; FILE *out ; if (argc < 2) return 0; out = fopen(argv[argc-1],"a+b"); if (out == 0) { perror("cant open"); return 1; } for (i=1; i < argc-1 ; i++) { FILE *fp = fopen(argv[i],"rb"); int ch; if (fp == 0) { perror("cant open"); return 1; } while (1) { ch =getc(fp); if (ch == EOF && feof(fp)) { fclose(fp); break; } else putc(ch,out); } } fclose(out); return 0; } gcl/bin/dpp.c000077500000000000000000000312401242227143400133260ustar00rootroot00000000000000/* dpp.c defun preprocessor */ /* Usage: dpp file The file named file.d is preprocessed and the output will be written to the file whose name is file.c. ;changes: remove \n from beginning of main output so debuggers can find the right foo.d source file name.--wfs ;add \" to the line output for ansi C --wfs The function definition: @(defun name ({var}* [&optional {var | (var [initform [svar]])}*] [&rest] [&key {var | ({var | (keyword var)} [initform [svar]])}* [&allow_other_keys]] [&aux {var | (var [initform])}*]) C-declaration @ C-body @) &optional may be abbreviated as &o. &rest may be abbreviated as &r. &key may be abbreviated as &k. &allow_other_keys may be abbreviated as &aok. &aux may be abbreviated as &a. Each variable becomes a macro name defined to be an expression of the form vs_base[...]. Each supplied-p parameter becomes a boolean C variable. Initforms are C expressions. It an expression contain non-alphanumeric characters, it should be surrounded by backquotes (`). Function return: @(return {form}*) It becomes a C block. */ #include #include #include #include "gclincl.h" #include "config.h" #ifdef UNIX #include #define isalphanum(c) isalnum(c) #endif #define POOLSIZE 2048 #define MAXREQ 16 #define MAXOPT 16 #define MAXKEY 16 #define MAXAUX 16 #define MAXRES 16 #define TRUE 1 #define FALSE 0 typedef int bool; FILE *in, *out; char filename[BUFSIZ]; int line; int tab; int tab_save; char pool[POOLSIZE]; char *poolp; char *function; int fstatic; char *required[MAXREQ]; int nreq; struct optional { char *o_var; char *o_init; char *o_svar; } optional[MAXOPT]; int nopt; bool rest_flag; bool key_flag; struct keyword { char *k_key; char *k_var; char *k_init; char *k_svar; } keyword[MAXKEY]; int nkey; bool allow_other_keys_flag; struct aux { char *a_var; char *a_init; } aux[MAXAUX]; int naux; char *result[MAXRES]; int nres; void error(s) char *s; { printf("Error in line %d: %s.\n", line, s); exit(0); } int readc() { int c; c = getc(in); if (feof(in)) { if (function != NULL) error("unexpected end of file"); exit(0); } if (c == '\n') { line++; tab = 0; } else if (c == '\t') tab++; return(c); } int nextc() { int c; while (isspace(c = readc())) ; return(c); } void unreadc(c) int c; { if (c == '\n') --line; else if (c == '\t') --tab; ungetc(c, in); } void put_tabs(n) int n; { int i; for (i = 0; i < n; i++) putc('\t', out); } void pushc(c) int c; { if (poolp >= &pool[POOLSIZE]) error("buffer bool overflow"); *poolp++ = c; } char * read_token() { int c; char *p; p = poolp; if ((c = nextc()) == '`') { while ((c = readc()) != '`') pushc(c); pushc('\0'); return(p); } do pushc(c); while (isalphanum(c = readc()) || c == '_'); pushc('\0'); unreadc(c); return(p); } void reset() { int i; poolp = pool; function = NULL; nreq = 0; for (i = 0; i < MAXREQ; i++) required[i] = NULL; nopt = 0; for (i = 0; i < MAXOPT; i++) optional[i].o_var = optional[i].o_init = optional[i].o_svar = NULL; rest_flag = FALSE; key_flag = FALSE; nkey = 0; for (i = 0; i < MAXKEY; i++) keyword[i].k_key = keyword[i].k_var = keyword[i].k_init = keyword[i].k_svar = NULL; allow_other_keys_flag = FALSE; naux = 0; for (i = 0; i < MAXAUX; i++) aux[i].a_var = aux[i].a_init = NULL; } void get_function() { function = read_token(); } void get_lambda_list() { int c; char *p; if ((c = nextc()) != '(') error("( expected"); for (;;) { if ((c = nextc()) == ')') return; if (c == '&') { p = read_token(); goto OPTIONAL; } unreadc(c); p = read_token(); if (nreq >= MAXREQ) error("too many required variables"); required[nreq++] = p; } OPTIONAL: if (strcmp(p, "optional") != 0 && strcmp(p, "o") != 0) goto REST; for (;; nopt++) { if ((c = nextc()) == ')') return; if (c == '&') { p = read_token(); goto REST; } if (nopt >= MAXOPT) error("too many optional argument"); if (c == '(') { optional[nopt].o_var = read_token(); if ((c = nextc()) == ')') continue; unreadc(c); optional[nopt].o_init = read_token(); if ((c = nextc()) == ')') continue; unreadc(c); optional[nopt].o_svar = read_token(); if (nextc() != ')') error(") expected"); } else { unreadc(c); optional[nopt].o_var = read_token(); } } REST: if (strcmp(p, "rest") != 0 && strcmp(p, "r") != 0) goto KEYWORD; rest_flag = TRUE; if ((c = nextc()) == ')') return; if (c != '&') error("& expected"); p = read_token(); goto KEYWORD; KEYWORD: if (strcmp(p, "key") != 0 && strcmp(p, "k") != 0) goto AUX_L; key_flag = TRUE; for (;; nkey++) { if ((c = nextc()) == ')') return; if (c == '&') { p = read_token(); if (strcmp(p, "allow_other_keys") == 0 || strcmp(p, "aok") == 0) { allow_other_keys_flag = TRUE; if ((c = nextc()) == ')') return; if (c != '&') error("& expected"); p = read_token(); } goto AUX_L; } if (nkey >= MAXKEY) error("too many optional argument"); if (c == '(') { if ((c = nextc()) == '(') { p = read_token(); if (p[0] != ':' || p[1] == '\0') error("keyword expected"); keyword[nkey].k_key = p + 1; keyword[nkey].k_var = read_token(); if (nextc() != ')') error(") expected"); } else { unreadc(c); keyword[nkey].k_key = keyword[nkey].k_var = read_token(); } if ((c = nextc()) == ')') continue; unreadc(c); keyword[nkey].k_init = read_token(); if ((c = nextc()) == ')') continue; unreadc(c); keyword[nkey].k_svar = read_token(); if (nextc() != ')') error(") expected"); } else { unreadc(c); keyword[nkey].k_key = keyword[nkey].k_var = read_token(); } } AUX_L: if (strcmp(p, "aux") != 0 && strcmp(p, "a") != 0) error("illegal lambda-list keyword"); for (;;) { if ((c = nextc()) == ')') return; if (c == '&') error("illegal lambda-list keyword"); if (naux >= MAXAUX) error("too many auxiliary variable"); if (c == '(') { aux[naux].a_var = read_token(); if ((c = nextc()) == ')') continue; unreadc(c); aux[naux].a_init = read_token(); if (nextc() != ')') error(") expected"); } else { unreadc(c); aux[naux].a_var = read_token(); } naux++; } } void get_return() { int c; nres = 0; for (;;) { if ((c = nextc()) == ')') return; unreadc(c); result[nres++] = read_token(); } } void put_fhead() { #ifdef STATIC_FUNCTION_POINTERS fprintf(out, "static void L%s_static ();\n",function); if (!fstatic) fprintf(out,"void\nL%s()\n{ L%s_static();}\n\n",function,function); fprintf(out,"static void\nL%s_static()\n{",function); #else fprintf(out, "%svoid\nL%s()\n{", fstatic ? "static " : "",function); #endif } void put_declaration() { int i; fprintf(out, "\tint narg;\n"); fprintf(out, "\tregister object *DPPbase=vs_base;\n"); for (i = 0; i < nopt; i++) if (optional[i].o_svar != NULL) fprintf(out, "\tbool %s;\n", optional[i].o_svar); for (i = 0; i < nreq; i++) fprintf(out, "#define\t%s\tDPPbase[%d]\n", required[i], i); for (i = 0; i < nopt; i++) fprintf(out, "#define\t%s\tDPPbase[%d+%d]\n", optional[i].o_var, nreq, i); for (i = 0; i < nkey; i++) fprintf(out, "#define\t%s\tDPPbase[%d+%d+%d]\n", keyword[i].k_var, nreq, nopt, i); for (i = 0; i < nkey; i++) if (keyword[i].k_svar != NULL) fprintf(out, "\tbool %s;\n", keyword[i].k_svar); for (i = 0; i < naux; i++) fprintf(out, "#define\t%s\tDPPbase[%d+%d+2*%d+%d]\n", aux[i].a_var, nreq, nopt, nkey, i); fprintf(out, "\n"); fprintf(out, "\tnarg = vs_top - vs_base;\n"); if (nopt == 0 && !rest_flag && !key_flag) fprintf(out, "\tcheck_arg(%d);\n", nreq); else { fprintf(out, "\tif (narg < %d)\n", nreq); fprintf(out, "\t\ttoo_few_arguments();\n"); } for (i = 0; i < nopt; i++) if (optional[i].o_svar != NULL) { fprintf(out, "\tif (narg > %d + %d)\n", nreq, i); fprintf(out, "\t\t%s = TRUE;\n", optional[i].o_svar); fprintf(out, "\telse {\n"); fprintf(out, "\t\t%s = FALSE;\n", optional[i].o_svar); fprintf(out, "\t\tvs_push(%s);\n", optional[i].o_init); fprintf(out, "\t\tnarg++;\n"); fprintf(out, "\t}\n"); } else if (optional[i].o_init != NULL) { fprintf(out, "\tif (narg <= %d + %d) {\n", nreq, i); fprintf(out, "\t\tvs_push(%s);\n", optional[i].o_init); fprintf(out, "\t\tnarg++;\n"); fprintf(out, "\t}\n"); } else { fprintf(out, "\tif (narg <= %d + %d) {\n", nreq, i); fprintf(out, "\t\tvs_push(Cnil);\n"); fprintf(out, "\t\tnarg++;\n"); fprintf(out, "\t}\n"); } if (nopt > 0 && !key_flag && !rest_flag) { fprintf(out, "\tif (narg > %d + %d)\n", nreq, nopt); fprintf(out, "\t\ttoo_many_arguments();\n"); } if (key_flag) { fprintf(out, "\tparse_key(vs_base+%d+%d,FALSE, %s, %d,\n", nreq, nopt, allow_other_keys_flag ? "TRUE" : "FALSE", nkey); if (nkey > 0) { i = 0; for (;;) { fprintf(out, "\t\tsK%s", keyword[i].k_key); if (++i == nkey) { fprintf(out, ");\n"); break; } else fprintf(out, ",\n"); } } else fprintf(out, "\t\tCnil);"); fprintf(out, "\tvs_top = vs_base + %d+%d+2*%d;\n", nreq, nopt, nkey); for (i = 0; i < nkey; i++) { if (keyword[i].k_init == NULL) continue; fprintf(out, "\tif (vs_base[%d+%d+%d+%d]==Cnil)\n", nreq, nopt, nkey, i); fprintf(out, "\t\t%s = %s;\n", keyword[i].k_var, keyword[i].k_init); } for (i = 0; i < nkey; i++) if (keyword[i].k_svar != NULL) fprintf(out, "\t%s = vs_base[%d+%d+%d+%d] != Cnil;\n", keyword[i].k_svar, nreq, nopt, nkey, i); } for (i = 0; i < naux; i++) if (aux[i].a_init != NULL) fprintf(out, "\tvs_push(%s);\n", aux[i].a_init); else fprintf(out, "\tvs_push(Cnil);\n"); } void put_ftail() { int i; for (i = 0; i < nreq; i++) fprintf(out, "#undef %s\n", required[i]); for (i = 0; i < nopt; i++) fprintf(out, "#undef %s\n", optional[i].o_var); for (i = 0; i < nkey; i++) fprintf(out, "#undef %s\n", keyword[i].k_var); for (i = 0; i < naux; i++) fprintf(out, "#undef %s\n", aux[i].a_var); fprintf(out, "}"); } void put_return() { int i, t; t = tab_save + 1; if (nres == 0) { fprintf(out, "{\n"); put_tabs(t); fprintf(out, "vs_top = vs_base;\n"); put_tabs(t); fprintf(out, "vs_base[0] = Cnil;\n"); put_tabs(t); fprintf(out, "return;\n"); put_tabs(tab_save); fprintf(out, "}"); } else if (nres == 1) { fprintf(out, "{\n"); put_tabs(t); fprintf(out, "vs_base[0] = %s;\n", result[0]); put_tabs(t); fprintf(out, "vs_top = vs_base + 1;\n"); put_tabs(t); fprintf(out, "return;\n"); put_tabs(tab_save); fprintf(out, "}"); } else { fprintf(out, "{\n"); for (i = 0; i < nres; i++) { put_tabs(t); fprintf(out, "object R%d;\n", i); } for (i = 0; i < nres; i++) { put_tabs(t); fprintf(out, "R%d = %s;\n", i, result[i]); } for (i = 0; i < nres; i++) { put_tabs(t); fprintf(out, "vs_base[%d] = R%d;\n", i, i); } put_tabs(t); fprintf(out, "vs_top = vs_base + %d;\n", nres); put_tabs(t); fprintf(out, "return;\n"); put_tabs(tab_save); fprintf(out, "}"); } } void main_loop() { int c; char *p; line = 1; fprintf(out, "# line %d \"%s\"\n", line, filename); LOOP: reset(); fprintf(out, "\n# line %d \"%s\"\n", line, filename); while ((c = readc()) != '@') putc(c, out); if (readc() != '(') error("@( expected"); p = read_token(); fstatic=0; if (strcmp(p, "static") == 0) { fstatic=1; p = read_token(); } if (strcmp(p, "defun") == 0) { get_function(); get_lambda_list(); put_fhead(); fprintf(out, "\n# line %d \"%s\"\n", line, filename); while ((c = readc()) != '@') putc(c, out); put_declaration(); BODY: fprintf(out, "\n# line %d \"%s\"\n", line, filename); while ((c = readc()) != '@') putc(c, out); if ((c = readc()) == ')') { put_ftail(); goto LOOP; } else if (c != '(') error("@( expected"); p = read_token(); if (strcmp(p, "return") == 0) { tab_save = tab; get_return(); put_return(); goto BODY; } else error("illegal symbol"); } else error("illegal symbol"); } int main(argc, argv) int argc; char **argv; { char *p, *q; if (argc != 2) error("arg count"); for (p = argv[1], q = filename; *p != '\0'; p++, q++) if (q >= &filename[BUFSIZ-3]) error("too long file name"); else *q = *p; q[0] = '.'; q[1] = 'd'; q[2] = '\0'; in = fopen(filename, "r"); if (in == NULL) error("can't open input file"); q[1] = 'c'; out = fopen(filename, "w"); if (out == NULL) error("can't open output file"); q[1] = 'd'; printf("dpp: %s -> ", filename); q[1] = 'c'; printf("%s\n", filename); q[1] = 'd'; main_loop(); return 0; } gcl/bin/file-sub.c000066400000000000000000000026101242227143400142450ustar00rootroot00000000000000/* # Substitute the region between BEGIN and END in FILE1 into FILE2 */ #include #include #include void scanCopyToLine(FILE *fp, char *line,FILE *outstream); int main(int argc,char *argv[]) { if (argc < 5) { ERROR: fprintf(stderr,"Usage: file-sub subFile FileToSubInto BEGIN END [outfile -]"); exit(1); } { FILE *file1; FILE *file2; FILE *outstream = stdout; char *begin=argv[3]; char *end=argv[4]; file2= fopen(argv[2],"rb"); file1= fopen(argv[1],"rb"); if (argc>=6 && strcmp(argv[5],"-")!=0) { outstream= fopen(argv[5],"wb"); } if (file1==0 || file2==0) goto ERROR; { scanCopyToLine(file2,begin,outstream); scanCopyToLine(file1,begin,0); scanCopyToLine(file1,end,outstream); scanCopyToLine(file2,end,0); scanCopyToLine(file2,0,outstream); } if (outstream != stdout) fclose(outstream); } return 0; } /* copy from fp to outstream all lines up to and including one beginning with LINE */ void scanCopyToLine(FILE *fp, char *line,FILE *outstream) { int length=0; int finish=0; char buf[5000]; if (line) length = strlen(line); while (!finish && !feof(fp)) { char *s = fgets(buf,sizeof(buf),fp); if (line && s && strncmp(line,s,length)==0) { finish=1; } if (s && outstream) fputs(s,outstream); } } gcl/bin/info000077500000000000000000000003131242227143400132520ustar00rootroot00000000000000#!/bin/sh gcl -batch -eval '(si::error-set (quote (progn (tk::tkconnect :args "-geometry 20x20-2+2")(tk::wm :iconify ".")(si::info '\"$1\"')(tk::bind (quote .info) "" (quote (bye)))(read))))' gcl/bin/info1000077500000000000000000000004041242227143400133340ustar00rootroot00000000000000#!/usr/local/bin/gcl.exe -f (si::error-set '(progn (tk::tkconnect :args "-geometry 20x20-2+2") (tk::wm :iconify ".") (si::info (nth 1 SYSTEM::*COMMAND-ARGS*)) (tk::bind (quote .info) "" (quote (bye))) (read))) gcl/bin/makefile000066400000000000000000000006141242227143400140750ustar00rootroot00000000000000DEFS = -I../h CC = cc APPEND = ../bin/append -include ../makedefs all: dpp${EXE} ${APPEND}${EXE} file-sub${EXE} dpp${EXE}: dpp.c ${CC} ${DEFS} -o dpp${EXE} dpp.c file-sub${EXE}: file-sub.c ${CC} ${DEFS} -o file-sub${EXE} file-sub.c ${APPEND}${EXE}: append.c ${CC} ${DEFS} -o append${EXE} append.c clean: rm -f dpp${EXE} append${EXE} file-sub${EXE} core a.out *.o gcl gclm.bat gcl/bin/tkinfo000077500000000000000000000004511242227143400136140ustar00rootroot00000000000000#!/home/wfs/bin/gcl -f (in-package "SI") (setq *load-verbose* nil) (tkconnect) (tk::wm :iconify ".") (offer-choices (sloop::sloop for v in (cdr si::*command-args*) appending (info-aux v *default-info-files*)) *default-info-files*) (tk::bind '.info "" '(bye)) (read) gcl/clcs/000077500000000000000000000000001242227143400125505ustar00rootroot00000000000000gcl/clcs/gcl_clcs_condition_definitions.lisp000077500000000000000000000123551242227143400216640ustar00rootroot00000000000000;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (IN-PACKAGE :CONDITIONS) (define-condition warning (condition) nil) (define-condition style-warning (warning) nil) (define-condition serious-condition (condition) nil) (define-condition error (serious-condition) nil) (define-condition simple-condition (condition) ((format-control :type string :initarg :format-control :reader simple-condition-format-control :initform "") (format-arguments :initarg :format-arguments :reader simple-condition-format-arguments :initform nil)) (:report (lambda (c s) (call-next-method) (apply 'format s (simple-condition-format-control c) (simple-condition-format-arguments c))))) (define-condition simple-warning (simple-condition warning) nil) (define-condition simple-error (simple-condition error) nil) (define-condition storage-condition (serious-condition) nil) (define-condition stack-overflow (storage-condition) nil) (define-condition storage-exhausted (storage-condition) nil) (define-condition type-error (error) ((datum :initarg :datum :reader type-error-datum) (expected-type :initarg :expected-type :reader type-error-expected-type)) (:report ("~s is not of type ~s: " datum expected-type))) (define-condition simple-type-error (simple-error type-error) nil) (define-condition program-error (error) nil) (define-condition control-error (error) nil) (define-condition parse-error (error) nil) (define-condition print-not-readable (error) ((object :initarg :object :reader print-not-readable-object)) (:report ("Object ~s is unreadable: " object))) (define-condition stream-error (error) ((stream :initarg :stream :reader stream-error-stream)) (:report ("Stream error on stream ~s: " stream))) (define-condition reader-error (parse-error stream-error) nil) (define-condition end-of-file (stream-error) nil (:report ("Unexpected end of file: "))) (define-condition file-error (error) ((pathname :initarg :pathname :reader file-error-pathname)) (:report ("File error on ~s: " pathname))) (define-condition pathname-error (file-error) nil) (define-condition package-error (error) ((package :initarg :package :reader package-error-package)) (:report ("Package error on ~s: " package))) (define-condition cell-error (error) ((name :initarg :name :reader cell-error-name)) (:report ("Cell error on ~s: " name))) (define-condition unbound-variable (cell-error) nil (:report ("Unbound variable: "))) (define-condition unbound-slot (cell-error) ((instance :initarg :instance :reader unbound-slot-instance)) (:report ("Slot is unbound in ~s: " instance))) (define-condition undefined-function (cell-error) nil (:report ("Undefined function: "))) (define-condition arithmetic-error (ERROR) ((operation :initarg :operation :reader arithmetic-error-operation) (operands :initarg :operands :reader arithmetic-error-operands)) (:report ("~%Arithmetic error when performing ~s on ~s: " operation operands))) (define-condition division-by-zero (arithmetic-error) nil) (define-condition floating-point-overflow (arithmetic-error) nil) (define-condition floating-point-invalid-operation (arithmetic-error) nil) (define-condition floating-point-inexact (arithmetic-error) nil) (define-condition floating-point-underflow (arithmetic-error) nil) (define-condition case-failure (type-error) ((name :initarg :name :reader case-failure-name) (possibilities :initarg :possibilities :reader case-failure-possibilities)) (:report (lambda (condition stream) (format stream "~s fell through ~s expression.~%wanted one of ~:s." (type-error-datum condition) (case-failure-name condition) (case-failure-possibilities condition))))) (define-condition abort-failure (control-error) nil (:report "abort failed.")) (define-condition internal-condition (condition) ((function-name :initarg :function-name :reader internal-condition-function-name :initform nil)) (:report (lambda (condition stream) (when (internal-condition-function-name condition) (format stream "Condition in ~S [or a callee]: " (internal-condition-function-name condition))) (call-next-method)))) (define-condition internal-simple-condition (internal-condition simple-condition) nil) (define-condition internal-simple-error (internal-condition simple-error) nil) (define-condition internal-simple-type-error (internal-condition simple-type-error) nil) (define-condition internal-simple-warning (internal-condition simple-warning) nil) #.`(progn ,@(mapcar (lambda (x) `(define-condition ,(intern (concatenate 'string "INTERNAL-SIMPLE-" (string x))) (internal-condition simple-condition ,x) nil)) `(stack-overflow storage-exhausted print-not-readable end-of-file style-warning unbound-variable unbound-slot undefined-function division-by-zero case-failure abort-failure ,@(mapcar (lambda (x) (intern (concatenate 'string "FLOATING-POINT-" (string x)))) '(overflow underflow invalid-operation inexact)) ,@(mapcar (lambda (x) (intern (concatenate 'string (string x) "-ERROR"))) '(program control parse stream reader file package cell arithmetic pathname))))) gcl/clcs/gcl_clcs_conditions.lisp000077500000000000000000000057731242227143400174620ustar00rootroot00000000000000;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- ;(in-package "CONDITIONS" :USE '(:cl #+(and clos (not pcl)) "CLOS" #+pcl "PCL")) (in-package :conditions) (defun slot-sym (base slot) (values (intern (concatenate 'string (string base) "-" (string slot))))) (defun coerce-to-fn (x y) (cond ((stringp x) `(lambda (c s) (declare (ignore c)) (write-string ,x s))) ((symbolp x) x) ((atom x) nil) ((eq (car x) 'lambda) x) ((stringp (car x)) `(lambda (c s) (declare (ignorable c)) (call-next-method) (format s ,(car x) ,@(mapcar (lambda (st) `(if (slot-boundp c ',st) (,(slot-sym y st) c) 'unbound)) (cdr x))))))) (defun default-report (x) `(lambda (c s) (call-next-method) (format s "~s " ',x))) (defmacro define-condition (name parent-list slot-specs &rest options) (unless (or parent-list (eq name 'condition)) (setq parent-list (list 'condition))) (let* ((report-function nil) (default-initargs nil) (documentation nil)) (do ((o options (cdr o))) ((null o)) (let ((option (car o))) (case (car option) (:report (setq report-function (coerce-to-fn (cadr option) name))) (:default-initargs (setq default-initargs option)) (:documentation (setq documentation (cadr option))) (otherwise (cerror "ignore this define-condition option." "invalid define-condition option: ~s" option))))) `(progn (eval-when (compile) (setq pcl::*defclass-times* '(compile load eval))) ,(if default-initargs `(defclass ,name ,parent-list ,slot-specs ,default-initargs) `(defclass ,name ,parent-list ,slot-specs)) (eval-when (compile load eval) ; (setf (get ',name 'documentation) ',documentation) (setf (get ',name 'si::s-data) nil)) ,@(when report-function `((defmethod print-object ((x ,name) stream) (if *print-escape* (call-next-method) (,report-function x stream))))) ',name))) (eval-when (compile load eval) (define-condition condition nil nil)) (defmethod pcl::make-load-form ((object condition) &optional env) (declare (ignore env)) (error "~@" 'pcl::make-load-form object)) (mapc 'pcl::proclaim-incompatible-superclasses '((condition pcl::metaobject))) (defun conditionp (object) (typep object 'condition)) (defun is-condition (x) (conditionp x)) (defun is-warning (x) (typep x 'warning)) (defmethod print-object ((x condition) stream) (let ((y (class-name (class-of x)))) (if *print-escape* (format stream "#<~s.~d>" y (unique-id x)) (format stream "~a: " y))));(type-of x) (defun make-condition (type &rest slot-initializations) (when (and (consp type) (eq (car type) 'or)) (return-from make-condition (apply 'make-condition (cadr type) slot-initializations)));FIXME (unless (condition-class-p type) (error 'simple-type-error :datum type :expected-type '(satisfies condition-class-p) :format-control "not a condition type: ~s" :format-arguments (list type))) (apply 'make-instance type slot-initializations)) gcl/clcs/gcl_clcs_handler.lisp000077500000000000000000000027351242227143400167210ustar00rootroot00000000000000;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (in-package :conditions) (defmacro handler-bind (bindings &body forms) (declare (optimize (safety 2))) `(let ((*handler-clusters* (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) bindings)) *handler-clusters*))) ,@forms)) (defmacro handler-case (form &rest cases) (declare (optimize (safety 2))) (let ((no-error-clause (assoc ':no-error cases))) (if no-error-clause (let ((normal-return (gensym)) (error-return (gensym))) `(block ,error-return (multiple-value-call (lambda ,@(cdr no-error-clause)) (block ,normal-return (return-from ,error-return (handler-case (return-from ,normal-return ,form) ,@(remove no-error-clause cases))))))) (let ((block (gensym))(var (gensym))(tcases (mapcar (lambda (x) (cons (gensym) x)) cases))) `(block ,block (let (,var) (declare (ignorable ,var)) (tagbody (handler-bind ,(mapcar (lambda (x &aux (tag (pop x))(type (pop x))(ll (car x))) (list type `(lambda (x) ,(if ll `(setq ,var x) `(declare (ignore x))) (go ,tag)))) tcases) (return-from ,block ,form)) ,@(mapcan (lambda (x &aux (tag (pop x))(type (pop x))(ll (pop x))(body x)) (list tag `(return-from ,block (let ,(when ll `((,(car ll) ,var))) ,@body)))) tcases)))))))) (defmacro ignore-errors (&rest forms) `(handler-case (progn ,@forms) (error (condition) (values nil condition)))) gcl/clcs/gcl_clcs_precom.lisp000077500000000000000000000003241242227143400165610ustar00rootroot00000000000000;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (in-package "CONDITIONS" :USE '("LISP" #+(and clos (not pcl)) "CLOS" #+pcl "PCL")) #+pcl (pcl::precompile-random-code-segments clcs) gcl/clcs/gcl_cmpinit.lsp000066400000000000000000000003301242227143400155540ustar00rootroot00000000000000;(proclaim '(optimize (safety 2) (space 3))) (setq compiler::*eval-when-defaults* '(compile eval load)) (setq compiler::*compile-ordinaries* t) (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) ;;;;; gcl/clcs/loading.lisp000077500000000000000000000012401242227143400150560ustar00rootroot00000000000000(defun jamie-load-clcs (&optional (mode :compiled)) (let ((files (list ;"package" "clcs_precom" "clcs_macros" "clcs_restart" "clcs_handler" "clcs_debugger" "clcs_conditions" "clcs_condition_definitions" "clcs_kcl_cond" "clcs_top_patches" "clcs_install"))) ; (load "package.lisp") (when (eql :compile mode) ; (load "package.lisp") (load "clcs_precom.lisp")) (mapc #'(lambda (file) (ecase mode (:interpreted (load (format nil "~A.lisp" file))) (:compiled (load (format nil "~A.o" file))) (:compile (compile-file (format nil "~A.lisp" file) :c-file t :h-file t :data-file t :system-p t)))) files))) gcl/clcs/makefile000066400000000000000000000023451242227143400142540ustar00rootroot00000000000000-include ../makedefs COMPILE_FILE=./saved_clcs_gcl$(EXE) ./ -system-p -c-file -data-file \ -o-file nil -h-file -compile FILES:=$(shell ls -1 gcl_clcs_*.lisp | sed 's,\.lisp,,1') all: $(addsuffix .c,$(FILES)) $(addsuffix .o,$(FILES)) saved_clcs_gcl: ../unixport/saved_pcl_gcl$(EXE) echo '(load "package.lisp")(load "myload.lisp")(si::save-system "$@")' | $< $(| |top - base| ("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments." internal-simple-control-error) ; || |args| ("FEtoo_many_arguments" :too-many-arguments "~S [or a callee] requires less than ~R argument~:p." internal-simple-control-error) ; || |top - base| ("FEtoo_many_argumentsF" :too-many-arguments "Too many arguments." internal-simple-control-error) ; || |args| ("FEinvalid_macro_call" :invalid-form "Invalid macro call to ~S." internal-simple-program-error) ; || ("FEunexpected_keyword" :unexpected-keyword "~S does not allow the keyword ~S." internal-simple-control-error) ; || |key| ("FEunbound_variable" :unbound-variable "The variable ~S is unbound." internal-unbound-variable :name) ; |sym| ("FEundefined_function" :undefined-function "The function ~S is undefined." internal-undefined-function :name) ("FEinvalid_function" :invalid-function "~S is invalid as a function." internal-simple-program-error) ; |obj| ("check_arg_failed" :too-few-arguments "~S [or a callee] requires ~R argument~:p,~%\ but only ~R ~:*~[were~;was~:;were~] supplied." internal-simple-control-error) ; || |n| |top - base| ("check_arg_failed" :too-many-arguments "~S [or a callee] requires only ~R argument~:p,~%\ but ~R ~:*~[were~;was~:;were~] supplied." internal-simple-control-error) ; || |n| |top - base| ("ck_larg_at_least" :error "APPLY sended too few arguments to LAMBDA." internal-simple-control-error) ("ck_larg_exactly" :error "APPLY sended too few arguments to LAMBDA." internal-simple-control-error) ("keyword_value_mismatch" :error "Keywords and values do not match." internal-simple-error) ;?? ("not_a_keyword" :error "~S is not a keyword." internal-simple-error) ;?? ("illegal_declare" :invalid-form "~S is an illegal declaration form." internal-simple-program-error) ("not_a_symbol" :invalid-variable "~S is not a symbol." internal-simple-error) ;?? ("not_a_variable" :invalid-variable "~S is not a variable." internal-simple-program-error) ("illegal_index" :error "~S is an illegal index to ~S." internal-simple-error) ("vfun_wrong_number_of_args" :error "Expected ~S args but received ~S args" internal-simple-control-error) ("end_of_stream" :error "Unexpected end of ~S." internal-end-of-file :stream) ("open_stream" :error "~S is an illegal IF-DOES-NOT-EXIST option." internal-simple-control-error) ("open_stream" :error "The file ~A already exists." internal-simple-file-error :pathname) ("open_stream" :error "Cannot append to the file ~A." internal-simple-file-error :pathname) ("open_stream" :error "~S is an illegal IF-EXISTS option." internal-simple-control-error) ("close_stream" :error "Cannot close the standard output." internal-simple-stream-error) ; no stream here!! ("close_stream" :error "Cannot close the standard input." internal-simple-stream-error) ; no stream here!! ("too_long_file_name" :error "~S is a too long file name." internal-simple-file-error :pathname) ("cannot_open" :error "Cannot open the file ~A." internal-simple-file-error :pathname) ("cannot_create" :error "Cannot create the file ~A." internal-simple-file-error :pathname) ("cannot_read" :error "Cannot read the stream ~S." internal-simple-stream-error :stream) ("cannot_write" :error "Cannot write to the stream ~S." internal-simple-stream-error :stream) )) (initialize-internal-error-table) (defun condition-backtrace (condition) (let* ((*debug-io* *error-output*) (si::*ihs-base* (1+ si::*ihs-top*)) (si::*ihs-top* (1- (si::ihs-top))) (si::*current-ihs* si::*ihs-top*) (si::*frs-base* (or (si::sch-frs-base si::*frs-top* si::*ihs-base*) (1+ (si::frs-top)))) (si::*frs-top* (si::frs-top)) (si::*break-env* nil)) (format *error-output* "~%~A~%" condition) (si::simple-backtrace))) (defvar *error-set-break-p* nil) (defun clcs-error-set (form) (let ((cond nil)) (restart-case (handler-bind ((error #'(lambda (condition) (unless (or si::*break-enable* *error-set-break-p*) (condition-backtrace condition) (return-from clcs-error-set condition)) (setq cond condition) nil))) (values-list (cons nil (multiple-value-list (eval form))))) (si::error-set () :report (lambda (stream) (format stream "~S" `(si::error-set ',form))) cond)))) (eval-when (compile load eval) (defun reset-function (symbol) ; invoke compiler::compiler-clear-compiler-properties (setf (symbol-function symbol) (symbol-function symbol))) (reset-function 'si::error-set) (reset-function 'load) (reset-function 'open) ) (setq compiler::*compiler-break-enable* t) (defun compiler::cmp-toplevel-eval (form) (let* (;;(si::*ihs-base* si::*ihs-top*) ; show the whole stack (si::*ihs-top* (1- (si::ihs-top))) (*break-enable* compiler::*compiler-break-enable*) (si::*break-hidden-packages* (cons (find-package 'compiler) si::*break-hidden-packages*))) (si:error-set form))) gcl/clcs/unused/test2.lisp000077500000000000000000000030551242227143400160130ustar00rootroot00000000000000(in-package "conditions") (define-condition internal-unbound-variable (#+(or clos pcl) internal-error unbound-variable) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-unbound-variable-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) #-(or pcl clos) (defun internal-error-function-name (condition) (etypecase condition (internal-error (%%internal-simple-error-function-name condition)) (internal-simple-error (%%internal-simple-error-function-name condition)) (internal-type-error (%%internal-type-error-function-name condition)) (internal-simple-program-error (%%internal-simple-program-error-function-name condition)) (internal-simple-control-error (%%internal-simple-control-error-function-name condition)) (internal-unbound-variable (%%internal-unbound-variable-function-name condition)) (internal-undefined-function (%%internal-undefined-function-function-name condition)) (internal-end-of-file (%%internal-end-of-file-function-name condition)) (internal-simple-file-error (%%internal-simple-file-error-function-name condition)) (internal-simple-stream-error (%%internal-simple-stream-error-function-name condition)))) gcl/clcs/unused/test3.lisp000077500000000000000000000072761242227143400160250ustar00rootroot00000000000000(IN-PACKAGE "CONDITIONS") (define-condition internal-simple-error (internal-error #+(or clos pcl) simple-condition) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-error-) (:report internal-simple-error-printer)) (define-condition internal-type-error (#+(or clos pcl) internal-error type-error) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-type-error-) #-(or clos pcl)(:report (lambda (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (format stream "~S is not of type ~S." (type-error-datum condition) (type-error-expected-type condition))))) (define-condition internal-simple-program-error (#+(or clos pcl) internal-simple-error program-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-program-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-simple-control-error (#+(or clos pcl) internal-simple-error control-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-control-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-unbound-variable (#+(or clos pcl) internal-error unbound-variable) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-unbound-variable-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) (define-condition internal-undefined-function (#+(or clos pcl) internal-error undefined-function) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-undefined-function-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The function ~S is undefined." (CELL-ERROR-NAME CONDITION))))) (define-condition internal-end-of-file (#+(or clos pcl) internal-error end-of-file) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-end-of-file-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "Unexpected end of file on ~S." (STREAM-ERROR-STREAM CONDITION))))) (define-condition internal-simple-file-error (#+(or clos pcl) internal-simple-error file-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-file-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-simple-stream-error (#+(or clos pcl) internal-simple-error stream-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-stream-error-) #-(or clos pcl)(:report internal-simple-error-printer)) gcl/clcs/unused/test4.lisp000077500000000000000000000010521242227143400160100ustar00rootroot00000000000000(IN-PACKAGE "CONDITIONS") (define-condition internal-unbound-variable (#+(or clos pcl) internal-error unbound-variable) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-unbound-variable-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) gcl/clcs/unused/test5.lisp000077500000000000000000000261651242227143400160250ustar00rootroot00000000000000;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (IN-PACKAGE "CONDITIONS") (eval-when (compile load eval) (pushnew #+(or clos pcl) :clos-conditions #-(or clos pcl) :defstruct-conditions *features*) ) (eval-when (compile load eval) (when (and (member :clos-conditions *features*) (member :defstruct-conditions *features*)) (dolist (sym '(simple-condition-format-string simple-condition-format-arguments type-error-datum type-error-expected-type case-failure-name case-failure-possibilities stream-error-stream file-error-pathname package-error-package cell-error-name arithmetic-error-operation internal-error-function-name)) (when (fboundp sym) (fmakunbound sym))) (setq *features* (remove :defstruct-conditions *features*))) ) ;;; Start (DEFINE-CONDITION WARNING (CONDITION) ()) (DEFINE-CONDITION SERIOUS-CONDITION (CONDITION) ()) (DEFINE-CONDITION lisp:ERROR (SERIOUS-CONDITION) ()) (DEFUN SIMPLE-CONDITION-PRINTER (CONDITION STREAM) (APPLY #'FORMAT STREAM (SIMPLE-CONDITION-FORMAT-STRING CONDITION) (SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION))) (DEFINE-CONDITION SIMPLE-CONDITION (CONDITION) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) ((FORMAT-STRING :type string :initarg :FORMAT-STRING :reader SIMPLE-CONDITION-FORMAT-STRING) (FORMAT-ARGUMENTS :initarg :FORMAT-ARGUMENTS :reader SIMPLE-CONDITION-FORMAT-ARGUMENTS :initform '())) #-(or clos pcl)(:CONC-NAME %%SIMPLE-CONDITION-) (:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION SIMPLE-WARNING (#+(or clos pcl) SIMPLE-CONDITION WARNING) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) () #-(or clos pcl)(:CONC-NAME %%SIMPLE-WARNING-) #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION SIMPLE-ERROR (#+(or clos pcl) SIMPLE-CONDITION lisp:ERROR) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) () #-(or clos pcl)(:CONC-NAME %%SIMPLE-ERROR-) #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION STORAGE-CONDITION (SERIOUS-CONDITION) ()) (DEFINE-CONDITION STACK-OVERFLOW (STORAGE-CONDITION) ()) (DEFINE-CONDITION STORAGE-EXHAUSTED (STORAGE-CONDITION) ()) (DEFINE-CONDITION TYPE-ERROR (lisp:ERROR) #-(or clos pcl) (DATUM EXPECTED-TYPE) #+(or clos pcl) ((DATUM :initarg :DATUM :reader TYPE-ERROR-DATUM) (EXPECTED-TYPE :initarg :EXPECTED-TYPE :reader TYPE-ERROR-EXPECTED-TYPE)) (:report (lambda (condition stream) (format stream "~S is not of type ~S." (TYPE-ERROR-DATUM CONDITION) (TYPE-ERROR-EXPECTED-TYPE CONDITION))))) (DEFINE-CONDITION SIMPLE-TYPE-ERROR (#+(or clos pcl) SIMPLE-CONDITION TYPE-ERROR) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) () #-(or clos pcl)(:CONC-NAME %%SIMPLE-TYPE-ERROR-) #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION CASE-FAILURE (TYPE-ERROR) #-(or clos pcl) (NAME POSSIBILITIES) #+(or clos pcl) ((NAME :initarg :NAME :reader CASE-FAILURE-NAME) (POSSIBILITIES :initarg :POSSIBILITIES :reader CASE-FAILURE-POSSIBILITIES)) (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "~S fell through ~S expression.~%Wanted one of ~:S." (TYPE-ERROR-DATUM CONDITION) (CASE-FAILURE-NAME CONDITION) (CASE-FAILURE-POSSIBILITIES CONDITION))))) (DEFINE-CONDITION PROGRAM-ERROR (lisp:ERROR) ()) (DEFINE-CONDITION CONTROL-ERROR (lisp:ERROR) ()) (DEFINE-CONDITION STREAM-ERROR (lisp:ERROR) #-(or clos pcl) (STREAM) #+(or clos pcl) ((STREAM :initarg :STREAM :reader STREAM-ERROR-STREAM))) (DEFINE-CONDITION END-OF-FILE (STREAM-ERROR) () (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "Unexpected end of file on ~S." (STREAM-ERROR-STREAM CONDITION))))) (DEFINE-CONDITION FILE-ERROR (lisp:ERROR) #-(or clos pcl) (PATHNAME) #+(or clos pcl) ((PATHNAME :initarg :PATHNAME :reader FILE-ERROR-PATHNAME))) (DEFINE-CONDITION PACKAGE-ERROR (lisp:ERROR) #-(or clos pcl) (PACKAGE) #+(or clos pcl) ((PACKAGE :initarg :PACKAGE :reader PACKAGE-ERROR-PACKAGE))) (DEFINE-CONDITION CELL-ERROR (lisp:ERROR) #-(or clos pcl) (NAME) #+(or clos pcl) ((NAME :initarg :NAME :reader CELL-ERROR-NAME))) (DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR) () (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "The function ~S is undefined." (CELL-ERROR-NAME CONDITION))))) (DEFINE-CONDITION ARITHMETIC-ERROR (lisp:ERROR) #-(or clos pcl) (OPERATION OPERANDS) #+(or clos pcl) ((OPERATION :initarg :OPERATION :reader ARITHMETIC-ERROR-OPERATION))) (DEFINE-CONDITION DIVISION-BY-ZERO (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION FLOATING-POINT-OVERFLOW (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION ABORT-FAILURE (CONTROL-ERROR) () (:REPORT "Abort failed.")) #+kcl (progn ;;; When this form is present, the compiled behavior disagrees with ;;; the interpreted behavior. The interpreted behavior is correct. (define-condition internal-error (lisp:error) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) ((function-name :initarg :function-name :reader internal-error-function-name :initform 'nil)) (:report (lambda (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) #+(or clos pcl)(call-next-method)))) (defun internal-simple-error-printer (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (apply #'format stream (simple-condition-format-string condition) (simple-condition-format-arguments condition))) (define-condition internal-simple-error (internal-error #+(or clos pcl) simple-condition) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-error-) (:report internal-simple-error-printer)) (define-condition internal-type-error (#+(or clos pcl) internal-error type-error) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-type-error-) #-(or clos pcl)(:report (lambda (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (format stream "~S is not of type ~S." (type-error-datum condition) (type-error-expected-type condition))))) (define-condition internal-simple-program-error (#+(or clos pcl) internal-simple-error program-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-program-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-simple-control-error (#+(or clos pcl) internal-simple-error control-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-control-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-unbound-variable (#+(or clos pcl) internal-error unbound-variable) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-unbound-variable-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) #-(or pcl clos) (defun internal-error-function-name (condition) (etypecase condition (internal-error (%%internal-error-function-name condition)) (internal-simple-error (%%internal-simple-error-function-name condition)) (internal-type-error (%%internal-type-error-function-name condition)) (internal-simple-program-error (%%internal-simple-program-error-function-name condition)) (internal-simple-control-error (%%internal-simple-control-error-function-name condition)) (internal-unbound-variable (%%internal-unbound-variable-function-name condition)) (internal-undefined-function (%%internal-undefined-function-function-name condition)) (internal-end-of-file (%%internal-end-of-file-function-name condition)) (internal-simple-file-error (%%internal-simple-file-error-function-name condition)) (internal-simple-stream-error (%%internal-simple-stream-error-function-name condition)))) ) #-(or clos pcl) (progn (DEFUN SIMPLE-CONDITION-FORMAT-STRING (CONDITION) (ETYPECASE CONDITION (SIMPLE-CONDITION (%%SIMPLE-CONDITION-FORMAT-STRING CONDITION)) (SIMPLE-WARNING (%%SIMPLE-WARNING-FORMAT-STRING CONDITION)) (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-STRING CONDITION)) (SIMPLE-ERROR (%%SIMPLE-ERROR-FORMAT-STRING CONDITION)) #+kcl(internal-simple-error (%%internal-simple-error-format-string condition)) #+kcl(internal-simple-program-error (%%internal-simple-program-error-format-string condition)) #+kcl(internal-simple-control-error (%%internal-simple-control-error-format-string condition)) #+kcl(internal-simple-file-error (%%internal-simple-file-error-format-string condition)) #+kcl(internal-simple-stream-error (%%internal-simple-stream-error-format-string condition)))) (DEFUN SIMPLE-CONDITION-FORMAT-ARGUMENTS (CONDITION) (ETYPECASE CONDITION (SIMPLE-CONDITION (%%SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-WARNING (%%SIMPLE-WARNING-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-ERROR (%%SIMPLE-ERROR-FORMAT-ARGUMENTS CONDITION)) #+kcl(internal-simple-error (%%internal-simple-error-format-arguments condition)) #+kcl(internal-simple-program-error (%%internal-simple-program-error-format-arguments condition)) #+kcl(internal-simple-control-error (%%internal-simple-control-error-format-arguments condition)) #+kcl(internal-simple-file-error (%%internal-simple-file-error-format-arguments condition)) #+kcl(internal-simple-stream-error (%%internal-simple-stream-error-format-arguments condition)))) (defun simple-condition-class-p (type) (member type '(SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-TYPE-ERROR SIMPLE-ERROR #+kcl internal-simple-error #+kcl internal-simple-program-error #+kcl internal-simple-control-error #+kcl internal-simple-file-error #+kcl internal-simple-stream-error))) ) #+(or clos pcl) (progn (defvar *simple-condition-class* (find-class 'simple-condition)) (defun simple-condition-class-p (TYPE) (when (symbolp TYPE) (setq TYPE (find-class TYPE))) (and (typep TYPE 'standard-class) (member *simple-condition-class* (#+pcl pcl::class-precedence-list #-pcl clos::class-precedence-list type)))) ) gcl/clcs/unused/tester.lisp000077500000000000000000000005661242227143400162640ustar00rootroot00000000000000(in-package "conditions") (defun compare-semantics (file condition) (let ((results)) (load (format nil "~A.lisp" file)) (push (with-output-to-string (s) (princ condition s)) results) (compile-file (format nil "~A.lisp" file)) (load (format nil "~A.o" file)) (push (with-output-to-string (s) (princ condition s)) results) (print (reverse results)) (values)))gcl/cmpnew/000077500000000000000000000000001242227143400131155ustar00rootroot00000000000000gcl/cmpnew/gcl_cmpbind.lsp000077500000000000000000000105521242227143400161040ustar00rootroot00000000000000;;; CMPBIND Variable Binding. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (si:putprop 'bds-bind 'set-bds-bind 'set-loc) ;;; Those functions that call the following binding functions should ;;; rebind the special variables, ;;; *vs*, *clink*, *ccb-vs*, and *unwind-exit*. (defun c2bind (var) (case (var-kind var) (LEXICAL (when (var-ref-ccb var) (wt-nl) (wt-vs (var-ref var)) (wt "=MMcons(") (wt-vs (var-ref var)) (wt ",") (wt-clink) (wt ");") (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push)))) (SPECIAL (wt-nl "bds_bind(" (vv-str (var-loc var)) ",") (wt-vs (var-ref var)) (wt ");") (push 'bds-bind *unwind-exit*)) (DOWN (cond ((integerp (var-loc var)) (wt-nl "base0[" (var-loc var) "]=") (wt-vs (var-ref var)) (wt ";")) (t (wfs-error)))) (INTEGER (wt-nl "SETQ_IO(V" (var-loc var)"," "V" (var-loc var)"alloc,") (wt "(") (wt-vs (var-ref var)) (wt "),") (wt (bignum-expansion-storage) ");")) (t (wt-nl "V" (var-loc var) "=") (case (var-kind var) (OBJECT) (FIXNUM (wt "fix")) (CHARACTER (wt "char_code")) (LONG-FLOAT (wt "lf")) (SHORT-FLOAT (wt "sf")) (t (baboon))) (wt "(") (wt-vs (var-ref var)) (wt ");"))) ) (defun c2bind-loc (var loc) (case (var-kind var) (LEXICAL (cond ((var-ref-ccb var) (wt-nl) (wt-vs (var-ref var)) (wt "=MMcons(" loc ",") (wt-clink) (wt ");") (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push))) (t (wt-nl) (wt-vs (var-ref var)) (wt "= " loc ";")))) (SPECIAL (wt-nl "bds_bind(" (vv-str (var-loc var)) "," loc ");") (push 'bds-bind *unwind-exit*)) (DOWN (wt-nl "base0[" (var-loc var) "]=" loc ";")) (INTEGER (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*)) (save-avma '(nil integer)) (wt-nl "V" (var-loc var) "= ") (wt-integer-loc loc var) (wt ";") (close-inline-blocks))) (t (wt-nl "V" (var-loc var) "= ") (case (var-kind var) (OBJECT (wt-loc loc)) (FIXNUM (wt-fixnum-loc loc)) (CHARACTER (wt-character-loc loc)) (LONG-FLOAT (wt-long-float-loc loc)) (SHORT-FLOAT (wt-short-float-loc loc)) (t (baboon))) (wt ";"))) ) (defun c2bind-init (var init) (case (var-kind var) (LEXICAL (cond ((var-ref-ccb var) (let ((loc (list 'vs (var-ref var)))) (let ((*value-to-go* loc)) (c2expr* init)) (wt-nl loc "=MMcons(" loc ",") (wt-clink *clink*) (wt ");")) (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push))) (t (let ((*value-to-go* (list 'vs (var-ref var)))) (c2expr* init))))) (SPECIAL (let ((*value-to-go* (list 'bds-bind (var-loc var)))) (c2expr* init)) (push 'bds-bind *unwind-exit*)) (DOWN (let ((*value-to-go* (list 'down (var-loc var)))) (c2expr* init))) ((OBJECT FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER) (let ((*value-to-go* (list 'var var nil))) (c2expr* init))) (t (baboon))) ) (defun set-bds-bind (loc vv) (wt-nl "bds_bind(" (vv-str vv) "," loc ");")) gcl/cmpnew/gcl_cmpblock.lsp000077500000000000000000000137541242227143400162710ustar00rootroot00000000000000;;; CMPBLOCK Block and Return-from. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (si:putprop 'block 'c1block 'c1special) (si:putprop 'block 'c2block 'c2) (si:putprop 'return-from 'c1return-from 'c1special) (si:putprop 'return-from 'c2return-from 'c2) (defstruct blk name ;;; Block name. ref ;;; Referenced or not. T or NIL. ref-clb ;;; Cross local function reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the vs-address for the ;;; block id, or NIL. ref-ccb ;;; Cross closure reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the ccb-vs for the ;;; block id, or NIL. exit ;;; Where to return. A label. value-to-go ;;; Where the value of the block to go. var ;;; The block name holder. Used only in ;;; the error message. ) (defvar *blocks* nil) ;;; During Pass 1, *blocks* holds a list of blk objects and the symbols 'CB' ;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on ;;; *blocks* when the compiler begins to process a closure. 'LB' will be ;;; pushed on *blocks* when *level* is incremented. (defun c1block (args) (when (endp args) (too-few-args 'block 1 0)) (cmpck (not (symbolp (car args))) "The block name ~s is not a symbol." (car args)) (let* ((blk (make-blk :name (car args) :ref nil :ref-ccb nil :ref-clb nil)) (*blocks* (cons blk *blocks*)) (body (c1progn (cdr args)))) (if (or (blk-ref-ccb blk) (blk-ref-clb blk)) (incf *setjmps*)) (if (or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk)) (list 'block (reset-info-type (cadr body)) blk body) body)) ) (defun c2block (blk body) (cond ((blk-ref-ccb blk) (c2block-ccb blk body)) ((blk-ref-clb blk) (c2block-clb blk body)) (t (c2block-local blk body)))) (defun c2block-local (blk body) (setf (blk-exit blk) *exit*) (setf (blk-value-to-go blk) *value-to-go*) (c2expr body) ) (defun c2block-clb (blk body &aux (*vs* *vs*)) (setf (blk-exit blk) *exit*) (setf (blk-value-to-go blk) *value-to-go*) (setf (blk-ref-clb blk) (vs-push)) (wt-nl) (wt-vs (blk-ref-clb blk)) (wt "=alloc_frame_id();") (wt-nl "frs_push(FRS_CATCH,") (wt-vs (blk-ref-clb blk)) (wt ");") (wt-nl "if(nlj_active)") (wt-nl "{nlj_active=FALSE;frs_pop();") (unwind-exit 'fun-val 'jump) (wt "}") (wt-nl "else{") (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body)) (wt-nl "}") ) (defun c2block-ccb (blk body &aux (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (setf (blk-exit blk) *exit*) (setf (blk-value-to-go blk) *value-to-go*) (setf (blk-ref-clb blk) (vs-push)) (setf (blk-var blk) (add-symbol (blk-name blk))) (wt-nl) (wt-vs (blk-ref-clb blk)) (wt "=alloc_frame_id();") (wt-nl) (wt-vs (blk-ref-clb blk)) (wt "=MMcons(") (wt-vs (blk-ref-clb blk)) (wt ",") (wt-clink) (wt ");") (clink (blk-ref-clb blk)) (setf (blk-ref-ccb blk) (ccb-vs-push)) (wt-nl "frs_push(FRS_CATCH,") (wt-vs* (blk-ref-clb blk)) (wt ");") (wt-nl "if(nlj_active)") (wt-nl "{nlj_active=FALSE;frs_pop();") (unwind-exit 'fun-val 'jump) (wt "}") (wt-nl "else{") (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body)) (wt-nl "}") ) (defun c1return-from (args) (cond ((endp args) (too-few-args 'return-from 1 0)) ((and (not (endp (cdr args))) (not (endp (cddr args)))) (too-many-args 'return-from 2 (length args))) ((not (symbolp (car args))) "The block name ~s is not a symbol." (car args))) (do ((blks *blocks* (cdr blks)) (name (car args)) (ccb nil) (clb nil)) ((endp blks) (cmperr "The block ~s is undefined." name)) (declare (object name ccb clb)) (case (car blks) (cb (setq ccb t)) (lb (setq clb t)) (t (when (eq (blk-name (car blks)) name) (let ((val (c1expr (cadr args))) (blk (car blks))) (cond (ccb (setf (blk-ref-ccb blk) t)) (clb (setf (blk-ref-clb blk) t)) (t (setf (blk-ref blk) t))) (return (list 'return-from (reset-info-type (cadr val)) blk clb ccb val))))))) ) (defun c2return-from (blk clb ccb val) (cond (ccb (c2return-ccb blk val)) (clb (c2return-clb blk val)) (t (c2return-local blk val)))) (defun c2return-local (blk val) (let ((*value-to-go* (blk-value-to-go blk)) (*exit* (blk-exit blk))) (c2expr val)) ) (defun c2return-clb (blk val) (let ((*value-to-go* 'top)) (c2expr* val)) (wt-nl "unwind(frs_sch(") (if (blk-ref-ccb blk) (wt-vs* (blk-ref-clb blk)) (wt-vs (blk-ref-clb blk))) (wt "),Cnil);") ) (defun c2return-ccb (blk val) (wt-nl "{frame_ptr fr;") (wt-nl "fr=frs_sch(") (wt-ccb-vs (blk-ref-ccb blk)) (wt ");") (wt-nl "if(fr==NULL) FEerror(\"The block ~s is missing.\",1," (vv-str (blk-var blk)) ");") (let ((*value-to-go* 'top)) (c2expr* val)) (wt-nl "unwind(fr,Cnil);}") ) gcl/cmpnew/gcl_cmpcall.lsp000077500000000000000000000510241242227143400161020ustar00rootroot00000000000000;;; CMPCALL Function call. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (defvar *ifuncall* nil) (eval-when (compile eval) (defmacro link-arg-p (x) `(let ((.u ,x)) (not (member .u '(character boolean long-float short-float))))) ) (defun fast-link-proclaimed-type-p (fname &optional args) (and (symbolp fname) (and (< (the fixnum(length args)) 64) (or (and (get fname 'fixed-args) (listp args)) (and (get fname 'proclaimed-function) (link-arg-p (get fname 'proclaimed-return-type)) (dolist (v (get fname 'proclaimed-arg-types) t) (or (eq v '*)(link-arg-p v) (return nil)))))))) (si::putprop 'funcall 'c2funcall-aux 'wholec2) (si:putprop 'call-lambda 'c2call-lambda 'c2) (si:putprop 'call-global 'c2call-global 'c2) ;;Like macro-function except it searches the lexical environment, ;;to determine if the macro is shadowed by a function or a macro. (defun cmp-macro-function (name &aux fd) (cond ((setq fd (c1local-fun name)) (if (eq (car fd) 'call-local) nil fd)) (t (macro-function name)))) (defun c1funob (fun &aux fd) ;;; NARGS is the number of arguments. If the number is unknown, (e.g. ;;; in case of APPLY), then NARGS should be NIL. (cond ((and (consp fun) (symbolp (car fun)) (cmp-macro-function (car fun))) (setq fun (cmp-macroexpand fun)))) (or (and (consp fun) (or (and (eq (car fun) 'quote) (not (endp (cdr fun))) (endp (cddr fun)) (or (and (consp (cadr fun)) (not (endp (cdadr fun))) (eq (caadr fun) 'lambda) (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil)) (let ((lambda-expr (c1lambda-expr (cdadr fun)))) (list 'call-lambda (cadr lambda-expr) lambda-expr)))) (and (symbolp (cadr fun)) (or (and (setq fd (c1local-fun (cadr fun))) (eq (car fd) 'call-local) fd) (list 'call-global (make-info :sp-change (null (get (cadr fun) 'no-sp-change))) (cadr fun))) ))) (and (eq (car fun) 'function) (not (endp (cdr fun))) (endp (cddr fun)) (or (and (consp (cadr fun)) (eq (caadr fun) 'lambda) (not (endp (cdadr fun))) (let ((lambda-expr (c1lambda-expr (cdadr fun)))) (list 'call-lambda (cadr lambda-expr) lambda-expr)) ) (and (symbolp (cadr fun)) (or (and (setq fd (c1local-fun (cadr fun))) (eq (car fd) 'call-local) fd) (list 'call-global (make-info :sp-change (null (get (cadr fun) 'no-sp-change))) (cadr fun))) ))))) (let ((x (c1expr fun)) (info (make-info :sp-change t))) (add-info info (cadr x)) (list 'ordinary info x)) )) (defun c2funcall-aux(form &aux (info (cadr form)) (funob (caddr form)) (args (cadddr form)) (loc (nth 4 form))) (c2funcall funob args loc info)) (defvar *use-sfuncall* t) (defvar *super-funcall* nil) (defun c2funcall (funob args &optional loc info) ;;; Usually, ARGS holds a list of forms, which are arguments to the ;;; function. If, however, the arguments are already pushed on the stack, ;;; ARGS should be set to the symbol ARGS-PUSHED. (case (car funob) (call-global (c2call-global (caddr funob) args loc t)) (call-local (c2call-local (cddr funob) args)) (call-lambda (c2call-lambda (caddr funob) args)) (ordinary ;;; An ordinary expression. In this case, if ;;; arguments are already pushed on the stack, then ;;; LOC cannot be NIL. Callers of C2FUNCALL must be ;;; responsible for maintaining this condition. (let ((*vs* *vs*) (form (caddr funob))) (declare (object form)) (cond ((and (listp args) *use-sfuncall* ;;Determine if only one value at most is required: (or (member *value-to-go* '(return-object trash)) (and (consp *value-to-go*) (member (car *value-to-go*) '(var cvar jump-false jump-true))) (and info (equal (info-type info) '(values t))) )) (c2funcall-sfun form args info) (return-from c2funcall nil))) (unless loc (unless (listp args) (baboon)) (cond ((eq (car form) 'LOCATION) (setq loc (caddr form))) ((and (eq (car form) 'VAR) (not (args-info-changed-vars (caaddr form) args))) (setq loc (cons 'VAR (caddr form)))) (t (setq loc (list 'vs (vs-push))) (let ((*value-to-go* loc)) (c2expr* (caddr funob)))))) (push-args args) (if *compiler-push-events* (wt-nl "super_funcall(" loc ");") (if *super-funcall* (funcall *super-funcall* loc) (wt-nl "super_funcall_no_event(" loc ");"))) (unwind-exit 'fun-val))) (otherwise (baboon)) )) (defun fcalln-inline (&rest args) (wt-nl "({object _f=" (car args) ";enum type _t=type_of(_f);") (wt-nl "_f = _t==t_symbol && _f->s.s_gfdef!=OBJNULL ? (_t=type_of(_f->s.s_gfdef),_f->s.s_gfdef) : _f;") (wt-nl "_t==t_sfun ? _f->sfn.sfn_self : ") (wt-nl "(fcall.argd= " (length (cdr args)) ",_t==t_vfun ? _f->vfn.vfn_self : ") (wt-nl "(fcall.fun=_f,fcalln));})") (wt-nl "(") (when (cdr args) (wt (cadr args)) (dolist (loc (cddr args)) (wt #\, loc))) (wt-nl ")")) (defun c2call-lambda (lambda-expr args &aux (lambda-list (caddr lambda-expr))) (declare (object lambda-list)) (cond ((or (cadr lambda-list) ;;; Has optional? (caddr lambda-list) ;;; Has rest? (cadddr lambda-list) ;;; Has key? (not (listp args)) ;;; Args already pushed? ) (when (listp args) ;;; Args already pushed? (let ((*vs* *vs*) (base *vs*)) (push-args-lispcall args) (when (need-to-set-vs-pointers lambda-list) (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";") (base-used) ))) (c2lambda-expr lambda-list (caddr (cddr lambda-expr))) ) (t (let ((l-length (length (car lambda-list))) (a-length (length args))) (or (eql a-length l-length) (cmperr "Calling lambda with ~a args not ~a" a-length l-length))) (c2let (car lambda-list) args (caddr (cddr lambda-expr))))) ) (defun check-fname-args (fname args) (let ((a (get fname 'arg-types t))) (and (eq t a) (get fname 'si::structure-access) (setq a '(t))) (cond ((and (listp a) (listp args) (not (member '* a))) (or (eql (length a) (length args)) (cmpwarn "Wrong number of args for ~s: ~a instead of ~a." fname (length args) (length a))))))) (defun save-avma (fd) (when (and (not *restore-avma*) (setq *restore-avma* (or (member 'integer (car fd)) (eq (cadr fd) 'integer) (flag-p (caddr fd) is)))) (wt-nl "{ save_avma;") (inc-inline-blocks) (or (consp *inline-blocks*) (setq *inline-blocks* (cons *inline-blocks* 'restore-avma))))) (defun c2call-global (fname args loc return-type &aux fd (*vs* *vs*)) ;this is now done in get-inline-info ; (and *Fast-link-compiling* (fast-link-proclaimed-type-p fname args) ; (add-fast-link fname t args)) (if (inline-possible fname) (cond ;;; Tail-recursive case. ((and (listp args) *do-tail-recursion* *tail-recursion-info* (eq (car *tail-recursion-info*) fname) (member *exit* '(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SHORT-FLOAT RETURN-LONG-FLOAT RETURN-OBJECT)) (tail-recursion-possible) (= (length args) (length (cdr *tail-recursion-info*)))) (let* ((*value-to-go* 'trash) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2psetq (mapcar #'(lambda (v) (list v nil)) (cdr *tail-recursion-info*)) args) (wt-label *exit*)) (unwind-no-exit 'tail-recursion-mark) (wt-nl "goto TTL;") (cmpnote "Tail-recursive call of ~s was replaced by iteration." fname)) ;;; Open-codable function call. ((and (listp args) (null loc) (setq fd (get-inline-info fname args return-type))) (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*)) (save-avma fd) (unwind-exit (get-inline-loc fd args) nil fname) (close-inline-blocks))) ;;; Call to a function whose C language function name is known. ((setq fd (or (get fname 'Lfun) (get fname 'Ufun))) (check-fname-args fname args) (push-args args) (wt-h "void " fd "();") (wt-nl fd "();") (unwind-exit 'fun-val nil fname) ) ( t; *Fast-link-compiling* (cond ((and (listp args) (< (the fixnum (length args)) 10) (or *ifuncall* (get fname 'ifuncall)) (progn (if (eq *value-to-go* 'top) (format t "~%Called with top:~a" fname)) t) (not (eq 'top *value-to-go*)) (null loc) ) (let ((*inline-blocks* 0)) (unwind-exit (get-inline-loc (inline-proc fname args) args) nil fname) (close-inline-blocks))) (t (push-args args) (let ((num (add-fast-link fname nil args))) (wt-nl "(void) (*Lnk" num ")(") (if (get fname 'proclaimed-closure) (wt "Lclptr" num)) (wt ");") (unwind-exit 'fun-val nil fname))))) ;;; Call to a function defined in the same file. ((setq fd (assoc fname *global-funs*)) (push-args args) (wt-nl (c-function-name "L" (cdr fd) fname) "();") (unwind-exit 'fun-val nil fname) ) ((eql fname 'funcall-c) (wt-funcall-c args)) ;;; Otherwise. (t (c2call-unknown-global fname args loc t))) (c2call-unknown-global fname args loc nil)) ) (defun add-fast-link (fname type args) (let (link link-info (n (add-object2 (add-symbol fname))) vararg) (cond (type ;;should do some args checking in that case too. (let* (link-string tem argtypes (leng (and (listp args) (length args)))) (setq argtypes (cond ((get fname 'proclaimed-function) (get fname 'proclaimed-arg-types)) ((setq tem (get fname ' fixed-args)) (cond ((si:fixnump tem) (or (equal leng tem) (cmpwarn "~a: Fixed args not fixed!" fname))) (t (setf (get fname 'fixed-args) leng))) (make-list leng :initial-element t)))) (and leng (or (eql leng (length argtypes)) (MEMBER '* ARGTYPES) (cmpwarn "~a called with ~a args, expected ~a " fname leng (length argtypes)))) (unless (cddr (setq link-info (car (member-if (lambda (x) (and (eq fname (car x)) (stringp (cadr x)))) *function-links*)))) (setq link-string (with-output-to-string (st) (format st "(*(LnkLI~d))(" n) (do ((com) (v argtypes (cdr v)) (i 0 (+ 1 i))) ((null v)) (cond ((eq (car v) '*) (setq vararg t) (princ (if (eq v argtypes) "#?" "#*") st)) (t (if com (princ "," st) (setq com t)) (format st "#~a" i)))) (princ ")" st) ) ) ; (print (list 'link-string link-string)) ; (format t "~{~a~#[~:;,~]~}" '(1 2 3 4)) ; 1,2,3,4 (if vararg (setq link #'(lambda ( &rest l) (wt "(VFUN_NARGS="(length l) ",") (wt-inline-loc link-string l) (wt ")")))) (push (list fname argtypes (or (get fname 'proclaimed-return-type) t) (flags side-effect-p allocates-new-storage) (or link link-string) 'link-call) *inline-functions*) (setq link-info (list fname (format nil "LI~d" n) (or (get fname 'proclaimed-return-type) t) argtypes))))) (t (check-fname-args fname args) (setq link-info (list fname n (if (get fname 'proclaimed-closure) 'proclaimed-closure) )))) (pushnew link-info *function-links* :test 'equal) n)) ;;make a function which will be called hopefully only once, ;;and will establish the link. (defun wt-function-link (x) (let ((name (first x)) (num (second x)) (type (third x)) (args (fourth x))) (cond ((null type) (wt-nl1 "static void LnkT" num "(){ call_or_link(VV[" num "],(void **)(void *)&Lnk" num");}")) ((eql type 'proclaimed-closure) (wt-nl1 "static void LnkT" num "(ptr) object *ptr;{ call_or_link_closure(VV[" num "],(void **)(void *)&Lnk" num",(void **)(void *)&Lclptr" num");}")) (t ;;change later to include above. ;;(setq type (cdr (assoc type '((t . "object")(:btpr . "bptr"))))) (wt-nl1 "static " (declaration-type (rep-type type)) " LnkT" num ) (cond ((or args (not (eq t type))) (let ((vararg (member '* args))) (wt "(object first,...){" (declaration-type (rep-type type)) "V1;" "va_list ap;va_start(ap,first);V1=call_" (if vararg "v" "") "proc_new(" (vv-str (add-object name)) ",(void **)(void *)&Lnk" num) (or vararg (wt "," (proclaimed-argd args type))) (wt ",first,ap);va_end(ap);return V1;}" ))) (t (wt "(){return call_proc0(" (vv-str (add-object name)) ",(void **)(void *)&Lnk" num ");}" )))) (t (error "unknown link type ~a" type))) (setq name (symbol-name name)) (if (find #\/ name) (setq name (remove #\/ name))) (wt " /* " name " */") )) ;;For funcalling when the argument is guaranteed to be a compiled-function. ;;For (funcall-c he 3 4), he being a compiled function. (not a symbol)! (defun wt-funcall-c (args) (let ((fun (car args)) (real-args (cdr args)) loc) (cond ((eql (car fun) 'var) (let ((fun-loc (cons (car fun) (third fun)))) (when *safe-compile* (wt-nl "(type_of(") (wt-loc fun-loc) (wt ")==t_cfun)||FEinvalid_function(") (wt-loc fun-loc)(wt ");")) (push-args real-args) (wt-nl "(") (wt-loc fun-loc))) (t (setq loc (list 'cvar (incf *next-cvar*))) (let ((*value-to-go* loc)) (wt-nl "{object V" (second loc) ";") (c2expr* (car args)) (push-args (cdr args)) (wt "(V" (second loc))))) (wt ")->cf.cf_self ();") (and loc (wt "}"))) (unwind-exit 'fun-val)) (defun inline-proc (fname args &aux (n (length args)) res (obj (add-object fname))) (format t "~%Using ifuncall: ~a" fname) (let ((result (case n ;(0 (list () t (flags ans set) (format nil "ifuncall0(VV[~d])" obj))) (1 (list '(t) t (flags ans set) (format nil "ifuncall1(~a,(#0))" (vv-str obj)) 'ifuncall)) (2 (list '(t t) t (flags ans set) (format nil "ifuncall2(~a,(#0),(#1))" (vv-str obj)) 'ifuncall)) (t (list (make-list n :initial-element t) t (flags ans set) (format nil "ifuncall(~a,~a~{,#~a~})" (vv-str obj) n (dotimes (i n(nreverse res)) (push i res))) 'ifuncall))))) (push (cons fname result ) *inline-functions*) result )) (si:putprop 'simple-call 'wt-simple-call 'wt-loc) (defun wt-simple-call (cfun base n &optional (vv-index nil)) (wt "simple_" cfun "(") (when vv-index (wt (vv-str vv-index) ",")) (wt "base+" base "," n ")") (base-used)) ;;; Functions that use SAVE-FUNOB should reset *vs*. (defun save-funob (funob) (case (car funob) ((call-lambda call-quote-lambda call-local)) (call-global (unless (and (inline-possible (caddr funob)) (or (get (caddr funob) 'Lfun) (get (caddr funob) 'Ufun) (get (caddr funob) 'proclaimed-function) (assoc (caddr funob) *global-funs*))) (let ((temp (list 'vs (vs-push)))) (if *safe-compile* (wt-nl temp "=symbol_function(" (vv-str (add-symbol (caddr funob))) ");") (wt-nl temp "=" (vv-str (add-symbol (caddr funob))) "->s.s_gfdef;")) temp))) (ordinary (let* ((temp (list 'vs (vs-push))) (*value-to-go* temp)) (c2expr* (caddr funob)) temp)) (otherwise (baboon)) )) (defun push-args (args) (cond ((null args) (wt-nl "vs_base=vs_top;")) ((consp args) (let ((*vs* *vs*) (base *vs*)) (dolist** (arg args) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* arg))) (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";") (base-used))))) (defun push-args-lispcall (args) (dolist** (arg args) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* arg)))) (defun c2call-unknown-global (fname args loc inline-p) (cond (*compiler-push-events* ;;; Want to set up the return catcher. (unless loc (setq loc (list 'vs (vs-push))) (wt-nl loc "=symbol_function(" (vv-str (add-symbol fname)) ");")) (push-args args) (wt-nl "funcall_with_catcher(" (vv-str (add-symbol fname)) "," loc ");") (unwind-exit 'fun-val nil fname)) (loc ;;; The function was already pushed. (push-args args) (if inline-p (if *safe-compile* (wt-nl "funcall_no_event(" loc ");") (wt-nl "CMPfuncall(" loc ");")) (wt-nl "funcall(" loc ");")) (unwind-exit 'fun-val)) ((args-cause-side-effect args) ;;; Evaluation of the arguments may cause side-effect. ;;; Arguments are not yet pushed. (let ((base *vs*)) (setq loc (list 'vs (vs-push))) (if *safe-compile* (wt-nl loc "=symbol_function(" (vv-str (add-symbol fname)) ");") (wt-nl loc "=(" (vv-str (add-symbol fname)) "->s.s_gfdef);")) (push-args-lispcall args) (cond ((or (eq *value-to-go* 'return) (eq *value-to-go* 'top)) (wt-nl "lispcall") (when inline-p (wt "_no_event")) (wt "(base+" base "," (length args) ");") (base-used) (unwind-exit 'fun-val)) (t (unwind-exit (list 'SIMPLE-CALL (if inline-p "lispcall_no_event" "lispcall") base (length args)))))) ) (t ;;; Evaluation of the arguments causes no side-effect. ;;; Arguments are not yet pushed. (let ((base *vs*)) (push-args-lispcall args) (cond ((or (eq *value-to-go* 'return) (eq *value-to-go* 'top)) (wt-nl "symlispcall") (when inline-p (wt "_no_event")) (wt "(" (vv-str (add-symbol fname)) ",base+" base "," (length args) ");") (base-used) (unwind-exit 'fun-val nil fname)) (t (unwind-exit (list 'SIMPLE-CALL (if inline-p "symlispcall_no_event" "symlispcall") base (length args) (add-symbol fname)) nil fname)))) ))) gcl/cmpnew/gcl_cmpcatch.lsp000077500000000000000000000101731242227143400162510ustar00rootroot00000000000000;;; CMPCATCH Catch, Unwind-protect, and Throw. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (si:putprop 'catch 'c1catch 'c1special) (si:putprop 'catch 'c2catch 'c2) (si:putprop 'unwind-protect 'c1unwind-protect 'c1special) (si:putprop 'unwind-protect 'c2unwind-protect 'c2) (si:putprop 'throw 'c1throw 'c1special) (si:putprop 'throw 'c2throw 'c2) (defun c1catch (args &aux (info (make-info :sp-change t)) tag) (incf *setjmps*) (when (endp args) (too-few-args 'catch 1 0)) (setq tag (c1expr (car args))) (add-info info (cadr tag)) (setq args (c1progn (cdr args))) (add-info info (cadr args)) (list 'catch info tag args)) (si:putprop 'push-catch-frame 'set-push-catch-frame 'set-loc) (defun c2catch (tag body &aux (*vs* *vs*)) (let ((*value-to-go* '(push-catch-frame))) (c2expr* tag)) (wt-nl "if(nlj_active)") (wt-nl "{nlj_active=FALSE;frs_pop();") (unwind-exit 'fun-val 'jump) (wt "}") (wt-nl "else{") (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body)) (wt "}") ) (defun set-push-catch-frame (loc) (wt-nl "frs_push(FRS_CATCH," loc ");")) (defun c1unwind-protect (args &aux (info (make-info :sp-change t)) form) (incf *setjmps*) (when (endp args) (too-few-args 'unwind-protect 1 0)) (setq form (let ((*blocks* (cons 'lb *blocks*)) (*tags* (cons 'lb *tags*)) (*vars* (cons 'lb *vars*))) (c1expr (car args)))) (add-info info (cadr form)) (setq args (c1progn (cdr args))) (add-info info (cadr args)) (list 'unwind-protect info form args) ) (defun c2unwind-protect (form body &aux (*vs* *vs*) (loc (list 'vs (vs-push))) top-data) ;;; exchanged following two lines to eliminate setjmp clobbering warning (wt-nl "frs_push(FRS_PROTECT,Cnil);") (wt-nl "{object tag=Cnil;frame_ptr fr=NULL;object p;bool active;") (wt-nl "if(nlj_active){tag=nlj_tag;fr=nlj_fr;active=TRUE;}") (wt-nl "else{") (let ((*value-to-go* 'top) *top-data* ) (c2expr* form) (setq top-data *top-data*)) (wt-nl "active=FALSE;}") (wt-nl loc "=Cnil;") (wt-nl "while(vs_base= (cadr x) 1)) (setq *safe-compile* (>= (cadr x) 2)) (setq *compiler-push-events* (>= (cadr x) 3))) (space (setq *space* (cadr x))) (speed (setq *speed* (cadr x))) (compilation-speed (setq *speed* (- 3 (cadr x)))) (t (warn "The OPTIMIZE quality ~s is unknown." (car x))))))) (type (if (consp (cdr decl)) (proclaim-var (cadr decl) (cddr decl)) (warn "The type declaration ~s is illegal." decl))) ((fixnum character short-float long-float) (proclaim-var (car decl) (cdr decl))) (ftype (cond ((and (consp (cdr decl)) (consp (cadr decl)) (eq (caadr decl) 'function)) (add-function-proclamation (caddr decl) (cdr (cadr decl)) (cddr decl))) (t (cmpwarn "Bad function proclamation ~a" decl)))) (function (cond ((and (consp (cdr decl))) (add-function-proclamation (cadr decl) (cddr decl) nil)) (t (cmpwarn "Bad function proclamation ~a" decl)))) (inline (dolist** (fun (cdr decl)) (if (symbolp fun) (remprop fun 'cmp-notinline) (warn "The function name ~s is not a symbol." fun)))) (notinline (dolist** (fun (cdr decl)) (if (symbolp fun) (si:putprop fun t 'cmp-notinline) (warn "The function name ~s is not a symbol." fun)))) ((object ignore ignorable) (dolist** (var (cdr decl)) (unless (symbolp var) (warn "The variable name ~s is not a symbol." var)))) (declaration (dolist** (x (cdr decl)) (if (symbolp x) (unless (member x *alien-declarations*) (push x *alien-declarations*)) (warn "The declaration specifier ~s is not a symbol." x)))) ((array atom bignum bit bit-vector character common compiled-function complex cons double-float fixnum float hash-table integer keyword list long-float nil null number package pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string dynamic-extent :dynamic-extent string-char symbol t vector signed-byte unsigned-byte) (proclaim-var (car decl) (cdr decl))) (otherwise (unless (member (car decl) *alien-declarations*) (warn "The declaration specifier ~s is unknown." (car decl))) (and (functionp (get (car decl) :proclaim)) (dolist** (v (cdr decl)) (funcall (get (car decl) :proclaim) v))) ) ) nil ) (defun proclaim-var (type vl) (setq type (type-filter type)) (dolist** (var vl) (cond ((symbolp var) (let ((type1 (get var 'cmp-type)) (v (sch-global var))) (setq type1 (if type1 (type-and type1 type) type)) (when v (setq type1 (type-and type1 (var-type v)))) (when (null type1) (warn "Inconsistent type declaration was found for the variable ~s." var)) (si:putprop var type1 'cmp-type) (when v (setf (var-type v) type1)))) (t (warn "The variable name ~s is not a symbol." var))))) (defun c1body (body doc-p &aux (ss nil) (is nil) (ts nil) (others nil) doc form) (loop (when (endp body) (return)) (setq form (cmp-macroexpand (car body))) (when (and (consp form) (eq (car form) 'load-time-value)) (setq form (cmp-eval form))) (cond ((stringp form) (when (or (null doc-p) (endp (cdr body)) doc) (return)) (setq doc form)) ((and (consp form) (eq (car form) 'declare)) (dolist** (decl (cdr form)) ;;; Add support for 'cons' declarations, such as (declare ((vector t) foo)) ;;; 20040320 CM (cmpck (not (consp decl)) "The declaration ~s is illegal." decl) (let* ((dtype (car decl))) ;; Can process user deftypes here in the future -- 20040318 CM ;; (dft (and (symbolp dtype) (get dtype 'si::deftype-definition))) ;; (dtype (or (and dft (funcall dft)) dtype))) (if (consp dtype) (let ((stype (car dtype))) (cmpck (or (not (symbolp stype)) (cdddr dtype)) "The declaration ~s is illegal." decl) (case stype (satisfies (push decl others)) (otherwise (dolist** (var (cdr decl)) (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." decl var) (push (cons var dtype) ts))))) (let ((stype dtype)) (cmpck (not (symbolp stype)) "The declaration ~s is illegal." decl) (case stype (special (dolist** (var (cdr decl)) (cmpck (not (symbolp var)) "The special declaration ~s contains a non-symbol ~s." decl var) (push var ss))) ((ignore ignorable) (dolist** (var (cdr decl)) (cmpck (not (symbolp var)) "The ignore declaration ~s contains a non-symbol ~s." decl var) (when (eq stype 'ignorable) (push 'ignorable is)) (push var is))) (type (cmpck (endp (cdr decl)) "The type declaration ~s is illegal." decl) (let ((type (type-filter (cadr decl)))) (when type (dolist** (var (cddr decl)) (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." decl var) (push (cons var type) ts))))) (object (dolist** (var (cdr decl)) (cmpck (not (symbolp var)) "The object declaration ~s contains a non-symbol ~s." decl var) (push (cons var 'object) ts))) (:register (dolist** (var (cdr decl)) (cmpck (not (symbolp var)) "The register declaration ~s contains a non-symbol ~s." decl var) (push (cons var 'register) ts) )) ((:dynamic-extent dynamic-extent) (dolist (var (cdr decl)) (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." decl var) (push (cons var :dynamic-extent) ts))) ((fixnum character double-float short-float array atom bignum bit bit-vector common compiled-function complex cons float hash-table integer keyword list long-float nil null number package pathname random-state ratio rational readtable sequence simple-array simple-bit-vector simple-string simple-base-string simple-vector single-float standard-char stream string string-char symbol t vector signed-byte unsigned-byte) (let ((type (type-filter stype))) (when type (dolist** (var (cdr decl)) (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." decl var) (push (cons var type) ts))))) (otherwise (push decl others)))))))) (t (return))) (pop body) ) (values body ss ts is others doc) ) (defun c1decl-body (decls body &aux (dl nil)) (if (null decls) (c1progn body) (let ((*function-declarations* *function-declarations*) (*alien-declarations* *alien-declarations*) (*notinline* *notinline*) (*space* *space*) (*safe-compile* *safe-compile*)) (dolist** (decl decls dl) (case (car decl) (optimize (dolist (x (cdr decl)) (when (symbolp x) (setq x (list x 3))) (if (or (not (consp x)) (not (consp (cdr x))) (not (numberp (cadr x))) (not (<= 0 (cadr x) 3))) (warn "The OPTIMIZE proclamation ~s is illegal." x) (case (car x) (safety (setq *safe-compile* (>= (the fixnum (cadr x)) 2)) (push (list 'safety (cadr x)) dl)) (space (setq *space* (cadr x)) (push (list 'space (cadr x)) dl)) ((speed compilation-speed)) (t (warn "The OPTIMIZE quality ~s is unknown." (car x))))))) (ftype (if (or (endp (cdr decl)) (not (consp (cadr decl))) (not (eq (caadr decl) 'function)) (endp (cdadr decl))) (warn "The function declaration ~s is illegal." decl) (dolist** (fname (cddr decl)) (add-function-declaration fname (cadadr decl) (cddadr decl))))) (function (if (or (endp (cdr decl)) (endp (cddr decl)) (not (symbolp (cadr decl)))) (warn "The function declaration ~s is illegal." decl) (add-function-declaration (cadr decl) (caddr decl) (cdddr decl)))) (inline (dolist** (fun (cdr decl)) (if (symbolp fun) (progn (push (list 'inline fun) dl) (setq *notinline* (remove fun *notinline*))) (warn "The function name ~s is not a symbol." fun)))) (notinline (dolist** (fun (cdr decl)) (if (symbolp fun) (progn (push (list 'notinline fun) dl) (push fun *notinline*)) (warn "The function name ~s is not a symbol." fun)))) (declaration (dolist** (x (cdr decl)) (if (symbolp x) (unless (member x *alien-declarations*) (push x *alien-declarations*)) (warn "The declaration specifier ~s is not a symbol." x)))) (otherwise (unless (member (car decl) *alien-declarations*) (warn "The declaration specifier ~s is unknown." (car decl)))) )) (setq body (c1progn body)) (list 'decl-body (cadr body) dl body) ) ) ) (si:putprop 'decl-body 'c2decl-body 'c2) (defun c2decl-body (decls body) (let ((*compiler-check-args* *compiler-check-args*) (*safe-compile* *safe-compile*) (*compiler-push-events* *compiler-push-events*) (*notinline* *notinline*) (*space* *space*) ) (dolist** (decl decls) (case (car decl) (safety (let ((level (cadr decl))) (declare (fixnum level)) (setq *compiler-check-args* (>= level 1) *safe-compile* (>= level 2) *compiler-push-events* (>= level 3)))) (space (setq *space* (cadr decl))) (notinline (push (cadr decl) *notinline*)) (inline (setq *notinline* (remove (cadr decl) *notinline*))) (otherwise (baboon)))) (c2expr body)) ) (defun check-vdecl (vnames ts is) (dolist** (x ts) (unless (member (car x) vnames) (cmpwarn "Type declaration was found for not bound variable ~s." (car x)))) (dolist** (x is) (unless (or (eq x 'ignorable) (member x vnames)) (cmpwarn "Ignore/ignorable declaration was found for not bound variable ~s." x))) ) (defun proclamation (decl) (case (car decl) (special (dolist** (var (cdr decl) t) (if (symbolp var) (unless (si:specialp var) (return nil)) (warn "The variable name ~s is not a symbol." var)))) (optimize (dolist (x (cdr decl) t) (when (symbolp x) (setq x (list x 3))) (if (or (not (consp x)) (not (consp (cdr x))) (not (numberp (cadr x))) (not (<= 0 (cadr x) 3))) (warn "The OPTIMIZE proclamation ~s is illegal." x) (case (car x) (safety (unless (= (cadr x) (cond ((null *compiler-check-args*) 0) ((null *safe-compile*) 1) ((null *compiler-push-events*) 2) (t 3))) (return nil))) (space (unless (= (cadr x) *space*) (return nil))) (speed (unless (= (cadr x) *speed*) (return nil))) (compilation-speed (unless (= (- 3 (cadr x)) *speed*) (return nil))) (t (warn "The OPTIMIZE quality ~s is unknown." (car x))))))) (type (if (consp (cdr decl)) (let ((type (type-filter (cadr decl))) x) (dolist** (var (cddr decl) t) (if (symbolp var) (unless (and (setq x (get var 'cmp-type)) (equal x type)) (return nil)) (warn "The variable name ~s is not a symbol." var)))) (warn "The type declaration ~s is illegal." decl))) ((fixnum character short-float long-float) (let ((type (type-filter (car decl))) x) (dolist** (var (cdr decl) t) (if (symbolp var) (unless (and (setq x (get var 'cmp-type)) (equal x type)) (return nil)) (warn "The variable name ~s is not a symbol." var))))) (ftype (if (or (endp (cdr decl)) (not (consp (cadr decl))) (not (eq (caadr decl) 'function)) (endp (cdadr decl))) (warn "The function declaration ~s is illegal." decl) (dolist** (fname (cddr decl) t) (unless (and (get fname 'proclaimed-function) (equal (function-arg-types (cadadr decl)) (get fname 'proclaimed-arg-types)) (equal (function-return-type (cddadr decl)) (get fname 'proclaimed-return-type))) (return nil))))) (function (if (or (endp (cdr decl)) (endp (cddr decl))) (warn "The function declaration ~s is illegal." decl) (and (get (cadr decl) 'proclaimed-function) (equal (function-arg-types (caddr decl)) (get (cadr decl) 'proclaimed-arg-types)) (equal (function-return-type (cdddr decl)) (get (cadr decl) 'proclaimed-return-type))))) (inline (dolist** (fun (cdr decl) t) (if (symbolp fun) (when (get fun 'cmp-notinline) (return nil)) (warn "The function name ~s is not a symbol." fun)))) (notinline (dolist** (fun (cdr decl) t) (if (symbolp fun) (unless (get fun 'cmp-notinline) (return nil)) (warn "The function name ~s is not a symbol." fun)))) ((object ignore ignorable) (dolist** (var (cdr decl) t) (unless (symbolp var) (warn "The variable name ~s is not a symbol." var)))) (declaration (dolist** (x (cdr decl) t) (if (symbolp x) (unless (member x *alien-declarations*) (return nil)) (warn "The declaration specifier ~s is not a symbol." x)))) ((array atom bignum bit bit-vector character common compiled-function complex cons double-float fixnum float hash-table integer keyword list long-float nil null number package pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string dynamic-extent :dynamic-extent string-char symbol t vector signed-byte unsigned-byte) (let ((type (type-filter (car decl)))) (dolist** (var (cdr decl) t) (if (symbolp var) (unless (equal (get var 'cmp-type) type) (return nil)) (warn "The variable name ~s is not a symbol." var))))) (otherwise (unless (member (car decl) *alien-declarations*) (warn "The declaration specifier ~s is unknown." (car decl)))) ) ) gcl/cmpnew/gcl_cmpeval.lsp000077500000000000000000000603241242227143400161210ustar00rootroot00000000000000;;; CMPEVAL The Expression Dispatcher. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (export '(si::define-compiler-macro si::undef-compiler-macro si::define-inline-function) 'system) (in-package 'compiler) (si:putprop 'progn 'c1progn 'c1special) (si:putprop 'progn 'c2progn 'c2) (si:putprop 'si:structure-ref 'c1structure-ref 'c1) (si:putprop 'structure-ref 'c2structure-ref 'c2) (si:putprop 'structure-ref 'wt-structure-ref 'wt-loc) (si:putprop 'si:structure-set 'c1structure-set 'c1) (si:putprop 'structure-set 'c2structure-set 'c2) (defun c1expr* (form info) (setq form (c1expr form)) (add-info info (cadr form)) form) (defun c1expr (form) (setq form (catch *cmperr-tag* (cond ((symbolp form) (cond ((eq form nil) (c1nil)) ((eq form t) (c1t)) ((keywordp form) (list 'LOCATION (make-info :type (object-type form)) (list 'VV (add-object form)))) ((constantp form) (let ((val (symbol-value form))) (or (c1constant-value val nil) (list 'LOCATION (make-info :type (object-type val)) (list 'VV (add-constant form)))))) (t (c1var form)))) ((consp form) (let ((fun (car form))) (cond ((symbolp fun) (c1symbol-fun fun (cdr form))) ((and (consp fun) (eq (car fun) 'lambda)) (c1lambda-fun (cdr fun) (cdr form))) ((and (consp fun) (eq (car fun) 'si:|#,|)) (cmperr "Sharp-comma-macro was found in a bad place.")) (t (cmperr "The function ~s is illegal." fun))))) (t (c1constant-value form t))))) (if (eq form '*cmperr-tag*) (c1nil) form)) (si::putprop 'si:|#,| 'c1sharp-comma 'c1special) (si::putprop 'load-time-value 'c1load-time-value 'c1special) (defun c1sharp-comma (arg) (c1constant-value (cons 'si:|#,| arg) t)) (defun c1load-time-value (arg) (c1constant-value (cons 'si:|#,| (if *compiler-compile* (let ((x (cmp-eval (car arg)))) (if (and (cdr arg) (cadr arg)) x `(si::nani ,(si::address x)))) (car arg))) t)) (si::putprop 'si::define-structure 'c1define-structure 't1) (defun c1define-structure (arg &aux *sharp-commas*) (declare (special *sharp-commas*)) (eval (cons 'si::define-structure arg)) (c1constant-value (cons 'si:|#,| (cons 'si::define-structure arg)) t) (add-load-time-sharp-comma) nil) (defvar *c1nil* (list 'LOCATION (make-info :type (object-type nil)) nil)) (defun c1nil () *c1nil*) (defvar *c1t* (list 'LOCATION (make-info :type (object-type t)) t)) (defun c1t () *c1t*) (defun flags-pos (flag &aux (i 0)) (declare (fixnum i)) (dolist (v '((allocates-new-storage ans); might invoke gbc (side-effect-p set) ; no effect on arguments (constantp) ; always returns same result, ;double eval ok. (result-type-from-args rfa); if passed args of matching ;type result is of result type (is))) ;; extends the `integer stack'. (cond ((member flag v :test 'eq) (return-from flags-pos i))) (setq i (+ i 1))) (error "unknown opt flag")) (defmacro flag-p (n flag) `(logbitp ,(flags-pos flag) ,n)) ;; old style opts had '(args ret new-storage side-effect string) ;; these new-storage and side-effect have been combined into ;; one integer, along with several other flags. (defun fix-opt (opt) (let ((a (cddr opt))) (unless (typep (car a ) 'fixnum) (if *compiler-in-use* (cmpwarn "Obsolete optimization: use fix-opt ~s" opt)) (setf (cddr opt) (cons (logior (if (car a) 2 0) (if (cadr a) 1 0)) (cddr a)))) opt)) ;; some hacks for revising a list of optimizers. #+revise (progn (defun output-opt (opt sym flag) (fix-opt opt) (format t "(push '(~(~s ~s #.(flags~)" (car opt) (second opt)) (let ((o (third opt))) (if (flag-p o set) (princ " set")) (if (flag-p o ans) (princ " ans")) (if (flag-p o rfa) (princ " rfa")) (if (flag-p o constantp) (princ "constantp "))) (format t ")") (if (and (stringp (nth 3 opt)) (> (length (nth 3 opt)) 40)) (format t "~% ")) (prin1 (nth 3 opt)) (format t ")~% ~((get '~s '~s)~))~%" sym flag)) (defun output-all-opts (&aux lis did) (sloop::sloop for v in ;(list (find-package "LISP")) (list-all-packages) do (setq lis (sloop::sloop for sym in-package (package-name v) when (or (get sym 'inline-always) (get sym 'inline-safe) (get sym 'inline-unsafe)) collect sym)) (setq lis (sort lis #'(lambda (x y) (string-lessp (symbol-name x) (symbol-name y))))) do (sloop::sloop for sym in lis do (format t "~%;;~s~% " sym) (sloop::sloop for u in '(inline-always inline-safe inline-unsafe) do (sloop::sloop for w in (nreverse (remove-duplicates (copy-list (get sym u)) :test 'equal)) do (output-opt w sym u)))))) ) (defun result-type-from-args(f args &aux tem) (when (and (setq tem (get f 'return-type)) (not (eq tem '*)) (not (consp tem))) (dolist (v '(inline-always inline-unsafe)) (dolist (w (get f v)) (fix-opt w) (when (and (flag-p (third w) result-type-from-args) (eql (length args) (length (car w))) (do ((a args (cdr a)) (b (car w) (cdr b))) ((null a) t) (unless (or (eq (car a) (car b)) (type>= (car b)(car a) )) (return nil)))) (return-from result-type-from-args (second w))))))) ;; omitting a flag means it is set to nil. (defmacro flags (&rest lis &aux (i 0)) (dolist (v lis) (setq i (logior i (ash 1 (flags-pos v))))) i) ;; Usage: ; (flagp-p (caddr ii) side-effect-p) ; (push '((integer integer) integer #.(flags const raf) "addii(#0,#1)") ; (get '+ 'inline-always)) (defun c1symbol-fun (fname args &aux fd) (cond ((setq fd (get fname 'c1special)) (funcall fd args)) ((and (setq fd (get fname 'co1special)) (funcall fd fname args))) ((setq fd (c1local-fun fname)) (if (eq (car fd) 'call-local) ;; c1local-fun now adds fun-info into (cadr fd), so we need no longer ;; do it explicitly here. CM 20031030 (let* ((info (add-info (make-info :sp-change t) (cadr fd))) (forms (c1args args info))) (let ((return-type (get-local-return-type (caddr fd)))) (when return-type (setf (info-type info) return-type))) (let ((arg-types (get-local-arg-types (caddr fd)))) ;;; Add type information to the arguments. (when arg-types (let ((fl nil)) (dolist** (form forms) (cond ((endp arg-types) (push form fl)) (t (push (and-form-type (car arg-types) form (car args)) fl) (pop arg-types) (pop args)))) (setq forms (nreverse fl))))) (list 'call-local info (cddr fd) forms)) (c1expr (cmp-expand-macro fd fname args)))) ((and (setq fd (get fname 'co1)) (inline-possible fname) (funcall fd fname args))) ((and (setq fd (get fname 'c1)) (inline-possible fname)) (funcall fd args)) ((and (setq fd (get fname 'c1conditional)) (inline-possible fname) (funcall (car fd) args)) (funcall (cdr fd) args)) ;; record the call info if we get to here ((progn (and (eq (symbol-package fname) (symbol-package 'and)) (not (fboundp fname)) (cmpwarn "~A (in lisp package) is called as a function--not yet defined" fname)) (and *record-call-info* (record-call-info 'record-call-info fname)) nil)) ;;continue ((setq fd (macro-function fname)) (c1expr (cmp-expand-macro fd fname args))) ((setq fd (get fname 'compiler-macro)) (c1expr (cmp-eval `(funcall ',fd ',(cons fname args) nil)))) ((and (setq fd (get fname 'si::structure-access)) (inline-possible fname) ;;; Structure hack. (consp fd) (si:fixnump (cdr fd)) (not (endp args)) (endp (cdr args))) (case (car fd) (vector (c1expr `(elt ,(car args) ,(cdr fd)))) (list (c1expr `(si:list-nth ,(cdr fd) ,(car args)))) (t (c1structure-ref1 (car args) (car fd) (cdr fd))) ) ) ((eq fname 'si:|#,|) (cmperr "Sharp-comma-macro was found in a bad place.")) (t (let* ((info (make-info :sp-change (null (get fname 'no-sp-change)))) (forms (c1args args info))) ;; info updated by args here (let ((return-type (get-return-type fname))) (when return-type (if (equal return-type '(*)) (setf return-type nil) (setf (info-type info) return-type)))) (let ((arg-types (get-arg-types fname))) ;;; Add type information to the arguments. (when arg-types (do ((fl forms (cdr fl)) (fl1 nil) (al args (cdr al))) ((endp fl) (setq forms (nreverse fl1))) (cond ((endp arg-types) (push (car fl) fl1)) (t (push (and-form-type (car arg-types) (car fl) (car al)) fl1) (pop arg-types)))))) (let ((arg-types (get fname 'arg-types))) ;;; Check argument types. (when arg-types (do ((fl forms (cdr fl)) (al args (cdr al))) ((or (endp arg-types) (endp fl))) (check-form-type (car arg-types) (car fl) (car al)) (pop arg-types)))) (case fname (aref (let ((etype (info-type (cadar forms)))) (when (or (and (eq etype 'string) (setq etype 'character)) (and (consp etype) (or (eq (car etype) 'array) (eq (car etype) 'vector)) (setq etype (cadr etype)))) (setq etype (type-and (info-type info) etype)) (when (null etype) (cmpwarn "Type mismatch was found in ~s." (cons fname args))) (setf (info-type info) etype)))) (si:aset (let ((etype (info-type (cadar forms)))) (when (or (and (eq etype 'string) (setq etype 'character)) (and (consp etype) (or (eq (car etype) 'array) (eq (car etype) 'vector)) (setq etype (cadr etype)))) (setq etype (type-and (info-type info) (type-and (info-type (cadar (last forms))) etype))) (when (null etype) (cmpwarn "Type mismatch was found in ~s." (cons fname args))) (setf (info-type info) etype) (setf (info-type (cadar (last forms))) etype) )))) ;; some functions can have result type deduced from ;; arg types. (let ((tem (result-type-from-args fname (mapcar #'(lambda (x) (info-type (cadr x))) forms)))) (when tem (setq tem (type-and tem (info-type info))) (setf (info-type info) tem))) (list 'call-global info fname forms))) ) ) ;;numbers and character constants may be sometimes used, instead ;;of the variable, eg inside eql (defun replace-constant (lis &aux found tem) (do ((v lis (cdr v))) ((null v) found) (cond ((and (constantp (car v)) (or (numberp (setq tem(eval (car v)))) (characterp tem))) (setq found t) (setf (car v) tem))))) (defun c1lambda-fun (lambda-expr args &aux (info (make-info :sp-change t))) (setq args (c1args args info)) (setq lambda-expr (c1lambda-expr lambda-expr)) (add-info info (cadr lambda-expr)) (list 'call-lambda info lambda-expr args) ) (defun c2expr (form) (if (eq (car form) 'call-global) (c2call-global (caddr form) (cadddr form) nil (info-type (cadr form))) (if (or (eq (car form) 'let) (eq (car form) 'let*)) (let ((*volatile* (volatile (cadr form)))) (declare (special *volatile*)) (apply (get (car form) 'c2) (cddr form))) (let ((tem (get (car form) 'c2))) (cond (tem (apply tem (cddr form))) ((setq tem (get (car form) 'wholec2)) (funcall tem form)) (t (baboon))))))) (defun c2funcall-sfun (fn args info &aux locs (all (cons fn args))) info (let ((*inline-blocks* 0)) (setq locs (get-inline-loc (list (make-list (length all) :initial-element t) t #.(flags ans set) 'fcalln-inline) all)) (unwind-exit locs) (close-inline-blocks))) (defun c2expr* (form) (let* ((*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2expr form) (wt-label *exit*)) ) (defun c2expr-top (form top &aux (*vs* 0) (*max-vs* 0) (*level* (1+ *level*)) (*reservation-cmacro* (next-cmacro))) (wt-nl "{register object *base" (1- *level*) "=base;") (base-used) (wt-nl "{register object *base=V" top ";") (wt-nl "register object *sup=vs_base+VM" *reservation-cmacro* ";") ;;; Dummy assignments for lint (wt-nl "base" (1- *level*) "[0]=base" (1- *level*) "[0];") (wt-nl "base[0]=base[0];") (if *safe-compile* (wt-nl "vs_reserve(VM" *reservation-cmacro* ");") (wt-nl "vs_check;")) (wt-nl) (reset-top) (c2expr form) (push (cons *reservation-cmacro* *max-vs*) *reservations*) (wt-nl "}}") ) (defun c2expr-top* (form top) (let* ((*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2expr-top form top) (wt-label *exit*))) (defun c1progn (forms &aux (fl nil)) (cond ((endp forms) (c1nil)) ((endp (cdr forms)) (c1expr (car forms))) (t (let ((info (make-info))) (dolist (form forms) (setq form (c1expr form)) (push form fl) (add-info info (cadr form))) (setf (info-type info) (info-type (cadar fl))) (list 'progn info (nreverse fl)) ))) ) ;;; Should be deleted. (defun c1progn* (forms info) (setq forms (c1progn forms)) (add-info info (cadr forms)) forms) (defun c2progn (forms) ;;; The length of forms may not be less than 1. (do ((l forms (cdr l))) ((endp (cdr l)) (c2expr (car l))) (declare (object l)) (let* ((*value-to-go* 'trash) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2expr (car l)) (wt-label *exit*) )) ) (defun c1args (forms info) (mapcar #'(lambda (form) (c1expr* form info)) forms)) ;;; Structures (defun c1structure-ref (args) (if (and (not *safe-compile*) (not (endp args)) (not (endp (cdr args))) (consp (cadr args)) (eq (caadr args) 'quote) (not (endp (cdadr args))) (symbolp (cadadr args)) (endp (cddadr args)) (not (endp (cddr args))) (si:fixnump (caddr args)) (endp (cdddr args))) (c1structure-ref1 (car args) (cadadr args) (caddr args)) (let ((info (make-info))) (list 'call-global info 'si:structure-ref (c1args args info))))) (defun c1structure-ref1 (form name index &aux (info (make-info))) ;;; Explicitly called from c1expr and c1structure-ref. (declare (special *aet-types*)) (cond (*safe-compile* (c1expr `(si::structure-ref ,form ',name ,index))) (t (let* ((sd (get name 'si::s-data)) (aet-type (aref (si::s-data-raw sd) index)) ) (setf (info-type info) (type-filter (aref *aet-types* aet-type))) (list 'structure-ref info (c1expr* form info) (add-symbol name) index sd) )))) (defun coerce-loc-structure-ref (arg type-wanted &aux (form (cdr arg))) (let* ((sd (fourth form)) (index (caddr form))) (cond (sd (let* ((aet-type (aref (si::s-data-raw sd) index)) (type (aref *aet-types* aet-type))) (cond ((eq (inline-type (type-filter type)) 'inline) (or (eql aet-type 0) (error "bad type ~a" type)))) (setf (info-type (car arg)) (type-filter type)) (coerce-loc (list (inline-type (type-filter type)) (flags) 'my-call (list (car (inline-args (list (car form)) '(t))) 'joe index sd)) (type-filter type-wanted))) ) (t (wfs-error))))) (defun c2structure-ref (form name-vv index sd &aux (*vs* *vs*) (*inline-blocks* 0)) (let ((loc (car (inline-args (list form) '(t)))) (type (aref *aet-types* (aref (si::s-data-raw sd) index)))) (unwind-exit (list (inline-type (type-filter type)) (flags) 'my-call (list loc name-vv index sd)))) (close-inline-blocks) ) (defun my-call (loc name-vv ind sd) name-vv (let* ((raw (si::s-data-raw sd)) (spos (si::s-data-slot-position sd))) (if *safe-compile* (wfs-error) (wt "STREF(" (aet-c-type (aref *aet-types* (aref raw ind)) ) "," loc "," (aref spos ind) ")")))) (defun c1structure-set (args &aux (info (make-info))) (if (and (not (endp args)) (not *safe-compile*) (not (endp (cdr args))) (consp (cadr args)) (eq (caadr args) 'quote) (not (endp (cdadr args))) (symbolp (cadadr args)) (endp (cddadr args)) (not (endp (cddr args))) (si:fixnump (caddr args)) (not (endp (cdddr args))) (endp (cddddr args))) (let ((x (c1expr (car args))) (y (c1expr (cadddr args)))) (add-info info (cadr x)) (add-info info (cadr y)) (setf (info-type info) (info-type (cadr y))) (list 'structure-set info x (add-symbol (cadadr args)) ;;; remove QUOTE. (caddr args) y (get (cadadr args) 'si::s-data))) (list 'call-global info 'si:structure-set (c1args args info)))) ;; The following (side-effects) exists for putting at the end of an ;; argument list to force all previous arguments to be stored in ;; variables, when computing inline-args. (push '(() t #.(flags ans set) "Ct") (get 'side-effects 'inline-always)) (defun c2structure-set (x name-vv ind y sd &aux locs (*vs* *vs*) (*inline-blocks* 0)) name-vv (let* ((raw (si::s-data-raw sd)) (type (aref *aet-types* (aref raw ind))) (spos (si::s-data-slot-position sd)) (tftype (type-filter type)) ix iy) (setq locs (inline-args (list x y (list 'call-global (make-info) 'side-effects nil)) (if (eq type t) '(t t t) `(t ,tftype t)))) (setq ix (car locs)) (setq iy (cadr locs)) (if *safe-compile* (wfs-error)) (wt-nl "STSET(" (aet-c-type type )"," ix "," (aref spos ind) ", " iy ");") (unwind-exit (list (inline-type tftype) (flags) 'wt-loc (list iy))) (close-inline-blocks) )) (defun c1constant-value (val always-p) (cond ((eq val nil) (c1nil)) ((eq val t) (c1t)) ((when (si:fixnump val) (< most-negative-fixnum val)) (list 'LOCATION (make-info :type 'fixnum) (list 'FIXNUM-VALUE (and (>= (abs val) 1024)(add-object val)) val))) ((characterp val) (list 'LOCATION (make-info :type 'character) (list 'CHARACTER-VALUE (add-object val) (char-code val)))) ((typep val 'long-float) ;; We can't read in long-floats which are too big: (let* (sc (vv (cond ((> (abs val) (/ most-positive-long-float 2)) (add-object `(si::|#,| * ,(/ val most-positive-long-float) most-positive-long-float))) ((< (abs val) (* least-positive-normalized-long-float 2.0)) (add-object `(si::|#,| * ,(/ val least-positive-normalized-long-float) least-positive-normalized-long-float))) ((setq sc t) (add-object val))))) `(location ,(make-info :type 'long-float) ,(if sc (list 'LONG-FLOAT-VALUE vv val) (list 'vv vv))))) ((typep val 'short-float) (list 'LOCATION (make-info :type 'short-float) (list 'SHORT-FLOAT-VALUE (add-object val) val))) ((and *compiler-compile* (not *keep-gaz*)) (list 'LOCATION (make-info :type (object-type val)) (list 'VV (add-object (cons 'si::|#,| `(si::nani ,(si::address val))))))) (always-p (list 'LOCATION (make-info :type (object-type val)) (list 'VV (add-object val)))) (t nil))) (defmacro si::define-compiler-macro (name vl &rest body) `(progn (si:putprop ',name (caddr (si:defmacro* ',name ',vl ',body)) 'compiler-macro) ',name)) (defun si::undef-compiler-macro (name) (remprop name 'compiler-macro)) (defvar *compiler-temps* '(tmp0 tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8 tmp9)) (defmacro si:define-inline-function (name vars &body body) (let ((temps nil) (*compiler-temps* *compiler-temps*)) (dolist (var vars) (if (and (symbolp var) (not (si:memq var '(&optional &rest &key &aux)))) (push (or (pop *compiler-temps*) (gentemp "TMP" (find-package 'compiler))) temps) (error "The parameter ~s for the inline function ~s is illegal." var name))) (let ((binding (cons 'list (mapcar #'(lambda (var temp) `(list ',var ,temp)) vars temps)))) `(progn (defun ,name ,vars ,@body) (si:define-compiler-macro ,name ,temps (list* 'let ,binding ',body)))))) (defun name-to-sd (x &aux sd) (or (and (symbolp x) (setq sd (get x 'si::s-data))) (error "The structure ~a is undefined." x)) sd) ;; lay down code for a load time eval constant. (defun name-sd1 (x) (or (get x 'name-to-sd) (setf (get x 'name-sd) `(si::|#,| name-to-sd ',x)))) (defun co1structure-predicate (f args &aux tem) (cond ((and (symbolp f) (setq tem (get f 'si::struct-predicate))) (c1expr `(typep ,(car args) ',tem))))) gcl/cmpnew/gcl_cmpflet.lsp000077500000000000000000000375711242227143400161340ustar00rootroot00000000000000;;; CMPFLET Flet, Labels, and Macrolet. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (si:putprop 'flet 'c1flet 'c1special) (si:putprop 'flet 'c2flet 'c2) (si:putprop 'labels 'c1labels 'c1special) (si:putprop 'labels 'c2labels 'c2) (si:putprop 'macrolet 'c1macrolet 'c1special) ;;; c2macrolet is not defined, because MACROLET is replaced by PROGN ;;; during Pass 1. (si:putprop 'call-local 'c2call-local 'c2) (defstruct fun name ;;; Function name. ref ;;; Referenced or not. ;;; During Pass1, T or NIL. ;;; During Pass2, the vs-address for the ;;; function closure, or NIL. ref-ccb ;;; Cross closure reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the vs-address for the ;;; function closure, or NIL. cfun ;;; The cfun for the function. level ;;; The level of the function. info ;;; fun-info; CM, 20031008 ;;; collect info structure when processing ;;; function lambda list in flet and labels ;;; and pass upwards to call-local and call-global ;;; to determine more accurately when ;;; args-info-changed-vars should prevent certain ;;; inlining ;;; examples: (defun foo (a) (flet ((%f8 nil (setq a 0))) ;;; (let ((v9 a)) (- (%f8) v9)))) ;;; (defun foo (a) (flet ((%f8 nil (setq a 2))) ;;; (* a (%f8)))) ) (defvar *funs* nil) ;;; During Pass 1, *funs* holds a list of fun objects, local macro definitions ;;; and the symbol 'CB' (Closure Boundary). 'CB' will be pushed on *funs* ;;; when the compiler begins to process a closure. A local macro definition ;;; is a list ( macro-name expansion-function). (defun c1flet (args &aux body ss ts is other-decl info (defs1 nil) (local-funs nil) (closures nil) (*info* (copy-info *info*))) (when (endp args) (too-few-args 'flet 1 0)) (let ((*funs* *funs*)) (dolist** (def (car args)) (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def))) "The function definition ~s is illegal." def) (let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil :info (make-info :sp-change t)))) (push fun *funs*) (push (list fun (cdr def)) defs1))) (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) (let ((*vars* *vars*)) (c1add-globals ss) (check-vdecl nil ts is) (setq body (c1decl-body other-decl body))) (setq info (copy-info (cadr body)))) (dolist* (def (setq defs1 (nreverse defs1))) (when (fun-ref-ccb (car def)) (let ((*vars* (cons 'cb *vars*)) (*funs* (cons 'cb *funs*)) (*blocks* (cons 'cb *blocks*)) (*tags* (cons 'cb *tags*))) (let ((lam (c1lambda-expr (cadr def) (fun-name (car def))))) (add-info info (cadr lam)) ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args ;; via args-info-changed-vars (add-info (fun-info (car def)) (cadr lam)) (push (list (car def) lam) closures)))) (when (fun-ref (car def)) (let ((*blocks* (cons 'lb *blocks*)) (*tags* (cons 'lb *tags*)) (*vars* (cons 'lb *vars*))) (let ((lam (c1lambda-expr (cadr def) (fun-name (car def))))) (add-info info (cadr lam)) ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args ;; via args-info-changed-vars (add-info (fun-info (car def)) (cadr lam)) (push (list (car def) lam) local-funs)))) (when (or (fun-ref (car def)) (fun-ref-ccb (car def))) (setf (fun-cfun (car def)) (next-cfun)))) ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args ;; via args-info-changed-vars ;; ;; walk body a second time to incorporate changed variable info from local function ;; lambda lists (let ((*funs* *funs*)) (setq *funs* (nconc (mapcar 'car defs1) *funs*)) (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) (let ((*vars* *vars*)) (c1add-globals ss) (check-vdecl nil ts is) (setq body (c1decl-body other-decl body))) ;; Apparently this is not scricttly necessary, just changes to body (add-info info (cadr body))) (if (or local-funs closures) (list 'flet info (nreverse local-funs) (nreverse closures) body) body)) (defun c2flet (local-funs closures body &aux (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (dolist** (def local-funs) (setf (fun-level (car def)) *level*) ;; Append *initial-ccb-vs* here and use it to initialize *initial-ccb-vs* when writing ;; the code for this function. Local functions, unlike closures, get an envinment ;; level with the *initial-ccb-vs* at this point, and *ccb-vs* can be further incremented ;; here, in c2tagbody-ccb, and in c2block-ccb. CM 20031130 (push (list nil *clink* *ccb-vs* (car def) (cadr def) *initial-ccb-vs*) *local-funs*)) ;;; Setup closures. (dolist** (def closures) (push (list 'closure (if (null *clink*) nil (cons 'fun-env 0)) *ccb-vs* (car def) (cadr def)) *local-funs*) (push (car def) *closures*) (let ((fun (car def))) (declare (object fun)) (setf (fun-ref fun) (vs-push)) (wt-nl) (wt-vs (fun-ref fun)) (wt "=make_cclosure_new(" (c-function-name "LC" (fun-cfun fun) (fun-name fun)) ",Cnil,") (wt-clink) (wt ",Cdata);") (wt-nl) (wt-vs (fun-ref fun)) (wt "=MMcons(") (wt-vs (fun-ref fun)) (wt ",") (wt-clink) (wt ");") (clink (fun-ref fun)) (setf (fun-ref-ccb fun) (ccb-vs-push)) )) (c2expr body) ) (defun c1labels (args &aux body ss ts is other-decl info (defs1 nil) (local-funs nil) (closures nil) (fnames nil) (processed-flag nil) (*funs* *funs*) (*info* (copy-info *info*))) (when (endp args) (too-few-args 'labels 1 0)) ;;; bind local-functions (dolist** (def (car args)) (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def))) "The local function definition ~s is illegal." def) (cmpck (member (car def) fnames) "The function ~s was already defined." (car def)) (push (car def) fnames) (let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil :info (make-info :sp-change t)))) (push fun *funs*) (push (list fun nil nil (cdr def)) defs1))) (setq defs1 (nreverse defs1)) ;;; Now DEFS1 holds ( { ( fun-object NIL NIL body ) }* ). (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) (let ((*vars* *vars*)) (c1add-globals ss) (check-vdecl nil ts is) (setq body (c1decl-body other-decl body))) (setq info (copy-info (cadr body))) (block local-process (loop (setq processed-flag nil) (dolist** (def defs1) (when (and (fun-ref (car def)) ;;; referred locally and (null (cadr def))) ;;; not processed yet (setq processed-flag t) (setf (cadr def) t) (let ((*blocks* (cons 'lb *blocks*)) (*tags* (cons 'lb *tags*)) (*vars* (cons 'lb *vars*))) (let ((lam (c1lambda-expr (cadddr def) (fun-name (car def))))) (add-info info (cadr lam)) ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args ;; via args-info-changed-vars (add-info (fun-info (car def)) (cadr lam)) (push (list (car def) lam) local-funs))))) (unless processed-flag (return-from local-process)) )) ;;; end local process (block closure-process (loop (setq processed-flag nil) (dolist** (def defs1) (when (and (fun-ref-ccb (car def)) ; referred across closure (null (caddr def))) ; and not processed (setq processed-flag t) (setf (caddr def) t) (let ((*vars* (cons 'cb *vars*)) (*funs* (cons 'cb *funs*)) (*blocks* (cons 'cb *blocks*)) (*tags* (cons 'cb *tags*))) (let ((lam (c1lambda-expr (cadddr def) (fun-name (car def))))) (add-info info (cadr lam)) ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args ;; via args-info-changed-vars (add-info (fun-info (car def)) (cadr lam)) (push (list (car def) lam) closures)))) ) (unless processed-flag (return-from closure-process)) )) ;;; end closure process (dolist** (def defs1) (when (or (fun-ref (car def)) (fun-ref-ccb (car def))) (setf (fun-cfun (car def)) (next-cfun)))) ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args ;; via args-info-changed-vars ;; ;; walk body a second time to gather info in labels lambda lists (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) (let ((*vars* *vars*)) (c1add-globals ss) (check-vdecl nil ts is) (setq body (c1decl-body other-decl body))) (add-info info (cadr body)) (if (or local-funs closures) (list 'labels info (nreverse local-funs) (nreverse closures) body) body)) (defun c2labels (local-funs closures body &aux (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) ;;; Prepare for cross-referencing closures. (dolist** (def closures) (let ((fun (car def))) (declare (object fun)) (setf (fun-ref fun) (vs-push)) (wt-nl) (wt-vs (fun-ref fun)) (wt "=MMcons(Cnil,") (wt-clink) (wt ");") (clink (fun-ref fun)) (setf (fun-ref-ccb fun) (ccb-vs-push)) )) (dolist** (def local-funs) (setf (fun-level (car def)) *level*) ;; Append *initial-ccb-vs* here and use it to initialize *initial-ccb-vs* when writing ;; the code for this function. Local functions, unlike closures, get an envinment ;; level with the *initial-ccb-vs* at this point, and *ccb-vs* can be further incremented ;; here, in c2tagbody-ccb, and in c2block-ccb. CM 20031130 (push (list nil *clink* *ccb-vs* (car def) (cadr def) *initial-ccb-vs*) *local-funs*)) ;;; Then make closures. (dolist** (def closures) (push (list 'closure (if (null *clink*) nil (cons 'fun-env 0)) *ccb-vs* (car def) (cadr def)) *local-funs*) (push (car def) *closures*) (wt-nl) (wt-vs* (fun-ref (car def))) (wt "=make_cclosure_new(" (c-function-name "LC" (fun-cfun (car def)) (fun-name (car def))) ",Cnil,") (wt-clink) (wt ",Cdata);") ) ;;; now the body of flet (c2expr body) ) (defun c1macrolet (args &aux body ss ts is other-decl (*funs* *funs*) (*vars* *vars*)) (when (endp args) (too-few-args 'macrolet 1 0)) (dolist** (def (car args)) (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def))) "The macro definition ~s is illegal." def) (push (list (car def) (caddr (si:defmacro* (car def) (cadr def) (cddr def)))) *funs*)) (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) (c1add-globals ss) (check-vdecl nil ts is) (c1decl-body other-decl body) ) (defun c1local-fun (fname &aux (ccb nil)) (declare (object ccb)) (dolist* (fun *funs* nil) (cond ((eq fun 'CB) (setq ccb t)) ((consp fun) (when (eq (car fun) fname) (return (cadr fun)))) ((eq (fun-name fun) fname) (if ccb (setf (fun-ref-ccb fun) t) (setf (fun-ref fun) t)) ;; Add fun-info here at the bottom of the call-local processing tree ;; FIXME -- understand why special variable *info* is used in certain ;; cases and copy-info in othes. ;; This extends local call arg side-effect protection (via args-info-changed-vars) ;; through c1funob to other call methods than previously supported c1symbol-fun, ;; e.g. c1multiple-value-call, etc. CM 20031030 (add-info *info* (fun-info fun)) (return (list 'call-local *info* fun ccb)))))) (defun sch-local-fun (fname) ;;; Returns fun-ob for the local function (not locat macro) named FNAME, ;;; if any. Otherwise, returns FNAME itself. (dolist* (fun *funs* fname) (when (and (not (eq fun 'CB)) (not (consp fun)) (eq (fun-name fun) fname)) (return fun))) ) (defun c1local-closure (fname &aux (ccb nil)) (declare (object ccb)) ;;; Called only from C1FUNCTION. (dolist* (fun *funs* nil) (cond ((eq fun 'CB) (setq ccb t)) ((consp fun) (when (eq (car fun) fname) (return (cadr fun)))) ((eq (fun-name fun) fname) (setf (fun-ref-ccb fun) t) ;; Add fun-info here at the bottom of the call-local processing tree ;; FIXME -- understand why special variable *info* is used in certain ;; cases and copy-info in othes. ;; This extends local call arg side-effect protection (via args-info-changed-vars) ;; through c1funob to other call methods than previously supported c1symbol-fun, ;; e.g. c1multiple-value-call, etc. CM 20031030 (add-info *info* (fun-info fun)) (return (list 'call-local *info* fun ccb)))))) (defun c2call-local (fd args &aux (*vs* *vs*)) ;;; FD is a list ( fun-object ccb ). (cond ((cadr fd) (push-args args) (wt-nl "funcall(") (wt-ccb-vs (fun-ref-ccb (car fd))) (wt ");")) ((and (listp args) *do-tail-recursion* *tail-recursion-info* (eq (car *tail-recursion-info*) (car fd)) (eq *exit* 'RETURN) (tail-recursion-possible) (= (length args) (length (cdr *tail-recursion-info*)))) (let* ((*value-to-go* 'trash) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2psetq (mapcar #'(lambda (v) (list v nil)) (cdr *tail-recursion-info*)) args) (wt-label *exit*)) (unwind-no-exit 'tail-recursion-mark) (wt-nl "goto TTL;") (cmpnote "Tail-recursive call of ~s was replaced by iteration." (fun-name (car fd)))) (t (push-args args) (wt-nl (c-function-name "L" (fun-cfun (car fd)) (fun-name (car fd))) "(") (dotimes** (n (fun-level (car fd))) (if (when *closure-p* (zerop n)) (wt "fun->cc.cc_turbo,") (wt "base" n ","))) (wt "base") (unless (= (fun-level (car fd)) *level*) (wt (fun-level (car fd)))) (wt ");") (base-used))) (unwind-exit 'fun-val) ) gcl/cmpnew/gcl_cmpfun.lsp000077500000000000000000000774751242227143400160010ustar00rootroot00000000000000;; CMPFUN Library functions. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (si:putprop 'princ 'c1princ 'c1) (si:putprop 'princ 'c2princ 'c2) (si:putprop 'terpri 'c1terpri 'c1) (si:putprop 'apply 'c1apply 'c1) (si:putprop 'apply 'c2apply 'c2) (si:putprop 'apply-optimize 'c2apply-optimize 'c2) (si:putprop 'funcall 'c1funcall 'c1) (si:putprop 'rplaca 'c1rplaca 'c1) (si:putprop 'rplaca 'c2rplaca 'c2) (si:putprop 'rplacd 'c1rplacd 'c1) (si:putprop 'rplacd 'c2rplacd 'c2) (si:putprop 'si::memq 'c1memq 'c1) (si:putprop 'member 'c1member 'c1) (si:putprop 'member!2 'c2member!2 'c2) (si:putprop 'assoc 'c1assoc 'c1) (si:putprop 'assoc!2 'c2assoc!2 'c2) (si:putprop 'get 'c1get 'c1) (si:putprop 'get 'c2get 'c2) (si:putprop 'nth '(c1nth-condition . c1nth) 'c1conditional) (si:putprop 'nthcdr '(c1nthcdr-condition . c1nthcdr) 'c1conditional) (si:putprop 'si:rplaca-nthcdr 'c1rplaca-nthcdr 'c1) (si:putprop 'si:list-nth 'c1list-nth 'c1) (si:putprop 'list-nth-immediate 'c2list-nth-immediate 'c2) (si:putprop 'gethash 'c1gethash 'c1) (si:putprop 'gethash 'c2gethash 'c2) (defvar *princ-string-limit* 80) (defun c1princ (args &aux stream (info (make-info))) (when (endp args) (too-few-args 'princ 1 0)) (unless (or (endp (cdr args)) (endp (cddr args))) (too-many-args 'princ 2 (length args))) (setq stream (if (endp (cdr args)) (c1nil) (c1expr* (cadr args) info))) (if (and (or (and (stringp (car args)) (<= (length (car args)) *princ-string-limit*)) (characterp (car args))) (or (endp (cdr args)) (and (eq (car stream) 'var) (member (var-kind (caaddr stream)) '(GLOBAL SPECIAL))))) (list 'princ info (car args) (if (endp (cdr args)) nil (var-loc (caaddr stream))) stream) (list 'call-global info 'princ (list (c1expr* (car args) info) stream)))) (defun c2princ (string vv-index stream) (cond ((eq *value-to-go* 'trash) (cond ((characterp string) (wt-nl "princ_char(" (char-code string)) (if (null vv-index) (wt ",Cnil") (wt "," (vv-str vv-index))) (wt ");")) ((= (length string) 1) (wt-nl "princ_char(" (char-code (aref string 0))) (if (null vv-index) (wt ",Cnil") (wt "," (vv-str vv-index))) (wt ");")) (t (wt-nl "princ_str(\"") (dotimes** (n (length string)) (let ((char (schar string n))) (cond ((char= char #\\) (wt "\\\\")) ((char= char #\") (wt "\\\"")) ((char= char #\Newline) (wt "\\n")) (t (wt char))))) (wt "\",") (if (null vv-index) (wt "Cnil") (wt (vv-str vv-index))) (wt ");"))) (unwind-exit nil)) ((eql string #\Newline) (c2call-global 'terpri (list stream) nil t)) (t (c2call-global 'princ (list (list 'LOCATION (make-info :type (if (characterp string) 'character 'string)) (list 'VV (add-object string))) stream) nil t)))) (defun c1terpri (args &aux stream (info (make-info))) (unless (or (endp args) (endp (cdr args))) (too-many-args 'terpri 1 (length args))) (setq stream (if (endp args) (c1nil) (c1expr* (car args) info))) (if (or (endp args) (and (eq (car stream) 'var) (member (var-kind (caaddr stream)) '(GLOBAL SPECIAL)))) (list 'princ info #\Newline (if (endp args) nil (var-loc (caaddr stream))) stream) (list 'call-global info 'terpri (list stream)))) (defun c1apply (args &aux info) (when (or (endp args) (endp (cdr args))) (too-few-args 'apply 2 (length args))) (let ((funob (c1funob (car args)))) (setq info (copy-info (cadr funob))) (setq args (c1args (cdr args) info)) (cond ((eq (car funob) 'call-lambda) (let* ((lambda-expr (caddr funob)) (lambda-list (caddr lambda-expr))) (declare (object lambda-expr lambda-list)) (if (and (null (cadr lambda-list)) ; No optional (null (cadddr lambda-list))) ; No keyword (c1apply-optimize info (car lambda-list) (caddr lambda-list) (car (cddddr lambda-expr)) args) (list 'apply info funob args)))) (t (list 'apply info funob args)))) ) (defun c2apply (funob args &aux (*vs* *vs*) loc) (setq loc (save-funob funob)) (let ((*vs* *vs*) (base *vs*) (last-arg (list 'CVAR (next-cvar)))) (do ((l args (cdr l))) ((endp (cdr l)) (wt-nl "{object " last-arg ";") (let ((*value-to-go* last-arg)) (c2expr* (car l)))) (declare (object l)) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* (car l)))) (wt-nl " vs_top=base+" *vs* ";") (base-used) (cond (*safe-compile* (wt-nl " while(!endp(" last-arg "))") (wt-nl " {vs_push(car(" last-arg "));") (wt last-arg "=cdr(" last-arg ");}")) (t (wt-nl " while(" last-arg "!=Cnil)") (wt-nl " {vs_push((" last-arg ")->c.c_car);") (wt last-arg "=(" last-arg ")->c.c_cdr;}"))) (wt-nl "vs_base=base+" base ";}") (base-used)) (c2funcall funob 'args-pushed loc) ) (defun c1apply-optimize (info requireds rest body args &aux (vl nil) (fl nil)) (do () ((or (endp (cdr args)) (endp requireds))) (push (pop requireds) vl) (push (pop args) fl)) (cond ((cdr args) ;;; REQUIREDS is NIL. (cmpck (null rest) "APPLY passes too many arguments to LAMBDA expression.") (push rest vl) (push (list 'call-global info 'list* args) fl) (list 'let info (reverse vl) (reverse fl) body)) (requireds ;;; ARGS is singleton. (let ((temp (make-var :kind 'LEXICAL :ref t))) (push temp vl) (push (car args) fl) (list 'let info (reverse vl) (reverse fl) (list 'apply-optimize (cadr body) temp requireds rest body)))) (rest (push rest vl) (push (car args) fl) (list 'let info (reverse vl) (reverse fl) body)) (t (let ((temp (make-var :kind 'LEXICAL :ref t))) (push temp vl) (push (car args) fl) (list 'let info (reverse vl) (reverse fl) (list 'apply-optimize (cadr body) temp requireds rest body)))) ) ) (defun c2apply-optimize (temp requireds rest body &aux (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (when (or *safe-compile* *compiler-check-args*) (wt-nl (if rest "ck_larg_at_least" "ck_larg_exactly") "(" (length requireds) ",") (wt-var temp nil) (wt ");")) (dolist** (v requireds) (setf (var-ref v) (vs-push))) (when rest (setf (var-ref rest) (vs-push))) (do ((n 0 (1+ n)) (vl requireds (cdr vl))) ((endp vl) (when rest (wt-nl) (wt-vs (var-ref rest)) (wt "= ") (dotimes** (i n) (wt "(")) (wt-var temp nil) (dotimes** (i n) (wt-nl ")->c.c_cdr")) (wt ";"))) (declare (fixnum n) (object vl)) (wt-nl) (wt-vs (var-ref (car vl))) (wt "=(") (dotimes** (i n) (wt "(")) (wt-var temp nil) (dotimes** (i n) (wt-nl ")->c.c_cdr")) (wt ")->c.c_car;")) (dolist** (var requireds) (c2bind var)) (when rest (c2bind rest)) (c2expr body) ) (defun c1funcall (args &aux funob (info (make-info))) (when (endp args) (too-few-args 'funcall 1 0)) (setq funob (c1funob (car args))) (add-info info (cadr funob)) (list 'funcall info funob (c1args (cdr args) info)) ) (defun c1rplaca (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'rplaca 2 (length args))) (unless (endp (cddr args)) (too-many-args 'rplaca 2 (length args))) (setq args (c1args args info)) (list 'rplaca info args)) (defun c2rplaca (args &aux (*vs* *vs*) (*inline-blocks* 0)) (setq args (inline-args args '(t t))) (safe-compile (wt-nl "if(type_of(" (car args) ")!=t_cons)" "FEwrong_type_argument(Scons," (car args) ");")) (wt-nl "(" (car args) ")->c.c_car = " (cadr args) ";") (unwind-exit (car args)) (close-inline-blocks) ) (defun c1rplacd (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'rplacd 2 (length args))) (when (not (endp (cddr args))) (too-many-args 'rplacd 2 (length args))) (setq args (c1args args info)) (list 'rplacd info args)) (defun c2rplacd (args &aux (*vs* *vs*) (*inline-blocks* 0)) (setq args (inline-args args '(t t))) (safe-compile (wt-nl "if(type_of(" (car args) ")!=t_cons)" "FEwrong_type_argument(Scons," (car args) ");")) (wt-nl "(" (car args) ")->c.c_cdr = SAFE_CDR(" (cadr args) ");") (unwind-exit (car args)) (close-inline-blocks) ) (defun c1memq (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'si::memq 2 (length args))) (unless (endp (cddr args)) (too-many-args 'si::memq 2 (length args))) (list 'member!2 info 'eq (c1args (list (car args) (cadr args)) info))) (defun c1member (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'member 2 (length args))) (cond ((endp (cddr args)) (list 'member!2 info 'eql (c1args args info))) ((and (eq (caddr args) :test) (eql (length args) 4) (member (cadddr args) '('eq #'eq 'equal #'equal 'equalp #'equalp 'eql #'eql) :test 'equal)) (list 'member!2 info (cadr (cadddr args)) (c1args (list (car args) (cadr args)) info))) (t (list 'call-global info 'member (c1args args info))))) (defun c2member!2 (fun args &aux (*vs* *vs*) (*inline-blocks* 0) (l (next-cvar))) (setq args (inline-args args '(t t))) (wt-nl "{register object x= " (car args) ",V" l "= " (cadr args) ";") (if *safe-compile* (wt-nl "while(!endp(V" l "))") (wt-nl "while(V" l "!=Cnil)")) (if (eq fun 'eq) (wt-nl "if(x==(V" l "->c.c_car)){") (wt-nl "if(" (string-downcase (symbol-name fun)) "(x,V" l "->c.c_car)){")) (if (and (consp *value-to-go*) (or (eq (car *value-to-go*) 'JUMP-TRUE) (eq (car *value-to-go*) 'JUMP-FALSE))) (unwind-exit t 'JUMP) (unwind-exit (list 'CVAR l) 'JUMP)) (wt-nl "}else V" l "=V" l "->c.c_cdr;") (unwind-exit nil) (wt "}") (close-inline-blocks) ) (defun c1assoc (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'assoc 2 (length args))) (cond ((endp (cddr args)) (list 'assoc!2 info 'eql (c1args args info))) ((and (eq (caddr args) ':test) (eql (length args) 4) (member (cadddr args) '('eq #'eq 'equal #'equal 'equalp #'equalp 'eql #'eql) :test 'equal)) (list 'assoc!2 info (cadr (cadddr args)) (c1args (list (car args) (cadr args)) info))) (t (list 'call-global info 'assoc (c1args args info))))) (defun c2assoc!2 (fun args &aux (*vs* *vs*) (*inline-blocks* 0) (al (next-cvar))name) (setq args (inline-args args '(t t))) (setq name (symbol-name fun)) (or (eq fun 'eq) (setq name (string-downcase name))) (wt-nl "{register object x= " (car args) ",V" al "= " (cadr args) ";") (cond (*safe-compile* (wt-nl "while(!endp(V" al "))") (wt-nl "if(type_of(V"al"->c.c_car)==t_cons &&" name "(x,V" al "->c.c_car->c.c_car)){")) (t (wt-nl "while(V" al "!=Cnil)") (wt-nl "if(" name "(x,V" al "->c.c_car->c.c_car) &&" "V"al"->c.c_car != Cnil){"))) (if (and (consp *value-to-go*) (or (eq (car *value-to-go*) 'jump-true) (eq (car *value-to-go*) 'jump-false))) (unwind-exit t 'jump) (unwind-exit (list 'CAR al) 'jump)) (wt-nl "}else V" al "=V" al "->c.c_cdr;") (unwind-exit nil) (wt "}") (close-inline-blocks) ) (defun boole3 (a b c) (boole a b c)) ;(si:putprop 'boole '(c1boole-condition . c1boole3) 'c1conditional) (defun c1boole-condition (args) (and (not (endp (cddr args))) (endp (cdddr args)) (inline-boole3-string (car args)))) (defun c1boole3 (args) (c1expr (cons 'boole3 args))) (defun inline-boole3 (&rest args) (let ((boole-op-arg (second (car args)))) (or (eq (car boole-op-arg) 'fixnum-value) (error "must be constant")) (let ((string (inline-boole3-string (third boole-op-arg)))) (or string (error "should not get here boole opt")) (wt-inline-loc string (cdr args))))) (defun inline-boole3-string (op-code) (and (constantp op-code) (setq op-code (eval op-code))) (case op-code (#. boole-andc1 "((~(#0))&(#1))") (#. boole-andc2 "(((#0))&(~(#1)))") (#. boole-nor "(~((#0)|(#1)))") (#. boole-orc1 "(~(#0)) | (#1)))") (#. boole-orc2 "((#0) | (~(#1)))") (#. boole-nand "(~((#0) & (#1)))") (#. boole-eqv "(~((#0) ^ (#1)))") (#. boole-and "((#0) & (#1))") (#. boole-xor "((#0) ^ (#1))") (#. boole-ior "((#0) | (#1))"))) (si:putprop 'ash '(c1ash-condition . c1ash) 'c1conditional) (defun c1ash-condition (args &aux (z '#.(let ((z (integer-length most-positive-fixnum))) `(integer ,(- z) ,z)))) (let ((shamt (second args))) (or (typep shamt z) (and (consp shamt) (eq (car shamt) 'the) (let ((type (cadr shamt))) (subtypep type z)))))) (defun c1ash (args) (let ((shamt (second args))fun) (cond ((constantp shamt) (setq shamt (eval shamt)) (or (si:fixnump shamt) (error "integer shift only")) (cond ((< shamt 0) (setq fun 'shift>> )) ((>= shamt 0) (setq fun 'shift<<)))) (t (let ((type (second shamt))) ;;it had to be a (the type..) (cond ((subtypep type '#.`(integer 0 ,(integer-length most-positive-fixnum))) (setq fun 'shift<< )) ((subtypep type '#.`(integer ,(- (integer-length most-positive-fixnum)) 0)) (setq fun 'shift>> )) (t (error "should not get here"))) ))) (c1expr (cons fun args)))) (defun shift>> (a b) (ash a b)) (defun shift<< (a b) (ash a b)) (si:putprop 'ash '(c1ash-condition . c1ash) 'c1conditional) (si:putprop 'shift>> "Lash" 'lfun) (si:putprop 'shift<< "Lash" 'lfun) (si::putprop 'ldb 'co1ldb 'co1) (defun co1ldb (f args &aux tem (len (integer-length most-positive-fixnum))) f (let ((specs (cond ((and (consp (setq tem (first args))) (eq 'byte (car tem)) (cons (second tem) (third tem))))))) (cond ((and (integerp (cdr specs)) (integerp (car specs)) (< (+ (car specs)(cdr specs)) len) (subtypep (result-type (second args)) 'fixnum)) (c1expr `(the fixnum (si::ldb1 ,(car specs) ,(cdr specs) ,(second args)))))))) (si:putprop 'length 'c1length 'c1) (defun c1length (args &aux (info (make-info))) (setf (info-type info) 'fixnum) (cond ((and (consp (car args)) (eq (caar args) 'symbol-name) (let ((args1 (cdr (car args)))) (and args1 (not (cddr args1)) (list 'call-global info 'symbol-length (c1args args1 info)))))) (t (setq args (c1args args info)) (list 'call-global info 'length args )))) (defun c1get (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'get 2 (length args))) (when (and (not (endp (cddr args))) (not (endp (cdddr args)))) (too-many-args 'get 3 (length args))) (list 'get info (c1args args info))) (defun c2get (args) (if *safe-compile* (c2call-global 'get args nil t) (let ((*vs* *vs*) (*inline-blocks* 0) (pl (next-cvar))) (setq args (inline-args args (if (cddr args) '(t t t) '(t t)))) (wt-nl "{object V" pl" =(" (car args) ")->s.s_plist;") (wt-nl " object ind= " (cadr args) ";") (wt-nl "while(V" pl "!=Cnil){") (wt-nl "if(V" pl "->c.c_car==ind){") (unwind-exit (list 'CADR pl) 'jump) (wt-nl "}else V" pl "=V" pl "->c.c_cdr->c.c_cdr;}") (unwind-exit (if (cddr args) (caddr args) nil)) (wt "}") (close-inline-blocks))) ) (defun co1eql (f args) f (or (and (cdr args) (not *safe-compile*)) (return-from co1eql nil)) (cond ((replace-constant args) (cond ((characterp (second args)) (setq args (reverse args)))) (cond ((characterp (car args)) (let ((c (gensym))) (c1expr `(let ((,c ,(second args))) (declare (type ,(result-type (second args)) ,c)) (and (typep ,c 'character) (= (char-code ,(car args)) (the fixnum (char-code (the character ,c))) )))))))))) (si::putprop 'eql 'co1eql 'co1) (defvar *frozen-defstructs* nil) ;; Return the most particular type we can EASILY obtain ;; from x. (defun result-type (x) (cond ((symbolp x) (let ((tem (c1expr x))) (info-type (second tem)))) ((constantp x) (type-filter (type-of x))) ((and (consp x) (eq (car x) 'the)) (type-filter (second x))) (t t))) (defvar *type-alist* '((fixnum . si::fixnump) (float . floatp) (si::spice . si::spice-p) (short-float . short-float-p) (long-float . long-float-p) (integer . integerp) (character . characterp) (symbol . symbolp) (cons . consp) (null . null) (array . arrayp) (vector . vectorp) (bit-vector . bit-vector-p) (string . stringp) (list . (lambda (y) (or (consp y) (null y)))) (number . numberp) (rational . rationalp) (complex . complexp) (ratio . ratiop) (sequence . (lambda (y) (or (listp y) (vectorp y)))) (function . functionp) )) (defun co1typep (f args &aux tem) f (let* ((x (car args)) new (type (and (consp (second args)) (eq (car (second args)) 'quote) (second (second args))))) (cond ((subtypep (result-type (car args)) type) (setq new t) (return-from co1typep (c1expr new)))) (setq new (cond ((null type) nil) ((setq f (assoc type *type-alist* :test 'equal)) (list (cdr f) x)) ((and (consp type) (or (and (eq (car type) 'vector) (null (cddr type))) (and (member (car type) '(array vector simple-array)) (equal (third type) '(*))))) (setq tem (si::best-array-element-type (second type))) (cond ((eq tem 'string-char) `(stringp ,x)) ((eq tem 'bit) `(bit-vector-p ,x)) ((setq tem (position tem *aet-types*)) `(the boolean (vector-type ,x ,tem))))) ((and (consp type) (eq (car type) 'satisfies) (consp (cdr type)) (cadr type) (symbolp (cadr type)) (symbol-package (cadr type)) (null (cddr type)) `(,(cadr type) ,x))) ((subtypep type 'fixnum) (setq tem (si::normalize-type type)) (and (consp tem) (si::fixnump (second tem)) (si::fixnump (third tem)) `(let ((.tem ,x)) (declare (type ,(result-type x) .tem)) (and (typep .tem 'fixnum) (>= (the fixnum .tem) ,(second tem)) (<= (the fixnum .tem) ,(third tem)))))) ((and (symbolp type) (setq tem (get type 'si::s-data))) (cond ((or (si::s-data-frozen tem) *frozen-defstructs*) (struct-type-opt x tem)) (t `(si::structure-subtype-p ,x ',type)))) ; ((and (print (list 'slow 'typep type)) nil)) (t nil))) (and new (c1expr `(the boolean , new))))) ;; this is going the wrong way. want to go up.. (defun struct-type-opt (x sd) (let ((s (gensym)) (included (get-included (si::s-data-name sd)))) `(let ((,s ,x)) (and (si::structurep ,s) ,(cond ((< (length included) 3) `(or ,@ (mapcar #'(lambda (x) `(eq (si::structure-def ,s) ,(name-sd1 x))) included))) (t `(si::structure-subtype-p ,s ,(name-sd1 (si::s-data-name sd))))))))) (defun get-included (name) (let ((sd (get name 'si::s-data))) (cons (si::s-data-name sd) (mapcan 'get-included (si::s-data-included sd))))) (si::putprop 'typep 'co1typep 'co1) (defun co1schar (f args) f (and (listp (car args)) (not *safe-compile*) (cdr args) (eq (caar args) 'symbol-name) (c1expr `(aref (the string ,(second (car args))) ,(second args))))) (si::putprop 'schar 'co1schar 'co1) (si::putprop 'cons 'co1cons 'co1) ;; turn repetitious cons's into a list* (defun cons-to-lista (x) (let ((tem (last x))) (cond ((and (consp tem) (consp (car tem)) (eq (caar tem) 'cons) (eql (length (cdar tem)) 2) (cons-to-lista (append (butlast x) (cdar tem))))) (t x)))) (defun co1cons (f args) f (let ((tem (and (eql (length args) 2) (cons-to-lista args)))) (and (not (eq tem args)) (c1expr (if (equal '(nil) (last tem)) (cons 'list (butlast tem)) (cons 'list* tem)))))) ;; I don't feel it is good to replace the list call, but rather ;; usually better the other way around. We removed c1list ;; because of possible feedback. (defun c1nth-condition (args) (and (not (endp args)) (not (endp (cdr args))) (endp (cddr args)) (numberp (car args)) (<= 0 (car args) 7))) (defun c1nth (args) (c1expr (case (car args) (0 (cons 'car (cdr args))) (1 (cons 'cadr (cdr args))) (2 (cons 'caddr (cdr args))) (3 (cons 'cadddr (cdr args))) (4 (list 'car (cons 'cddddr (cdr args)))) (5 (list 'cadr (cons 'cddddr (cdr args)))) (6 (list 'caddr (cons 'cddddr (cdr args)))) (7 (list 'cadddr (cons 'cddddr (cdr args)))) ))) (defun c1nthcdr-condition (args) (and (not (endp args)) (not (endp (cdr args))) (endp (cddr args)) (numberp (car args)) (<= 0 (car args) 7))) (defun c1nthcdr (args) (c1expr (case (car args) (0 (cadr args)) (1 (cons 'cdr (cdr args))) (2 (cons 'cddr (cdr args))) (3 (cons 'cdddr (cdr args))) (4 (cons 'cddddr (cdr args))) (5 (list 'cdr (cons 'cddddr (cdr args)))) (6 (list 'cddr (cons 'cddddr (cdr args)))) (7 (list 'cdddr (cons 'cddddr (cdr args)))) ))) (defun c1rplaca-nthcdr (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args)) (endp (cddr args))) (too-few-args 'si:rplaca-nthcdr 3 (length args))) (unless (endp (cdddr args)) (too-few-args 'si:rplaca-nthcdr 3 (length args))) (if (and (numberp (cadr args)) (<= 0 (cadr args) 10)) (let ((x (gensym))(y (gensym))) (c1expr `(let ((,x ,(car args)) (,y ,(third args))) (setf ,x (nthcdr ,(cadr args) ,x)) (setf (car ,x) ,y) ,y))) (list 'call-global info 'si:rplaca-nthcdr (c1args args info)))) ;; Facilities for faster reading and writing from file streams. ;; You must declare the stream to be :in-file ;; or :out-file (si::putprop 'read-byte 'co1read-byte 'co1) (si::putprop 'read-char 'co1read-char 'co1) (si::putprop 'write-byte 'co1write-byte 'co1) (si::putprop 'write-char 'co1write-char 'co1) (defun fast-read (args read-fun) (cond ((and (not *safe-compile*) (< *space* 2) (null (second args)) (boundp 'si::*eof*)) (cond ((atom (car args)) (or (car args) (setq args (cons '*standard-input* (cdr args)))) (let ((stream (car args)) (eof (third args))) `(let ((ans 0)) (declare (fixnum ans)) (cond ((fp-okp ,stream) (setq ans (sgetc1 ,stream)) (cond ((and (eql ans ,si::*eof*) (sfeof ,stream)) ,eof) (t ,(if (eq read-fun 'read-char1) '(code-char ans) 'ans)) )) (t (,read-fun ,stream ,eof) ) )))) (t `(let ((.strm. ,(car args))) (declare (type ,(result-type (car args)) .strm.)) ,(fast-read (cons '.strm. (cdr args)) read-fun))))))) (defun co1read-byte (f args &aux tem) f (cond ((setq tem (fast-read args 'read-byte1)) (let ((*space* 10)) ;prevent recursion! (c1expr tem))))) (defun co1read-char (f args &aux tem) f (cond ((setq tem (fast-read args 'read-char1)) (let ((*space* 10)) ;prevent recursion! (c1expr tem))))) (defun cfast-write (args write-fun) (cond ((and (not *safe-compile*) (< *space* 2) (boundp 'si::*eof*)) (let ((stream (second args))) (or stream (setq stream '*standard-output*)) (cond ((atom stream) `(cond ((fp-okp ,stream) (the fixnum (sputc .ch ,stream))) (t (,write-fun .ch ,stream)))) (t `(let ((.str ,stream)) (declare (type ,(result-type stream) .str)) ,(cfast-write (list '.ch '.str) write-fun)))))))) (defun co1write-byte (f args) f (let ((tem (cfast-write args 'write-byte))) (if tem (let ((*space* 10)) (c1expr `(let ((.ch ,(car args))) (declare (fixnum .ch)) ,tem ,(if (atom (car args)) (car args) '.ch))))))) (defun co1write-char (f args) f (let ((tem (cfast-write args 'write-char))) (if tem (let ((*space* 10)) (c1expr `(let ((.ch ,(car args))) (declare (character .ch)) ,tem ,(if (atom (car args)) (car args) '.ch))))))) (defvar *aet-types* #(T STRING-CHAR SIGNED-CHAR FIXNUM SHORT-FLOAT LONG-FLOAT SIGNED-CHAR UNSIGNED-CHAR SIGNED-SHORT UNSIGNED-SHORT)) (defun aet-c-type (type) (ecase type ((t) "object") ((string-char signed-char) "char") (fixnum "fixnum") (unsigned-char "unsigned char") (unsigned-short "unsigned short") (signed-short "short") (unsigned-short "unsigned short") (long-float "longfloat") (short-float "shortfloat"))) (si:putprop 'vector-push 'co1vector-push 'co1) (si:putprop 'vector-push-extend 'co1vector-push 'co1) (defun co1vector-push (f args) f (unless (or *safe-compile* (> *space* 3) (null (cdr args)) ) (let ((*space* 10)) (c1expr `(let* ((.val ,(car args)) (.v ,(second args)) (.i (fill-pointer .v)) (.dim (array-total-size .v))) (declare (fixnum .i .dim)) (declare (type ,(result-type (second args)) .v)) (declare (type ,(result-type (car args)) .val)) (cond ((< .i .dim) (the fixnum (si::fill-pointer-set .v (the fixnum (+ 1 .i)))) (si::aset .v .i .val) .i) (t ,(cond ((eq f 'vector-push-extend) `(vector-push-extend .val .v ,@(cddr args))))))))))) (defun constant-fold-p (x) (cond ((constantp x) t) ((atom x) nil) ((eq (car x) 'the) (constant-fold-p (third x))) ((and (symbolp (car x)) (eq (get (car x) 'co1) 'co1constant-fold)) (dolist (w (cdr x)) (or (constant-fold-p w) (return-from constant-fold-p nil))) t) (t nil))) (defun co1constant-fold (f args ) (cond ((and (fboundp f) (dolist (v args t) (or (constant-fold-p v) (return-from co1constant-fold nil)))) (c1expr (cmp-eval (cons f args)))))) (si::putprop 'do 'co1special-fix-decl 'co1special) (si::putprop 'do* 'co1special-fix-decl 'co1special) (si::putprop 'prog 'co1special-fix-decl 'co1special) (si::putprop 'prog* 'co1special-fix-decl 'co1special) (defun co1special-fix-decl (f args) (flet ((fixup (forms &aux decls ) (block nil (tagbody top (or (consp forms) (go end)) (let ((tem (car forms))) (if (and (consp tem) (setq tem (cmp-macroexpand tem)) (eq (car tem) 'declare)) (progn (push tem decls) (pop forms)) (go end))) (go top) ; all decls made explicit. end (return (nconc (nreverse decls) forms)))))) (c1expr (cmp-macroexpand (case f ((do do*) `(,f ,(car args) ,(second args) ,@ (fixup (cddr args)))) ((prog prog*) `(,f ,(car args) ,@ (fixup (cdr args))))))))) (si::putprop 'sublis 'co1sublis 'co1) (defun co1sublis (f args &aux test) f (and (case (length args) (2 (setq test 'eql)) (4 (and (eq (third args) :test) (cond ((member (fourth args) '(equal (function equal))) (setq test 'equal)) ((member (fourth args) '(eql (function eql))) (setq test 'eql)) ((member (fourth args) '(eq (function eq))) (setq test 'eq)) )))) (let ((s (gensym))) (c1expr `(let ((,s ,(car args))) (sublis1 ,s ,(second args) ',test)))))) (defun sublis1-inline (a b c) (let ((tst (ltvp-eval (cadr c)))) (or (member tst '(eq equal eql)) (error "bad test")) (wt "(check_alist(" a "),sublis1("a "," b "," (format nil "&o~(~a~)))" tst)))) ;; end new (defun c1list-nth (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'si:rplaca-nthcdr 2 (length args))) (unless (endp (cddr args)) (too-few-args 'si:rplaca-nthcdr 2 (length args))) (if (and (numberp (car args)) (<= 0 (car args) 10)) (list 'list-nth-immediate info (car args) (c1args (list (cadr args)) info)) (list 'call-global info 'si:list-nth (c1args args info)))) (defun c2list-nth-immediate (index args &aux (l (next-cvar)) (*vs* *vs*) (*inline-blocks* 0)) (setq args (inline-args args '(t t))) (wt-nl "{object V" l "= ") (if *safe-compile* (progn (dotimes** (i index) (wt "cdr(")) (wt (car args)) (dotimes** (i index) (wt ")")) (wt ";") (wt-nl "if((type_of(V" l ")!=t_cons) && (" (car args) "!= Cnil))") (wt-nl " FEwrong_type_argument(Scons,V" l ");") ) (progn (wt-nl (car args)) (dotimes** (i index) (wt-nl "->c.c_cdr")) (wt ";"))) (unwind-exit (list 'CAR l)) (wt "}") (close-inline-blocks) ) (defun c1gethash (args) (unless (cdr args) (too-few-args 'gethash 2 (length args))) (when (cdddr args) (too-many-args 'gethash 3 (length args))) (let* ((info (make-info)) (nargs (c1args args info))) `(gethash ,info ,nargs))) (defun c2gethash (args) (cond ((member *value-to-go* '(top return)) (let* ((nargs (inline-args args '(t t))) (base *vs*)(*vs* *vs*) (r (cdr (vs-push)))(f (cdr (vs-push)))) (wt-nl "{ struct htent *_z=gethash" (if *safe-compile* "_with_check" "") "(" (car nargs) "," (cadr nargs) ");") (wt-nl "if (_z->hte_key==OBJNULL) {") (wt-nl "base[" r "]=" (caddr nargs) ";") (wt-nl "base[" f "]=Cnil;") (wt-nl "} else {") (wt-nl "base[" r "]=_z->hte_value;") (wt-nl "base[" f "]=Ct;") (wt-nl "}}") (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";") (unwind-exit 'fun-val nil (cons 'values 2)))) ((unwind-exit (get-inline-loc `((t t) t #.(flags rfa) ,(concatenate 'string "({struct htent *_z=gethash" (if *safe-compile* "_with_check" "") "(#0,#1);_z->hte_key==OBJNULL ? (#2) : _z->hte_value;})")) args))))) gcl/cmpnew/gcl_cmpif.lsp000077500000000000000000000376631242227143400156020ustar00rootroot00000000000000;;; CMPIF Conditionals. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (si:putprop 'if 'c1if 'c1special) (si:putprop 'if 'c2if 'c2) (si:putprop 'and 'c1and 'c1) (si:putprop 'and 'c2and 'c2) (si:putprop 'or 'c1or 'c1) (si:putprop 'or 'c2or 'c2) (si:putprop 'jump-true 'set-jump-true 'set-loc) (si:putprop 'jump-false 'set-jump-false 'set-loc) (si:putprop 'case 'c1case 'c1) (si:putprop 'ecase 'c1ecase 'c1) (si:putprop 'case 'c2case 'c2) (defun c1if (args &aux info f) (when (or (endp args) (endp (cdr args))) (too-few-args 'if 2 (length args))) (unless (or (endp (cddr args)) (endp (cdddr args))) (too-many-args 'if 3 (length args))) (setq f (c1fmla-constant (car args))) (case f ((t) (c1expr (cadr args))) ((nil) (if (endp (cddr args)) (c1nil) (c1expr (caddr args)))) (otherwise (setq info (make-info)) (list 'if info (c1fmla f info) (c1expr* (cadr args) info) (if (endp (cddr args)) (c1nil) (c1expr* (caddr args) info))))) ) (defun c1fmla-constant (fmla &aux f) (cond ((consp fmla) (case (car fmla) (and (do ((fl (cdr fmla) (cdr fl))) ((endp fl) t) (declare (object fl)) (setq f (c1fmla-constant (car fl))) (case f ((t)) ((nil) (return nil)) (t (if (endp (cdr fl)) (return f) (return (list* 'and f (cdr fl)))))))) (or (do ((fl (cdr fmla) (cdr fl))) ((endp fl) nil) (declare (object fl)) (setq f (c1fmla-constant (car fl))) (case f ((t) (return t)) ((nil)) (t (if (endp (cdr fl)) (return f) (return (list* 'or f (cdr fl)))))))) ((not null) (when (endp (cdr fmla)) (too-few-args 'not 1 0)) (unless (endp (cddr fmla)) (too-many-args 'not 1 (length (cdr fmla)))) (setq f (c1fmla-constant (cadr fmla))) (case f ((t) nil) ((nil) t) (t (list 'not f)))) (t fmla))) ((symbolp fmla) (if (constantp fmla) (if (symbol-value fmla) t nil) fmla)) (t t)) ) (defun c1fmla (fmla info) (if (consp fmla) (case (car fmla) (and (case (length (cdr fmla)) (0 (c1t)) (1 (c1fmla (cadr fmla) info)) (t (cons 'FMLA-AND (mapcar #'(lambda (x) (c1fmla x info)) (cdr fmla)))))) (or (case (length (cdr fmla)) (0 (c1nil)) (1 (c1fmla (cadr fmla) info)) (t (cons 'FMLA-OR (mapcar #'(lambda (x) (c1fmla x info)) (cdr fmla)))))) ((not null) (when (endp (cdr fmla)) (too-few-args 'not 1 0)) (unless (endp (cddr fmla)) (too-many-args 'not 1 (length (cdr fmla)))) (list 'FMLA-NOT (c1fmla (cadr fmla) info))) (t (c1expr* `(the boolean ,fmla) info))) (c1expr* fmla info)) ) (defun c2if (fmla form1 form2 &aux (Tlabel (next-label)) Flabel) (cond ((and (eq (car form2) 'LOCATION) (null (caddr form2)) (eq *value-to-go* 'TRASH) (not (eq *exit* 'RETURN))) (let ((exit *exit*) (*unwind-exit* (cons Tlabel *unwind-exit*)) (*exit* Tlabel)) (CJF fmla Tlabel exit)) (wt-label Tlabel) (c2expr form1)) (t (setq Flabel (next-label)) (let ((*unwind-exit* (cons Flabel (cons Tlabel *unwind-exit*))) (*exit* Tlabel)) (CJF fmla Tlabel Flabel)) (wt-label Tlabel) (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr form1)) (wt-label Flabel) (c2expr form2))) ) ;;; If fmla is true, jump to Tlabel. If false, do nothing. (defun CJT (fmla Tlabel Flabel) (case (car fmla) (fmla-and (do ((fs (cdr fmla) (cdr fs))) ((endp (cdr fs)) (CJT (car fs) Tlabel Flabel)) (declare (object fs)) (let* ((label (next-label)) (*unwind-exit* (cons label *unwind-exit*))) (CJF (car fs) label Flabel) (wt-label label)))) (fmla-or (do ((fs (cdr fmla) (cdr fs))) ((endp (cdr fs)) (CJT (car fs) Tlabel Flabel)) (declare (object fs)) (let* ((label (next-label)) (*unwind-exit* (cons label *unwind-exit*))) (CJT (car fs) Tlabel label) (wt-label label)))) (fmla-not (CJF (cadr fmla) Flabel Tlabel)) (LOCATION (case (caddr fmla) ((t) (unwind-no-exit Tlabel) (wt-nl) (wt-go Tlabel)) ((nil)) (t (let ((*value-to-go* (list 'jump-true Tlabel))) (c2expr* fmla))))) (t (let ((*value-to-go* (list 'jump-true Tlabel))) (c2expr* fmla)))) ) ;;; If fmla is false, jump to Flabel. If true, do nothing. (defun CJF (fmla Tlabel Flabel) (case (car fmla) (FMLA-AND (do ((fs (cdr fmla) (cdr fs))) ((endp (cdr fs)) (CJF (car fs) Tlabel Flabel)) (declare (object fs)) (let* ((label (next-label)) (*unwind-exit* (cons label *unwind-exit*))) (CJF (car fs) label Flabel) (wt-label label)))) (FMLA-OR (do ((fs (cdr fmla) (cdr fs))) ((endp (cdr fs)) (CJF (car fs) Tlabel Flabel)) (declare (object fs)) (let* ((label (next-label)) (*unwind-exit* (cons label *unwind-exit*))) (CJT (car fs) Tlabel label) (wt-label label)))) (FMLA-NOT (CJT (cadr fmla) Flabel Tlabel)) (LOCATION (case (caddr fmla) ((t)) ((nil) (unwind-no-exit Flabel) (wt-nl) (wt-go Flabel)) (t (let ((*value-to-go* (list 'jump-false Flabel))) (c2expr* fmla))))) (t (let ((*value-to-go* (list 'jump-false Flabel))) (c2expr* fmla)))) ) (defun c1and (args) (cond ((endp args) (c1t)) ((endp (cdr args)) (c1expr (car args))) (t (let ((info (make-info))) (list 'AND info (c1args args info)))))) (defun c2and (forms) (do ((forms forms (cdr forms))) ((endp (cdr forms)) (c2expr (car forms))) (declare (object forms)) (cond ((eq (caar forms) 'LOCATION) (case (caddar forms) ((t)) ((nil) (unwind-exit nil 'JUMP)) (t (wt-nl "if(" (caddar forms) "==Cnil){") (unwind-exit nil 'JUMP) (wt "}") ))) ((eq (caar forms) 'VAR) (wt-nl "if(") (wt-var (car (caddar forms)) (cadr (caddar forms))) (wt "==Cnil){") (unwind-exit nil 'jump) (wt "}")) (t (let* ((label (next-label)) (*unwind-exit* (cons label *unwind-exit*))) (let ((*value-to-go* (list 'jump-true label))) (c2expr* (car forms))) (unwind-exit nil 'jump) (wt-label label)))) )) (defun c1or (args) (cond ((endp args) (c1nil)) ((endp (cdr args)) (c1expr (car args))) (t (let ((info (make-info))) (list 'OR info (c1args args info)))))) (defun c2or (forms &aux (*vs* *vs*) temp) (do ((forms forms (cdr forms)) ) ((endp (cdr forms)) (c2expr (car forms))) (declare (object forms)) (cond ((eq (caar forms) 'LOCATION) (case (caddar forms) ((t) (unwind-exit t 'JUMP)) ((nil)) (t (wt-nl "if(" (caddar forms) "!=Cnil){") (unwind-exit (caddar forms) 'JUMP) (wt "}")))) ((eq (caar forms) 'VAR) (wt-nl "if(") (wt-var (car (caddar forms)) (cadr (caddar forms))) (wt "!=Cnil){") (unwind-exit (cons 'VAR (caddar forms)) 'jump) (wt "}")) ((and (eq (caar forms) 'CALL-GLOBAL) (get (caddar forms) 'predicate)) (let* ((label (next-label)) (*unwind-exit* (cons label *unwind-exit*))) (let ((*value-to-go* (list 'jump-false label))) (c2expr* (car forms))) (unwind-exit t 'jump) (wt-label label))) (t (let* ((label (next-label)) (*inline-blocks* 0) (*unwind-exit* (cons label *unwind-exit*))) (setq temp (wt-c-push)) (let ((*value-to-go* temp)) (c2expr* (car forms))) (wt-nl "if(" temp "==Cnil)") (wt-go label) (unwind-exit temp 'jump) (wt-label label) (close-inline-blocks) ))) ) ) (defun set-jump-true (loc label) (unless (null loc) (cond ((eq loc t)) ((and (consp loc) (eq (car loc) 'INLINE-COND)) (wt-nl "if(") (wt-inline-loc (caddr loc) (cadddr loc)) (wt ")")) (t (wt-nl "if((" loc ")!=Cnil)"))) (unless (eq loc t) (wt "{")) (unwind-no-exit label) (wt-nl) (wt-go label) (unless (eq loc t) (wt "}"))) ) (defun set-jump-false (loc label) (unless (eq loc t) (cond ((null loc)) ((and (consp loc) (eq (car loc) 'INLINE-COND)) (wt-nl "if(!(") (wt-inline-loc (caddr loc) (cadddr loc)) (wt "))")) (t (wt-nl "if((" loc ")==Cnil)"))) (unless (null loc) (wt "{")) (unwind-no-exit label) (wt-nl) (wt-go label) (unless (null loc) (wt "}"))) ) (defun c1ecase (args) (c1case args t)) ;;If the key is declared fixnum, then we convert a case statement to a switch, ;;so that we may see the benefit of a table jump. (defun convert-case-to-switch (args default) (let ((sym (gensym)) body keys) (dolist (v (cdr args)) (cond ((si::fixnump (car v)) (push (car v) body)) ((consp (car v))(dolist (w (car v)) (push w body))) ((member (car v) '(t otherwise)) (and default (cmperror "T or otherwise found in an ecase")) (push t body))) (push `(return-from ,sym (progn ,@ (cdr v))) body)) (cond (default (push t body) (dolist (v (cdr args)) (cond ((atom (car v)) (push (car v) keys)) (t (setq keys (append (car v) keys))))) (push `(error "The key ~a for ECASE was not found in cases ~a" ,(car args) ',keys) body))) `(block ,sym (si::switch ,(car args) ,@ (nreverse body))))) (defun c1case (args &optional (default nil)) (when (endp args) (too-few-args 'case 1 0)) (let* ((info (make-info)) (key-form (c1expr* (car args) info)) clauses) (cond ((subtypep (info-type (second key-form)) 'fixnum) (return-from c1case (c1expr (convert-case-to-switch args default ))))) (do ((c (cdr args) (cdr c))) ((not c)) (let* ((clause (car c))) (cmpck (endp clause) "The CASE clause ~S is illegal." clause) (let* ((k (pop clause))(dfp (unless default (member k '(t otherwise)))) (keylist (cond ((listp k) (mapcar (lambda (key) (if (symbolp key) key (add-object key))) k)) ((symbolp k) (when dfp (when (cdr c) (cmperr "default case found in bad place"))) (list k)) ((list (add-object k))))) (body (c1progn clause))) (add-info info (cadr body)) (if dfp (setq default body) (push (cons keylist body) clauses))))) (list 'case info key-form (nreverse clauses) (or default (c1nil))))) ;; (defun c1case (args &optional (default nil)) ;; (when (endp args) (too-few-args 'case 1 0)) ;; (let* ((info (make-info)) ;; (key-form (c1expr* (car args) info)) ;; (clauses nil)) ;; (cond ((subtypep (info-type (second key-form)) 'fixnum) ;; (return-from c1case (c1expr (convert-case-to-switch ;; args default ))))) ;; (dolist (clause (cdr args)) ;; (cmpck (endp clause) "The CASE clause ~S is illegal." clause) ;; (case (car clause) ;; ((nil)) ;; ((t otherwise) ;; (when default ;; (cmperr (if (eq default 't) ;; "ECASE had an OTHERWISE clause." ;; "CASE had more than one OTHERWISE clauses."))) ;; (setq default (c1progn (cdr clause))) ;; (add-info info (cadr default))) ;; (t (let* ((keylist ;; (cond ((consp (car clause)) ;; (mapcar #'(lambda (key) (if (symbolp key) key ;; (add-object key))) ;; (car clause))) ;; ((symbolp (car clause)) (list (car clause))) ;; (t (list (add-object (car clause)))))) ;; (body (c1progn (cdr clause)))) ;; (add-info info (cadr body)) ;; (push (cons keylist body) clauses))))) ;; (list 'case info key-form (reverse clauses) (or default (c1nil))))) (defun c2case (key-form clauses default &aux (cvar (next-cvar)) (*vs* *vs*) (*inline-blocks* 0)) (setq key-form (car (inline-args (list key-form) '(t)))) (wt-nl "{object V" cvar "= " key-form ";") (dolist (clause clauses) (let* ((label (next-label)) (keylist (car clause)) (local-label nil)) (do () ((<= (length keylist) 5)) (when (null local-label) (setq local-label (next-label))) (wt-nl "if(") (dotimes (i 5) (cond ((symbolp (car keylist)) (wt "(V" cvar "== ") (case (car keylist) ((t) (wt "Ct")) ((nil) (wt "Cnil")) (otherwise (wt (vv-str (add-symbol (car keylist)))))) (wt ")")) (t (wt "eql(V" cvar "," (vv-str (car keylist)) ")"))) (when (< i 4) (wt-nl "|| ")) (pop keylist)) (wt ")") (wt-go local-label)) (when keylist (wt-nl "if(") (do () ((endp keylist)) (cond ((symbolp (car keylist)) (wt "(V" cvar "!= ") (case (car keylist) ((t) (wt "Ct")) ((nil) (wt "Cnil")) (otherwise (wt (vv-str (add-symbol (car keylist)))))) (wt ")")) (t (wt "!eql(V" cvar "," (vv-str (car keylist)) ")"))) (unless (endp (cdr keylist)) (wt-nl "&& ")) (pop keylist)) (wt ")") (wt-go label) (when local-label (wt-label local-label)) (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr (cdr clause))) (wt-label label)))) (if (eq default 't) (progn (wt-nl "FEerror(\"The ECASE key value ~s is illegal.\",1,V" cvar ");") (unwind-exit nil 'jump)) (c2expr default)) (wt "}") (close-inline-blocks)) gcl/cmpnew/gcl_cmpinit.lsp000077500000000000000000000006301242227143400161270ustar00rootroot00000000000000;(proclaim '(optimize (safety 0) (space 3))) ;(proclaim '(optimize (safety 2) (space 3))) (load "../lsp/sys-proclaim.lisp") (load "sys-proclaim.lisp") (setq compiler::*eval-when-defaults* '(compile eval load)) ;(load "cmptop.lsp") ;(dolist (v '( cmpeval cmpopt cmptype cmpbind cmpinline cmploc cmpvar cmptop cmplet cmpcall cmpmulti cmplam cmplabel cmpeval )) (si::nload (format nil "~(~a~).lsp" v))) gcl/cmpnew/gcl_cmpinline.lsp000077500000000000000000000656631242227143400164630ustar00rootroot00000000000000;;; CMPINLINE Open coding optimizer. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) ;;; Pass 1 generates the internal form ;;; ( id info-object . rest ) ;;; for each form encountered. ;;; Change changed-vars and referrred-vars slots in info structure to arrays ;;; for dramatic compilation speed improvements when the number of variables ;;; are large, as occurs at present in running the random-int-form tester. ;;; 20040320 CM (defmacro mia (x y) `(si:make-vector t ,x t ,y nil 0 nil nil)) ;(defmacro mia (x y) `(make-array ,x :adjustable t :fill-pointer ,y)) (defmacro eql-not-nil (x y) `(and ,x (eql ,x ,y))) (defstruct (info (:copier old-copy-info)) (type t) ;;; Type of the form. (sp-change nil) ;;; Whether execution of the form may change ;;; the value of a special variable *VS*. (volatile nil) ;;; whether there is a possible setjmp (changed-array (mia 10 0)) ;;; List of var-objects changed by the form. (referred-array (mia 10 0)) ;;; List of var-objects referred in the form. ) (defun copy-array (array) (declare ((vector t) array)) (let ((new-array (mia (the fixnum (array-total-size array)) (length array)))) (declare ((vector t) new-array)) (do ((i 0 (1+ i))) ((>= i (length array)) new-array) (declare (fixnum i)) (setf (aref new-array i) (aref array i))))) (defun copy-info (info) (let ((new-info (old-copy-info info))) (setf (info-referred-array new-info) (copy-array (info-referred-array info))) (setf (info-changed-array new-info) (copy-array (info-changed-array info))) new-info)) (defun bsearchleq (x a i j le) (declare (object x le) ((vector t) a) (fixnum i j)) (when (eql i j) (return-from bsearchleq (if (or le (and (< i (length a)) (eq x (aref a i)))) i (length a)))) (let* ((k (the fixnum (+ i (the fixnum (ash (the fixnum (- j i) ) -1))))) (y (aref a k))) (declare (fixnum k) (object y)) (cond ((si::objlt x y) (bsearchleq x a i k le)) ((eq x y) k) (t (bsearchleq x a (1+ k) j le))))) (defun push-array (x ar s lin) (declare (object x lin) ((vector t) ar) (fixnum s) (ignore lin)) ; (j (if lin ; (do ((k s (1+ k))) ((or (eql k (length ar)) (si::objlt x (aref ar k)) (eq x (aref ar k))) k) ; (declare (fixnum k))) ; (bsearchleq x ar s (length ar))))) (let ((j (bsearchleq x ar s (length ar) t))) (declare (fixnum j)) (when (and (< j (length ar)) (eq (aref ar j) x)) (return-from push-array -1)) (let ((ar (if (eql (length ar) (the fixnum (array-total-size ar))) (adjust-array ar (the fixnum (* 2 (length ar)))) ar))) (declare ((vector t) ar)) (do ((i (length ar) (1- i))) ((<= i j)) (declare (fixnum i)) (setf (aref ar i) (aref ar (the fixnum (1- i))))) (setf (aref ar j) x) (setf (fill-pointer ar) (the fixnum (1+ (length ar)))) j))) (defmacro do-array ((v oar) &rest body) (let ((count (gensym)) (ar (gensym))) `(let* ((,ar ,oar)) (declare ((vector t) ,ar)) (do ((,count 0 (1+ ,count))) ((eql ,count (length ,ar))) (declare (fixnum ,count)) (let ((,v (aref ,ar ,count))) ,@body))))) (defmacro in-array (v ar) `(< (bsearchleq ,v ,ar 0 (length ,ar) nil) (length ,ar))) (defmacro do-referred ((v info) &rest body) `(do-array (,v (info-referred-array ,info)) ,@body)) (defmacro do-changed ((v info) &rest body) `(do-array (,v (info-changed-array ,info)) ,@body)) (defmacro is-referred (var info) `(in-array ,var (info-referred-array ,info))) (defmacro is-changed (var info) `(in-array ,var (info-changed-array ,info))) (defmacro push-referred (var info) `(push-array ,var (info-referred-array ,info) 0 nil)) (defmacro push-changed (var info) `(push-array ,var (info-changed-array ,info) 0 nil)) (defmacro push-referred-with-start (var info s lin) `(push-array ,var (info-referred-array ,info) ,s ,lin)) (defmacro push-changed-with-start (var info s lin) `(push-array ,var (info-changed-array ,info) ,s ,lin)) (defmacro changed-length (info) `(length (info-changed-array ,info))) (defmacro referred-length (info) `(length (info-referred-array ,info))) (defvar *info* (make-info)) (defun mlin (x y) (declare (fixnum x y)) (when (<= y 3) (return-from mlin nil)) (let ((ly (do ((tl y (ash tl -1)) (k -1 (1+ k))) ((eql tl 0) k) (declare (fixnum k tl))))) (declare (fixnum ly)) (let ((lyr (the fixnum (truncate y (the fixnum (1- ly)))))) (declare (fixnum lyr)) (> x (the fixnum (1+ lyr)))))) (defun add-info (to-info from-info) ;; Allow nil from-info without error CM 20031030 (unless from-info (return-from add-info to-info)) (let* ((s 0) (lin)); (mlin (changed-length from-info) (changed-length to-info)))) (declare (fixnum s) (object lin)) (do-changed (v from-info) (let ((res (push-changed-with-start v to-info s lin))) (declare (fixnum res)) (when (>= res 0) (setq s (the fixnum (1+ res))))))) (let* ((s 0) (lin)); (mlin (referred-length from-info) (referred-length to-info)))) (declare (fixnum s) (object lin)) (do-referred (v from-info) (let ((res (push-referred-with-start v to-info s lin))) (declare (fixnum res)) (when (>= res 0) (setq s (the fixnum (1+ res))))))) (when (info-sp-change from-info) (setf (info-sp-change to-info) t)) ;; Return to-info, CM 20031030 to-info) (defun args-info-changed-vars (var forms) (case (var-kind var) ((LEXICAL FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT) (dolist** (form forms) (when (is-changed var (cadr form)) (return-from args-info-changed-vars t)))) (REPLACED nil) (t (dolist** (form forms nil) (when (or (is-changed var (cadr form)) (info-sp-change (cadr form))) (return-from args-info-changed-vars t))))) ) ;; Variable references in arguments can also be via replaced variables ;; (see gcl_cmplet.lsp) It appears that this is not necessary when ;; checking for changed variables, as matches would appear to require ;; that the variable not be replaced. It might be better to provide a ;; new slot in the var structure to point to the variable by which one ;; is replaced -- one would need to consider chains in such a case. ;; Here we match on the C variable reference, which should be complete. ;; 20040306 CM (defun var-rep-loc (x) (and (eq (var-kind x) 'replaced) (consp (var-loc x)) ;; may not be necessary, but vars can also be replaced to 'locations ;; see gcl_cmplet.lsp (cadr (var-loc x)))) (defun is-rep-referred (var info) (let ((rx (var-rep-loc var))) (do-referred (v info) (let ((ry (var-rep-loc v))) (when (or (eql-not-nil (var-loc var) ry) (eql-not-nil (var-loc v) rx) (eql-not-nil rx ry)) (return-from is-rep-referred t)))))) (defun args-info-referred-vars (var forms) (case (var-kind var) ((LEXICAL REPLACED FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT) (dolist** (form forms nil) (when (or (is-referred var (cadr form)) (is-rep-referred var (cadr form))) (return-from args-info-referred-vars t)))) (t (dolist** (form forms nil) (when (or (is-referred var (cadr form)) (is-rep-referred var (cadr form)) (info-sp-change (cadr form))) (return-from args-info-referred-vars t)))) )) ;;; Valid property names for open coded functions are: ;;; INLINE ;;; INLINE-SAFE safe-compile only ;;; INLINE-UNSAFE non-safe-compile only ;;; ;;; Each property is a list of 'inline-info's, where each inline-info is: ;;; ( types { type | boolean } side-effect new-object { string | function } ). ;;; ;;; For each open-codable function, open coding will occur only if there exits ;;; an appropriate property with the argument types equal to 'types' and with ;;; the return-type equal to 'type'. The third element ;;; is T if and only if side effects may occur by the call of the function. ;;; Even if *VALUE-TO-GO* is TRASH, open code for such a function with side ;;; effects must be included in the compiled code. ;;; The forth element is T if and only if the result value is a new Lisp ;;; object, i.e., it must be explicitly protected against GBC. (defvar *inline-functions* nil) (defvar *inline-blocks* 0) ;;; *inline-functions* holds: ;;; (...( function-name . inline-info )...) ;;; ;;; *inline-blocks* holds the number of temporary cvars used to save ;;; intermediate results during evaluation of inlined function calls. ;;; This variable is used to close up blocks introduced to declare static ;;; c variables. (defvar *special-types* '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT integer)) (defun inc-inline-blocks() (cond ((consp *inline-blocks*) (incf (car *inline-blocks*))) (t (incf *inline-blocks*)))) (defun inline-args (forms types &optional fun &aux (locs nil) ii) (do ((forms forms (cdr forms)) (types types (cdr types))) ((endp forms) (nreverse locs)) (declare (object forms types)) (let ((form (car forms)) (type (car types))) (declare (object form type)) (case (car form) (LOCATION (push (coerce-loc (caddr form) type) locs)) (VAR (cond ((args-info-changed-vars (caaddr form) (cdr forms)) (cond ((and (member (var-kind (caaddr form)) *special-types*) (eq type (var-kind (caaddr form)))) (let ((cvar (next-cvar))) (wt-nl "{" (rep-type type) "V" cvar "= V" (var-loc (caaddr form)) ";") (push (list 'cvar cvar 'inline-args) locs) (inc-inline-blocks))) (t (let ((temp (wt-c-push))) (wt-nl temp "= ") (wt-var (caaddr form) (cadr (caddr form))) (wt ";") (push (coerce-loc temp type) locs))))) ((and (member (var-kind (caaddr form)) '(FIXNUM LONG-FLOAT SHORT-FLOAT INTEGER)) (not (eq type (var-kind (caaddr form))))) (let ((temp (cs-push type))) (wt-nl "V" temp " = " (coerce-loc (cons 'var (caddr form)) type) ";") (push (list 'cvar temp) locs))) (t (push (coerce-loc (cons 'VAR (caddr form)) type) locs)))) (CALL-GLOBAL (if (let ((fname (caddr form))) (and (inline-possible fname) (setq ii (get-inline-info fname (cadddr form) (info-type (cadr form)))) (progn (save-avma ii) t))) (let ((loc (get-inline-loc ii (cadddr form)))) (cond ((or (and (flag-p (caddr ii) ans)(not *c-gc*)) ; returns new object (and (member (cadr ii) '(FIXNUM LONG-FLOAT SHORT-FLOAT)) (not (eq type (cadr ii))))) (let ((temp (cs-push type))) (wt-nl "V" temp " = " (coerce-loc loc type) ";") (push (list 'cvar temp) locs)) ) ((or (need-to-protect (cdr forms) (cdr types)) ;;if either new form or side effect, ;;we don't want double evaluation (and (flag-p (caddr ii) allocates-new-storage) (or (null fun) ;; Any fun such as list,list* which ;; does not cause side effects or ;; do double eval (ie not "@..") ;; could go here. (not (si::memq fun '(list-inline list*-inline))))) (flag-p (caddr ii) is) (and (flag-p (caddr ii) set) ; side-effectp (not (null (cdr forms))))) (let (cvar) (cond ((eq type t) (setq cvar (cs-push)) (wt-nl "V" cvar "= ") (wt-loc loc)) (t (setq cvar (next-cvar)) (wt-nl "{" (rep-type type) "V" cvar "= ") (case type (fixnum (wt-fixnum-loc loc)) (integer (wt-integer-loc loc 'inline-args)) (character (wt-character-loc loc)) (long-float (wt-long-float-loc loc)) (short-float (wt-short-float-loc loc)) (otherwise (wt-loc loc))) (inc-inline-blocks))) (wt ";") (push (list 'cvar cvar 'inline-args) locs) )) (t (push (coerce-loc loc type) locs)))) (let ((temp (if *c-gc* (list 'cvar (cs-push)) (list 'vs (vs-push))))) (let ((*value-to-go* temp)) (c2expr* form)) (push (coerce-loc temp type) locs)))) (structure-ref (push (coerce-loc-structure-ref (cdr form) type) locs)) (SETQ (let ((vref (caddr form)) (form1 (cadddr form))) (let ((*value-to-go* (cons 'var vref))) (c2expr* form1)) (cond ((eq (car form1) 'LOCATION) (push (coerce-loc (caddr form1) type) locs)) (t (setq forms (list* form (list 'VAR (cadr form) vref) (cdr forms))) ;; want (setq types (list* type type (cdr types))) ;; but type is first of types (setq types (list* type types)))))) (t (let ((temp (cond (*c-gc* (cond ((eq type t) (list 'cvar (cs-push))) (t (push (cons type (next-cvar)) *c-vars*) (list 'var (make-var :type type :kind (if (member type *special-types*) type 'object) :loc (cdar *c-vars*)) nil )))) (t (list 'vs (vs-push)))))) (let ((*value-to-go* temp)) (c2expr* form) (push (coerce-loc temp type) locs)))))))) (defun coerce-loc (loc type) (case type (fixnum (list 'FIXNUM-LOC loc)) (integer (list 'integer-loc loc )) (character (list 'CHARACTER-LOC loc)) (long-float (list 'LONG-FLOAT-LOC loc)) (short-float (list 'SHORT-FLOAT-LOC loc)) (t loc))) (defun get-inline-loc (ii args &aux (fun (car (cdddr ii))) locs) ;;; Those functions that use GET-INLINE-LOC must rebind the variable *VS*. (setq locs (inline-args args (car ii) fun)) (when (and (stringp fun) (char= (char (the string fun) 0) #\@)) (let ((i 1) (saves nil)) (declare (fixnum i)) (do ((char (char (the string fun) i) (char (the string fun) i))) ((char= char #\;) (incf i)) (declare (character char)) (push (the fixnum (- (char-code char) #.(char-code #\0))) saves) (incf i)) (do ((l locs (cdr l)) (n 0 (1+ n)) (locs1 nil)) ((endp l) (setq locs (nreverse locs1))) (declare (fixnum n) (object l)) (if (member n saves) (let* ((loc1 (car l)) (loc loc1) (coersion nil)) (declare (object loc loc1)) (when (and (consp loc1) (member (car loc1) '(FIXNUM-LOC integer-loc CHARACTER-LOC LONG-FLOAT-LOC SHORT-FLOAT-LOC))) (setq coersion (car loc1)) (setq loc (cadr loc1)) ; remove coersion ) (cond ((and (consp loc) (or (member (car loc) '(INLINE INLINE-COND)) (and (member (car loc) '( INLINE-FIXNUM inline-integer INLINE-CHARACTER INLINE-LONG-FLOAT INLINE-SHORT-FLOAT)) (or (flag-p (cadr loc) allocates-new-storage) (flag-p (cadr loc) side-effect-p)) ))) (wt-nl "{") (inc-inline-blocks) (let ((cvar (next-cvar))) (push (list 'CVAR cvar) locs1) (case coersion ((nil) (wt "object V" cvar "= ") (wt-loc loc1)) (FIXNUM-LOC (wt "int V" cvar "= ") (wt-fixnum-loc loc)) (integer-loc (wt "MP_INT * V" cvar "= ") (wt-integer-loc loc 'get-inline-locs)) (CHARACTER-LOC (wt "unsigned char V" cvar "= ") (wt-character-loc loc)) (LONG-FLOAT-LOC (wt "double V" cvar "= ") (wt-long-float-loc loc)) (SHORT-FLOAT-LOC (wt "float V" cvar "= ") (wt-short-float-loc loc)) (t (baboon)))) (wt ";") ) (t (push loc1 locs1)))) (push (car l) locs1))))) (list (inline-type (cadr ii)) (caddr ii) fun locs) ) (defvar *inline-types* '((boolean . INLINE-COND) (fixnum . INLINE-FIXNUM) (character . INLINE-CHARACTER) (long-float . INLINE-LONG-FLOAT) (short-float . INLINE-SHORT-FLOAT) (integer . INLINE-INTEGER) (t . INLINE))) (defun inline-type (type) (or (cdr (assoc type *inline-types*)) 'inline)) (defun get-inline-info (fname args return-type &aux x ii) (and (fast-link-proclaimed-type-p fname args) (add-fast-link fname return-type args)) (setq args (mapcar #'(lambda (form) (info-type (cadr form))) args)) (when (if *safe-compile* (setq x (get fname 'inline-safe)) (setq x (get fname 'inline-unsafe))) (dolist** (y x nil) (when (setq ii (inline-type-matches y args return-type)) (return-from get-inline-info ii)))) (when (setq x (get fname 'inline-always)) (dolist** (y x) (when (setq ii (inline-type-matches y args return-type)) (return-from get-inline-info ii)))) (dolist* (x *inline-functions*) (when (and (eq (car x) fname) (setq ii (inline-type-matches (cdr x) args return-type))) (return-from get-inline-info ii))) nil) (defun inline-type-matches (inline-info arg-types return-type &aux (rts nil)) (if (not (typep (third inline-info) 'fixnum)) (fix-opt inline-info)) (if (member 'integer (car inline-info)) (return-from inline-type-matches nil)) (if (and (let ((types (car inline-info))) (declare (object types)) (dolist** (arg-type arg-types (or (equal types '(*)) (endp types))) (when (endp types) (return nil)) (cond ((equal types '(*)) (setq types '(t *)))) (cond ((eq (car types) 'fixnum-float) (cond ((type>= 'fixnum arg-type) (push 'fixnum rts)) ((type>= 'long-float arg-type) (push 'long-float rts)) ((type>= 'short-float arg-type) (push 'short-float rts)) (t (return nil)))) ((type>= (car types) arg-type) (push (car types) rts)) (t (return nil))) (pop types))) (type>= (cadr inline-info) return-type)) (cons (nreverse rts) (cdr inline-info)) nil) ) (defun need-to-protect (forms types &aux ii) (do ((forms forms (cdr forms)) (types types (cdr types))) ((endp forms) nil) (declare (object forms types)) (let ((form (car forms))) (declare (object form)) (case (car form) (LOCATION) (VAR (when (or (args-info-changed-vars (caaddr form) (cdr forms)) (and (member (var-kind (caaddr form)) '(FIXNUM LONG-FLOAT SHORT-FLOAT)) (not (eq (car types) (var-kind (caaddr form)))))) (return t))) (CALL-GLOBAL (let ((fname (caddr form))) (declare (object fname)) (when (or (not (inline-possible fname)) (null (setq ii (get-inline-info fname (cadddr form) (info-type (cadr form))))) (flag-p (caddr ii) allocates-new-storage) (flag-p (caddr ii) set) (flag-p (caddr ii) is) (and (member (cadr ii) '(fixnum long-float short-float)) (not (eq (car types) (cadr ii)))) (need-to-protect (cadddr form) (car ii))) (return t)))) (structure-ref (when (need-to-protect (list (caddr form)) '(t)) (return t))) (t (return t))))) ) (defun wt-c-push () (cond (*c-gc* (inc-inline-blocks) (let ((tem (next-cvar))) (wt "{" *volatile* "object V" tem ";") (list 'cvar tem))) (t (list 'VS (vs-push))))) (defun close-inline-blocks ( &aux (bl *inline-blocks*)) (when (consp bl) (if (eql (cdr bl) 'restore-avma) (wt "restore_avma;")) (setq bl (car bl))) (dotimes** (i bl) (wt "}"))) (si:putprop 'inline 'wt-inline 'wt-loc) (si:putprop 'inline-cond 'wt-inline-cond 'wt-loc) (si:putprop 'inline-fixnum 'wt-inline-fixnum 'wt-loc) (si:putprop 'inline-integer 'wt-inline-integer 'wt-loc) (si:putprop 'inline-character 'wt-inline-character 'wt-loc) (si:putprop 'inline-long-float 'wt-inline-long-float 'wt-loc) (si:putprop 'inline-short-float 'wt-inline-short-float 'wt-loc) (defun wt-inline-loc (fun locs &aux (i 0) (max -1)) (declare (fixnum i max)) (cond ((stringp fun) (when (char= (char (the string fun) 0) #\@) (setq i 1) (do () ((char= (char (the string fun) i) #\;) (incf i)) (incf i))) (do ((size (length (the string fun)))) ((>= i size)) (declare (fixnum size )) (let ((char (char (the string fun) i))) (declare (character char)) (cond ((char= char #\#) (let ((ch (char (the string fun) (the fixnum (1+ i)))) (n 0)) (cond ((or (eql ch #\*) (eql ch #\?));#? ensures 'first' vararg is initialized (let* ((f (char= (char fun (1- i)) #\()) (e (char= (char fun (+ 2 i)) #\))) (locs (nthcdr (1+ max) locs)) (locs (or locs (when (eql ch #\?) `((fixnum-value nil 0)))))) (dolist (v locs (unless (or f e) (wt ","))) (unless f (wt ",")) (setq f nil) (wt-loc v)))) ((digit-char-p ch 10) (setq n (- (char-code ch) (char-code #\0))) (when (and (> (length fun) (+ i 2)) (progn (setq ch (char (the string fun) (+ i 2))) (digit-char-p ch))) (setq n (+ (* n 10) (- (char-code ch) (char-code #\0)))) (incf i)) (cond ((>= n max) (setq max n))) (wt-loc (nth n locs))))) (incf i 2)) (t (princ char *compiler-output1*) (incf i))))) ) (t (apply fun locs)))) (defun wt-inline (side-effectp fun locs) (declare (ignore side-effectp)) (wt-inline-loc fun locs)) (defun wt-inline-cond (side-effectp fun locs) (declare (ignore side-effectp)) (wt "(") (wt-inline-loc fun locs) (wt "?Ct:Cnil)")) (defun wt-inline-fixnum (side-effectp fun locs) (declare (ignore side-effectp)) (when (zerop *space*) (wt "CMP")) (wt "make_fixnum((long)(") (wt-inline-loc fun locs) (wt "))")) (defun wt-inline-integer (side-effectp fun locs) (declare (ignore side-effectp)) (wt "make_integer(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-character (side-effectp fun locs) (declare (ignore side-effectp)) (wt "code_char(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-long-float (side-effectp fun locs) (declare (ignore side-effectp)) (wt "make_longfloat(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-short-float (side-effectp fun locs) (declare (ignore side-effectp)) (wt "make_shortfloat(") (wt-inline-loc fun locs) (wt ")")) (defun args-cause-side-effect (forms &aux ii) (dolist** (form forms nil) (case (car form) ((LOCATION VAR structure-ref)) (CALL-GLOBAL (let ((fname (caddr form))) (declare (object fname)) (unless (and (inline-possible fname) (setq ii (get-inline-info fname (cadddr form) (info-type (cadr form)))) (progn (fix-opt ii) (not (flag-p (caddr ii) side-effect-p))) ) (return t)))) (otherwise (return t))))) ;;; Borrowed from CMPOPT.LSP (defun list-inline (&rest x &aux tem (n (length x))) (cond ((setq tem (and (consp *value-to-go*) (eq (car *value-to-go*) 'var) (eq (var-type (second *value-to-go*)) :dynamic-extent))) (wt "(ALLOCA_CONS(" n "),ON_STACK_LIST(" n)) (t (wt "list(" (length x)))) (dolist (loc x) (wt #\, loc)) (wt #\)) (if tem (wt #\))) ) (defun list*-inline (&rest x) (case (length x) (1 (wt (car x))) (2 (wt "make_cons(" (car x) "," (cadr x) ")")) (otherwise (wt "listA(" (length x)) (dolist (loc x) (wt #\, loc)) (wt #\))))) ;;; Borrowed from LFUN_LIST.LSP (defun defsysfun (fname cname-string arg-types return-type never-change-special-var-p predicate) ;;; The value NIL for each parameter except for fname means "not known". (when cname-string (si:putprop fname cname-string 'Lfun)) (when arg-types (si:putprop fname (mapcar #'(lambda (x) (if (eq x '*) '* (type-filter x))) arg-types) 'arg-types)) (when return-type (let ((rt (function-return-type (if (atom return-type) (list return-type) return-type)))) (or (consp rt) (setq rt (list rt))) (si:putprop fname (if (null (cdr rt)) (car rt) (cons 'values rt)) 'return-type))) (when never-change-special-var-p (si:putprop fname t 'no-sp-change)) (when predicate (si:putprop fname t 'predicate)) ) gcl/cmpnew/gcl_cmplabel.lsp000077500000000000000000000231171242227143400162500ustar00rootroot00000000000000;;; CMPLABEL Exit manager. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (defvar *last-label* 0) (defvar *exit*) (defvar *unwind-exit*) (defvar *record-call-info* nil) ;;; *last-label* holds the label# of the last used label. ;;; *exit* holds an 'exit', which is ;;; ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM, ;;; RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-SHORT-FLOAT, or ;;; RETURN-OBJECT). ;;; *unwind-exit* holds a list consisting of: ;;; ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME, ;;; JUMP, BDS-BIND (each pushed for a single special binding), and ;;; cvar (which holds the bind stack pointer used to unbind). (defmacro next-label () `(cons (incf *last-label*) nil)) (defmacro next-label* () `(cons (incf *last-label*) t)) (defmacro wt-label (label) `(when (cdr ,label) (wt-nl "goto T" (car ,label) ";")(wt-nl1 "T" (car ,label) ":;"))) (defmacro wt-go (label) `(progn (rplacd ,label t) (wt "goto T" (car ,label) ";"))) (defvar *restore-avma* nil) (defun unwind-bds (bds-cvar bds-bind) (when (consp *inline-blocks*) (wt-nl "restore_avma; ")) (when bds-cvar (wt-nl "bds_unwind(V" bds-cvar ");")) (dotimes* (n bds-bind) (wt-nl "bds_unwind1;"))) (defun unwind-exit (loc &optional (jump-p nil) fname &aux (*vs* *vs*) (bds-cvar nil) (bds-bind 0) type.wt) (declare (fixnum bds-bind)) (and *record-call-info* (record-call-info loc fname)) (when (and (eq loc 'fun-val) (not (eq *value-to-go* 'return)) (not (eq *value-to-go* 'top))) (wt-nl) (reset-top)) (cond ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-true)) (set-jump-true loc (cadr *value-to-go*)) (when (eq loc t) (return-from unwind-exit))) ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-false)) (set-jump-false loc (cadr *value-to-go*)) (when (null loc) (return-from unwind-exit)))) (dolist* (ue *unwind-exit* (baboon)) (cond ((consp ue) (cond ((eq ue *exit*) (cond ((and (consp *value-to-go*) (or (eq (car *value-to-go*) 'jump-true) (eq (car *value-to-go*) 'jump-false))) (unwind-bds bds-cvar bds-bind)) (t (if (or bds-cvar (plusp bds-bind)) ;;; Save the value if LOC may possibly refer ;;; to special binding. (if (and (consp loc) (or (and (eq (car loc) 'var) (member (var-kind (cadr loc)) '(SPECIAL GLOBAL))) (member (car loc) '(SIMPLE-CALL INLINE INLINE-COND INLINE-FIXNUM INLINE-CHARACTER INLINE-INTEGER INLINE-LONG-FLOAT INLINE-SHORT-FLOAT)))) (cond ((and (consp *value-to-go*) (eq (car *value-to-go*) 'vs)) (set-loc loc) (unwind-bds bds-cvar bds-bind)) (t (let ((temp (list 'cvar (cs-push)))) (let ((*value-to-go* temp)) (set-loc loc)) (unwind-bds bds-cvar bds-bind) (set-loc temp)))) (progn (unwind-bds bds-cvar bds-bind) (set-loc loc))) (set-loc loc)))) (when jump-p (when (consp *inline-blocks*) (wt-nl "restore_avma; ")) (wt-nl) (wt-go *exit*)) (return)) ;; Add (sup .var) handling in unwind-exit -- in ;; c2multiple-value-prog1 and c2-multiple-value-call, apparently ;; alone, c2expr-top is used to evaluate arguments, presumably to ;; preserve certain states of the value stack for the purposes of ;; retrieving the final results. c2exprt-top rebinds sup, and ;; vs_top in turn to the new sup, causing non-local exits to lose ;; the true top of the stack vital for subsequent function ;; evaluations. We unwind this stack supremum variable change here ;; when necessary. CM 20040301 ((eq (car ue) 'sup) (when (and ;; If we've pushed the sup, we've always reset vs_top, as we're ;; using c2expr-top{*}. Regardless then of whether we are ;; explicitly unwinding a fun-val, we must reset the top, unless ;; unless returning, when we rely on the returning code to leave ;; the stack in the correct state, regardless of loc being a fun-val ;; or otherwise. We might need to reset when returning and loc is not ;; fun-val, but this appears doubtful. 20040306 CM ;; (eq loc 'fun-val) (not (eq *value-to-go* 'return)) (not (eq *value-to-go* 'top))) (wt-nl "sup=V" (cdr ue) ";") (wt-nl) (reset-top))) (t (setq jump-p t)))) ((numberp ue) (setq bds-cvar ue bds-bind 0)) ((eq ue 'bds-bind) (incf bds-bind)) ((eq ue 'return) (when (eq *exit* 'return) ;;; *VALUE-TO-GO* must be either *RETURN* or *TRASH*. (set-loc loc) (unwind-bds bds-cvar bds-bind) (wt-nl "return;") (return)) ;;; Never reached ) ((eq ue 'frame) (when (and (consp loc) (member (car loc) '(SIMPLE-CALL INLINE INLINE-COND INLINE-FIXNUM inline-integer INLINE-CHARACTER INLINE-LONG-FLOAT INLINE-SHORT-FLOAT))) (cond ((and (consp *value-to-go*) (eq (car *value-to-go*) 'vs)) (set-loc loc) (setq loc *value-to-go*)) (t (let ((*value-to-go* (if *c-gc* (list 'cvar (cs-push)) (list 'vs (vs-push))))) (set-loc loc) (setq loc *value-to-go*))))) (wt-nl "frs_pop();")) ((eq ue 'tail-recursion-mark)) ((eq ue 'jump) (setq jump-p t)) ((setq type.wt (assoc ue '((return-fixnum fixnum . wt-fixnum-loc) (return-character character . wt-character-loc) (return-short-float short-float . wt-short-float-loc) (return-long-float long-float . wt-long-float-loc) (return-object t . wt-loc)))) (let ((cvar (next-cvar))) (or (eq *exit* (car type.wt)) (wfs-error)) (setq type.wt (cdr type.wt)) (wt-nl "{" (rep-type (car type.wt)) "V" cvar " = ") (funcall (cdr type.wt) loc) (wt ";") (unwind-bds bds-cvar bds-bind) (wt-nl "VMR" *reservation-cmacro* "(" (if (equal (rep-type (car type.wt)) "long ") "(object)" "") "V" cvar")}") (return))) (t (baboon)) ;;; Never reached )) ) (defun unwind-no-exit (exit &aux (bds-cvar nil) (bds-bind 0)) (declare (fixnum bds-bind)) (dolist* (ue *unwind-exit* (baboon)) (cond ((consp ue) (when (eq ue exit) (unwind-bds bds-cvar bds-bind) (return)) ;; Add (sup .var) handling in unwind-exit -- in ;; c2multiple-value-prog1 and c2-multiple-value-call, apparently ;; alone, c2expr-top is used to evaluate arguments, presumably to ;; preserve certain states of the value stack for the purposes of ;; retrieving the final results. c2exprt-top rebinds sup, and ;; vs_top in turn to the new sup, causing non-local exits to lose ;; the true top of the stack vital for subsequent function ;; evaluations. We unwind this stack supremum variable change here ;; when necessary. CM 20040301 (when (eq (car ue) 'sup) (wt-nl "sup=V" (cdr ue) ";") (wt-nl) (reset-top))) ((numberp ue) (setq bds-cvar ue bds-bind 0)) ((eq ue 'bds-bind) (incf bds-bind)) ((member ue '(return return-object return-fixnum return-character return-long-float return-short-float)) (cond ((eq exit ue) (unwind-bds bds-cvar bds-bind) (return)) (t (baboon))) ;;; Never reached ) ((eq ue 'frame) (wt-nl "frs_pop();")) ((eq ue 'tail-recursion-mark) (cond ((eq exit 'tail-recursion-mark) (unwind-bds bds-cvar bds-bind) (return)) (t (baboon))) ;;; Never reached ) ((eq ue 'jump)) (t (baboon)) ;;; Never reached )) ) ;;; Tail-recursion optimization for a function F is possible only if ;;; 1. the value of *DO-TAIL-RECURSION* is non-nil (this is default), ;;; 2. F receives only required parameters, and ;;; 3. no required parameter of F is enclosed in a closure. ;;; ;;; A recursive call (F e1 ... en) may be replaced by a loop only if ;;; 1. F is not declared as NOTINLINE, ;;; 2. n is equal to the number of required parameters of F, ;;; 3. the form is a normal function call (i.e. the arguments are ;;; pushed on the stack, ;;; 4. (F e1 ... en) is not surrounded by a form that causes dynamic ;;; binding (such as LET, LET*, PROGV), ;;; 5. (F e1 ... en) is not surrounded by a form that that pushes a frame ;;; onto the frame-stack (such as BLOCK and TAGBODY whose tags are ;;; enclosed in a closure, and CATCH), (defun tail-recursion-possible () (dolist* (ue *unwind-exit* (baboon)) (cond ((eq ue 'tail-recursion-mark) (return t)) ((or (numberp ue) (eq ue 'bds-bind) (eq ue 'frame)) (return nil)) ((or (consp ue) (eq ue 'jump))) (t (baboon))))) gcl/cmpnew/gcl_cmplam.lsp000077500000000000000000001026111242227143400157370ustar00rootroot00000000000000;;; CMPLAM Lambda expression. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) ;;; During Pass1, a lambda-list ;;; ;;; ( { var }* ;;; [ &optional { var | ( var [ initform [ svar ] ] ) }* ] ;;; [ &rest var ] ;;; [ &key { var | ( { var | ( kwd var ) } [initform [ svar ]])}* ;;; [&allow-other-keys]] ;;; [ &aux {var | (var [initform])}*] ;;; ) ;;; ;;; is transformed into ;;; ;;; ( ( { var }* ) ; required ;;; ( { (var initform svar) }* ) ; optional ;;; { var | nil } ; rest ;;; key-flag ;;; ( { ( kwd-vv-index var initform svar) }* ) ; key ;;; allow-other-keys-flag ;;; ) ;;; ;;; where ;;; svar: nil ; means svar is not supplied ;;; | var ;;; ;;; &aux parameters will be embedded into LET*. ;;; ;;; c1lambda-expr receives ;;; ( lambda-list { doc | decl }* . body ) ;;; and returns ;;; ( lambda info-object lambda-list' doc body' ) ;;; ;;; Doc is NIL if no doc string is supplied. ;;; Body' is body possibly surrounded by a LET* (if &aux parameters are ;;; supplied) and an implicit block. (defmacro ck-spec (condition) `(unless ,condition (cmperr "The parameter specification ~s is illegal." spec))) (defmacro ck-vl (condition) `(unless ,condition (cmperr "The lambda list ~s is illegal." vl))) ;;;the following code implements downward closures. ;;;These are like closures, except they are guaranteed not ;;;to survive past the exit of the function in which they ;;;are born. (defmacro downward-function (x) `(function ,x)) (setf (get 'downward-function 'c1special) 'c1downward-function) (defun c1downward-function (x) (let* ((tem (c1expr (list 'function (car x)))) (info (cadr tem))) ;; for the moment we only allow downward closures with no args (cond ((and (consp x) (consp (car x)) (eq (caar x) 'lambda) (null (second (car x)))) (do-referred (var info) (cond ((and (eq (var-kind var) 'lexical) (var-ref-ccb var) t) (setf (var-kind var) 'down))) ) (setf (car tem) 'downward-function) tem) (t tem)))) (si::putprop 'downward-function 'c2downward-function 'c2) (si:putprop 'make-dclosure 'wt-make-dclosure 'wt-loc) (defun wt-make-dclosure (cfun clink)clink ;;Dbase=base0 (wt-nl "(DownClose"cfun".t=t_dclosure,DownClose" cfun ".dc_self=LC" cfun"," "DownClose" cfun ".dc_env=base0,(object)&DownClose" cfun ")")) (defun wfs-error () (error "This error is not supposed to occur: Contact Schelter ~ ~%wfs@math.utexas.edu")) (defun wt-downward-closure-macro (cfun) (cond (*downward-closures* (wt-h "#define DCnames" cfun " ") (setq *downward-closures* (delete 'dcnames *downward-closures*)) (cond (*downward-closures* (wt-h1 "struct dclosure ") (do ((v *downward-closures* (cdr v))) ((null v)) (wt-h1 "DownClose") (wt-h1 (car v)) (if (cdr v) (wt-h1 ","))) (wt-h1 ";")))))) (defun c2downward-function (funob) (let ((fun (make-fun :name 'closure :cfun (next-cfun)))) (push (list 'dclosure (if (null *clink*) nil (cons 'fun-env 0)) *ccb-vs* fun funob) *local-funs*) (push fun *closures*) (push (fun-cfun fun) *downward-closures*) (unwind-exit (list 'make-dclosure (fun-cfun fun) *clink*)))) (defun c1lambda-expr (lambda-expr &optional (block-name nil block-it) &aux (requireds nil) (optionals nil) (rest nil) (keywords nil) (key-flag nil) lambda-list (allow-other-keys nil) (aux-vars nil) (aux-inits nil) doc vl spec body ss is ts other-decls vnames (*vars* *vars*) (info (make-info)) (aux-info nil) (setjmps *setjmps*) ) (cmpck (endp lambda-expr) "The lambda expression ~s is illegal." (cons 'lambda lambda-expr)) (multiple-value-setq (body ss ts is other-decls doc) (c1body (cdr lambda-expr) t)) (when block-it (setq body (list (cons 'block (cons block-name body))))) (c1add-globals ss) (setq vl (car lambda-expr)) (block parse (tagbody Lreq (when (null vl) (return-from parse)) (ck-vl (consp vl)) (case (setq spec (pop vl)) (&optional (go Lopt)) (&rest (go Lrest)) (&key (go Lkey)) (&aux (go Laux))) (let ((v (c1make-var spec ss is ts))) (push spec vnames) (push v *vars*) (push v requireds)) (go Lreq) Lopt (when (null vl) (return-from parse)) (ck-vl (consp vl)) (case (setq spec (pop vl)) (&rest (go Lrest)) (&key (go Lkey)) (&aux (go Laux))) (cond ((not (consp spec)) (let ((v (c1make-var spec ss is ts))) (push spec vnames) (push (list v (default-init (var-type v)) nil) optionals) (push v *vars*))) ((not (consp (cdr spec))) (ck-spec (null (cdr spec))) (let ((v (c1make-var (car spec) ss is ts))) (push (car spec) vnames) (push (list v (default-init (var-type v)) nil) optionals) (push v *vars*))) ((not (consp (cddr spec))) (ck-spec (null (cddr spec))) (let ((init (c1expr* (cadr spec) info)) (v (c1make-var (car spec) ss is ts))) (push (car spec) vnames) (push (list v (and-form-type (var-type v) init (cadr spec)) nil) optionals) (push v *vars*))) (t (ck-spec (null (cdddr spec))) (let ((init (c1expr* (cadr spec) info)) (v (c1make-var (car spec) ss is ts)) (sv (c1make-var (caddr spec) ss is ts)) ) (push (car spec) vnames) (push (caddr spec) vnames) (push (list v (and-form-type (var-type v) init (cadr spec)) sv) optionals) (push v *vars*) (push sv *vars*)))) (go Lopt) Lrest (ck-vl (consp vl)) (push (car vl) vnames) (setq rest (c1make-var (pop vl) ss is ts)) (push rest *vars*) (when (null vl) (return-from parse)) (ck-vl (consp vl)) (case (setq spec (pop vl)) (&key (go Lkey)) (&aux (go Laux))) (cmperr "Either &key or &aux is missing before ~s." spec) Lkey (setq key-flag t) (when (null vl) (return-from parse)) (ck-vl (consp vl)) (case (setq spec (pop vl)) (&aux (go Laux)) (&allow-other-keys (setq allow-other-keys t) (when (null vl) (return-from parse)) (ck-vl (consp vl)) (case (setq spec (pop vl)) (&aux (go Laux))) (cmperr "&aux is missing before ~s." spec))) (when (not (consp spec)) (setq spec (list spec))) (cond ((consp (car spec)) (ck-spec (and (keywordp (caar spec)) (consp (cdar spec)) (null (cddar spec)))) (setq spec (cons (caar spec) (cons (cadar spec) (cdr spec))))) (t (ck-spec (symbolp (car spec))) (setq spec (cons (intern (string (car spec)) 'keyword) (cons (car spec) (cdr spec)))))) (cond ((not (consp (cddr spec))) (ck-spec (null (cddr spec))) (let ((v (c1make-var (cadr spec) ss is ts))) (push (cadr spec) vnames) (push (list (car spec) v (default-init (var-type v)) (make-var :kind 'DUMMY)) keywords) (push v *vars*))) ((not (consp (cdddr spec))) (ck-spec (null (cdddr spec))) (let ((init (c1expr* (caddr spec) info)) (v (c1make-var (cadr spec) ss is ts))) (push (cadr spec) vnames) (push (list (car spec) v (and-form-type (var-type v) init (caddr spec)) (make-var :kind 'DUMMY)) keywords) (push v *vars*))) (t (ck-spec (null (cddddr spec))) (let ((init (c1expr* (caddr spec) info)) (v (c1make-var (cadr spec) ss is ts)) (sv (c1make-var (cadddr spec) ss is ts))) (push (cadr spec) vnames) (push (cadddr spec) vnames) (push (list (car spec) v (and-form-type (var-type v) init (caddr spec)) sv) keywords) (push v *vars*) (push sv *vars*)))) (go Lkey) Laux (setq aux-info (make-info)) Laux1 (when (null vl) (add-info info aux-info) (return-from parse)) (ck-vl (consp vl)) (setq spec (pop vl)) (cond ((consp spec) (cond ((not (consp (cdr spec))) (ck-spec (null (cdr spec))) (let ((v (c1make-var (car spec) ss is ts))) (push (car spec) vnames) (push (default-init (var-type v)) aux-inits) (push v aux-vars) (push v *vars*))) (t (ck-spec (null (cddr spec))) (let ((init (c1expr* (cadr spec) aux-info)) (v (c1make-var (car spec) ss is ts))) (push (car spec) vnames) (push (and-form-type (var-type v) init (cadr spec)) aux-inits) (push v aux-vars) (push v *vars*))))) (t (let ((v (c1make-var spec ss is ts))) (push spec vnames) (push (default-init (var-type v)) aux-inits) (push v aux-vars) (push v *vars*)))) (go Laux1) ) ) (setq requireds (nreverse requireds) optionals (nreverse optionals) keywords (nreverse keywords) aux-vars (nreverse aux-vars) aux-inits (nreverse aux-inits)) (check-vdecl vnames ts is) (setq body (c1decl-body other-decls body)) (add-info info (cadr body)) (dolist** (var requireds) (check-vref var)) (dolist** (opt optionals) (check-vref (car opt)) (when (caddr opt) (check-vref (caddr opt)))) (when rest (check-vref rest)) (dolist** (kwd keywords) (check-vref (cadr kwd)) (when (cadddr kwd) (check-vref (cadddr kwd)))) (dolist** (var aux-vars) (check-vref var)) (when aux-vars (add-info aux-info (cadr body)) (setq body (list 'let* aux-info aux-vars aux-inits body)) (or (eql setjmps *setjmps*) (setf (info-volatile aux-info) t))) (setq body (fix-down-args requireds body block-name)) (setq lambda-list (list requireds optionals rest key-flag keywords allow-other-keys)) (and *record-call-info* (record-arg-info lambda-list)) (list 'lambda info lambda-list doc body) ) ;;this makes a let for REQUIREDS which are used in a downward ;;lexical closure (defun fix-down-args(requireds body name &aux auxv auxinit info v) (let ((types (get name 'proclaimed-arg-types)) (fixed (get name 'fixed-args))) (do ((vv requireds (cdr vv)) (typ types (cdr typ))) ((null vv)) (setq v (car vv)) (cond ((not (or fixed (eq (car typ) t))) (return-from fix-down-args body)) ((and (eq (var-kind v) 'DOWN) (eq (var-loc v) 'object)) ;;a downward variable could not have been special ;;and must be type t. We create a new variable ;;for the arg, and bind the old one to it. (let* ((new (c1make-var (var-name v) nil nil nil)) (init (list 'var (or info (setq info (make-info))) (list new nil)))) (push v auxv) (setf (car vv) new) (push-referred new info) (push init auxinit))))) (if auxv (list 'let* info auxv auxinit body) body))) (defun the-parameter (name) (cmpck (not (symbolp name)) "The parameter ~s is not a symbol." name) (cmpck (constantp name) "The constant ~s is being bound." name) name ) (defvar *rest-on-stack* nil) ;; non nil means put rest arg on C stack. (defun c2lambda-expr (lambda-list body &optional (fname nil s-fname)) (let ((*tail-recursion-info* ;;; Tail recursion possible if (if (and *do-tail-recursion* s-fname ;;; named function, (dolist* (var (car lambda-list) t) (when (var-ref-ccb var) (return nil))) ;;; no required is closed in a closure, (null (cadr lambda-list)) ;;; no optionals, (null (caddr lambda-list)) ;;; no rest parameter, and (not (cadddr lambda-list))) ;;; no keywords. (cons fname (car lambda-list)) nil))) (let ((*rest-on-stack* (cond ((and (caddr lambda-list) (eq (var-type (caddr lambda-list)) :dynamic-extent)) t) (t *rest-on-stack*)))) (if (cadddr lambda-list) ;;; key-flag (c2lambda-expr-with-key lambda-list body) (c2lambda-expr-without-key lambda-list body))) )) (defun c2lambda-expr-without-key (lambda-list body &aux (requireds (car lambda-list)) (optionals (cadr lambda-list)) (rest (caddr lambda-list)) (labels nil) (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*) (block-p nil) ) (declare (object requireds optionals rest)) ;;; Allocate immediate-type parameters. (flet ((do-decl (var) (let ((kind (c2var-kind var))) (declare (object kind)) (when kind (let ((cvar (next-cvar))) (setf (var-kind var) kind) (setf (var-loc var) cvar) (wt-nl) (unless block-p (wt "{") (setq block-p t)) (wt-var-decl var) ))))) (dolist** (v requireds) (do-decl v)) (dolist** (opt optionals) (do-decl (car opt)) (when (caddr opt) (do-decl (caddr opt)))) (when rest (do-decl rest)) ) ;;; check arguments (when (or *safe-compile* *compiler-check-args*) (cond ((or rest optionals) (when requireds (wt-nl "if(vs_top-vs_base<" (length requireds) ") too_few_arguments();")) (unless rest (wt-nl "if(vs_top-vs_base>" (+ (length requireds) (length optionals)) ") too_many_arguments();"))) (t (wt-nl "check_arg(" (length requireds) ");")))) ;;; Allocate the parameters. (dolist** (var requireds) (setf (var-ref var) (vs-push))) (dolist** (opt optionals) (setf (var-ref (car opt)) (vs-push))) (when rest (setf (var-ref rest) (vs-push))) (dolist** (opt optionals) (when (caddr opt) (setf (var-ref (caddr opt)) (vs-push)))) ;;; Bind required parameters. (dolist** (var requireds) (c2bind var)) ;;; Bind optional parameters as long as there remain arguments. ;;; The compile-time binding is discarded because they are bound again. (when (and (or optionals rest) (not (null requireds))) (wt-nl "vs_base=vs_base+" (length requireds) ";")) (cond (optionals (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (when rest (wt-nl "vs_top[0]=Cnil;") (wt-nl "{object *p=vs_top, *q=vs_base+" (length optionals) ";") (wt-nl " for(;p>q;p--)p[-1]=MMcons(p[-1],p[0]);}")) (do ((opts optionals (cdr opts))) ((endp opts)) (declare (object opts)) (push (next-label) labels) (wt-nl "if(vs_base>=vs_top){") (reset-top) (wt-go (car labels)) (wt "}") (c2bind (caar opts)) (when (caddar opts) (c2bind-loc (caddar opts) t)) (when (cdr opts) (wt-nl "vs_base++;")) ) (when rest (c2bind rest)) ) (wt-nl) (reset-top) (let ((label (next-label))) (wt-nl) (wt-go label) (setq labels (nreverse labels)) ;;; Bind unspecified optional parameters. (dolist** (opt optionals) (wt-label (car labels)) (pop labels) (c2bind-init (car opt) (cadr opt)) (when (caddr opt) (c2bind-loc (caddr opt) nil))) (when rest (c2bind-loc rest nil)) (wt-label label))) (rest (wt-nl "vs_top[0]=Cnil;") (wt-nl "{object *p=vs_top;") (wt-nl " for(;p>vs_base;p--)p[-1]=" (if *rest-on-stack* "ON_STACK_CONS" "MMcons") "(p[-1],p[0]);}") (c2bind rest) (wt-nl) (reset-top)) (t (wt-nl) (reset-top))) (when *tail-recursion-info* (push 'tail-recursion-mark *unwind-exit*) (wt-nl "goto TTL;")(wt-nl1 "TTL:;")) ;;; Now the parameters are ready! (c2expr body) (when block-p (wt-nl "}")) ) (defun c2lambda-expr-with-key (lambda-list body &aux (requireds (nth 0 lambda-list)) (optionals (nth 1 lambda-list)) (rest (nth 2 lambda-list)) (keywords (nth 4 lambda-list)) (allow-other-keys (nth 5 lambda-list)) (labels nil) (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*) (block-p nil) ) (declare (object requireds optionals rest keywords allow-other-keys)) ;;; Allocate immediate-type parameters. (flet ((do-decl (var) (let ((kind (c2var-kind var))) (declare (object kind)) (when kind (let ((cvar (next-cvar))) (setf (var-kind var) kind) (setf (var-loc var) cvar) (wt-nl) (unless block-p (wt "{") (setq block-p t)) (wt-var-decl var) ))))) (dolist** (v requireds) (do-decl v)) (dolist** (opt optionals) (do-decl (car opt)) (when (caddr opt) (do-decl (caddr opt)))) (when rest (do-decl rest)) (dolist** (kwd keywords) (do-decl (cadr kwd)) (when (cadddr kwd) (do-decl (cadddr kwd)))) ) ;;; Check arguments. (when (and (or *safe-compile* *compiler-check-args*) requireds) (when requireds (wt-nl "if(vs_top-vs_base<" (length requireds) ") too_few_arguments();"))) ;;; Allocate the parameters. (dolist** (var requireds) (setf (var-ref var) (vs-push))) (dolist** (opt optionals) (setf (var-ref (car opt)) (vs-push))) (when rest (setf (var-ref rest) (vs-push))) (dolist** (kwd keywords) (setf (var-ref (cadr kwd)) (vs-push))) (dolist** (kwd keywords) (setf (var-ref (cadddr kwd)) (vs-push))) (dolist** (opt optionals) (when (caddr opt) (setf (var-ref (caddr opt)) (vs-push)))) ;;; Assign rest and keyword parameters first. ;;; parse_key does not change vs_base and vs_top. (wt-nl "parse_key(vs_base") (when (or requireds optionals) (wt "+" (+ (length requireds) (length optionals)))) (if rest (wt ",TRUE,") (wt ",FALSE,")) (if allow-other-keys (wt "TRUE,") (wt "FALSE,")) (wt (length keywords)) (dolist** (kwd keywords) (wt "," (vv-str (add-symbol (car kwd))))) (wt ");") ;;; Bind required parameters. (dolist** (var requireds) (c2bind var)) ;;; Bind optional parameters as long as there remain arguments. ;;; The compile-time binding is discarded because they are bound again. (when optionals (when requireds (wt-nl "vs_base += " (length requireds) ";")) (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (do ((opts optionals (cdr opts))) ((endp opts)) (declare (object opts)) (push (next-label) labels) (wt-nl "if(vs_base>=vs_top){") (reset-top) (wt-go (car labels)) (wt "}") (c2bind (caar opts)) (when (caddar opts) (c2bind-loc (caddar opts) t)) (when (cdr opts) (wt-nl "vs_base++;")))) (setq labels (nreverse labels)) ) (reset-top) (when optionals (let ((label (next-label))) (wt-go label) ;;; Bind unspecified optional parameters. (dolist** (opt optionals) (wt-label (car labels)) (pop labels) (c2bind-init (car opt) (cadr opt)) (when (caddr opt) (c2bind-loc (caddr opt) nil))) (wt-label label) )) (when rest (c2bind rest)) ;;; Bind keywords. (dolist** (kwd keywords) (cond ((and (eq (caaddr kwd) 'LOCATION) (null (caddr (caddr kwd)))) ;;; Cnil has been set if keyword parameter is not supplied. (c2bind (cadr kwd))) (t (wt-nl "if(") (wt-vs (var-ref (cadddr kwd))) (wt "==Cnil){") (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (c2bind-init (cadr kwd) (caddr kwd))) (wt-nl "}else{") (c2bind (cadr kwd)) (wt "}"))) (unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind (cadddr kwd)))) ;;; Now the parameters are ready, after all! (c2expr body) (when block-p (wt-nl "}")) ) (defun need-to-set-vs-pointers (lambda-list) ;;; On entry to in-line lambda expression, ;;; vs_base and vs_top must be set iff, (or *safe-compile* *compiler-check-args* (nth 1 lambda-list) ;;; optional, (nth 2 lambda-list) ;;; rest, or (nth 3 lambda-list) ;;; key-flag. )) ;;; The DEFMACRO compiler. ;;; valid lambda-list to DEFMACRO is: ;;; ;;; ( [ &whole sym ] ;;; [ &environment sym ] ;;; { v }* ;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] ;;; { [ { &rest | &body } v ] ;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* ;;; [ &allow-other-keys ]] ;;; [ &aux { sym | ( v [ init ] ) }* ] ;;; | . sym } ;;; ) ;;; ;;; where v is short for { defmacro-lambda-list | sym }. ;;; Defamcro-lambda-list is defined as: ;;; ;;; ( { v }* ;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] ;;; { [ { &rest | &body } v ] ;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* ;;; [ &allow-other-keys ]] ;;; [ &aux { sym | ( v [ init ] ) }* ] ;;; | . sym } ;;; ) (defvar *vnames*) (defvar *dm-info*) (defvar *dm-vars*) (defun c1dm (macro-name vl body &aux (*vs* *vs*) (whole nil) (env nil) (setjmps *setjmps*) (*vnames* nil) (*dm-info* (make-info)) (*dm-vars* nil) doc ss is ts other-decls ppn) (multiple-value-setq (body ss ts is other-decls doc) (c1body body t)) (setq body (list (list* 'block macro-name body))) (c1add-globals ss) (when (and (listp vl) (eq (car vl) '&whole)) (push (cadr vl) *vnames*) (setq whole (c1make-var (cadr vl) ss is ts)) (push whole *dm-vars*) (push whole *vars*) (setq vl (cddr vl)) ) (let ((env-m (and (listp vl) (do ((tail vl (cdr tail))) ((not (consp tail)) nil) (when (eq '&environment (car tail)) (return tail)))))) (when env-m (push (cadr env-m) *vnames*) (setq env (c1make-var (cadr env-m) ss is ts)) (push env *dm-vars*) (push env *vars*) (setq vl (append (ldiff vl env-m) (cddr env-m))))) (multiple-value-setq (vl ppn) (c1dm-vl vl ss is ts)) (check-vdecl *vnames* ts is) (setq body (c1decl-body other-decls body)) (add-info *dm-info* (cadr body)) (cond ((eql setjmps *setjmps*)) (t(setf (info-volatile *dm-info*) t) (setf (get macro-name 'contains-setjmp) t) )) (dolist* (v *dm-vars*) (check-vref v)) (list doc ppn whole env vl body *dm-info*) ) (defun c1dm-vl (vl ss is ts) (do ((optionalp nil) (restp nil) (keyp nil) (allow-other-keys-p nil) (auxp nil) (requireds nil) (optionals nil) (rest nil) (key-flag nil) (keywords nil) (auxs nil) (allow-other-keys nil) (n 0) (ppn nil) ) ((not (consp vl)) (when vl (when restp (dm-bad-key '&rest)) (setq rest (c1dm-v vl ss is ts))) (values (list (nreverse requireds) (nreverse optionals) rest key-flag (nreverse keywords) allow-other-keys (nreverse auxs)) ppn) ) (let ((v (car vl))) (declare (object v)) (cond ((eq v '&optional) (when optionalp (dm-bad-key '&optional)) (setq optionalp t) (pop vl)) ((or (eq v '&rest) (eq v '&body)) (when restp (dm-bad-key v)) (setq rest (c1dm-v (cadr vl) ss is ts)) (setq restp t optionalp t) (setq vl (cddr vl)) (when (eq v '&body) (setq ppn n))) ((eq v '&key) (when keyp (dm-bad-key '&key)) (setq keyp t restp t optionalp t key-flag t) (pop vl)) ((eq v '&allow-other-keys) (when (or (not keyp) allow-other-keys-p) (dm-bad-key '&allow-other-keys)) (setq allow-other-keys-p t allow-other-keys t) (pop vl)) ((eq v '&aux) (when auxp (dm-bad-key '&aux)) (setq auxp t allow-other-keys-p t keyp t restp t optionalp t) (pop vl)) (auxp (let (x init) (cond ((symbolp v) (setq x v init (c1nil))) (t (setq x (car v)) (if (endp (cdr v)) (setq init (c1nil)) (setq init (c1expr* (cadr v) *dm-info*))))) (push (list (c1dm-v x ss is ts) init) auxs)) (pop vl)) (keyp (let (x k init (sv nil)) (cond ((symbolp v) (setq x v k (intern (string v) 'keyword) init (c1nil))) (t (if (symbolp (car v)) (setq x (car v) k (intern (string (car v)) 'keyword)) (setq x (cadar v) k (caar v))) (cond ((endp (cdr v)) (setq init (c1nil))) (t (setq init (c1expr* (cadr v) *dm-info*)) (unless (endp (cddr v)) (setq sv (caddr v))))))) (push (list k (c1dm-v x ss is ts) init (if sv (c1dm-v sv ss is ts) nil)) keywords) ) (pop vl)) (optionalp (let (x init (sv nil)) (cond ((symbolp v) (setq x v init (c1nil))) (t (setq x (car v)) (cond ((endp (cdr v)) (setq init (c1nil))) (t (setq init (c1expr* (cadr v) *dm-info*)) (unless (endp (cddr v)) (setq sv (caddr v))))))) (push (list (c1dm-v x ss is ts) init (if sv (c1dm-v sv ss is ts) nil)) optionals)) (pop vl) (incf n) ) (t (push (c1dm-v v ss is ts) requireds) (pop vl) (incf n)) ))) ) (defun c1dm-v (v ss is ts) (cond ((symbolp v) (push v *vnames*) (setq v (c1make-var v ss is ts)) (push v *vars*) (push v *dm-vars*) v) (t (c1dm-vl v ss is ts)))) (defun c1dm-bad-key (key) (cmperr "Defmacro-lambda-list contains illegal use of ~s." key)) (defmacro maybe-wt-c2dm-bind-vl (vl cvar form end-form) `(let ((ipos (file-position *compiler-output1*))) ,form (let ((npos (file-position *compiler-output1*))) (c2dm-bind-vl ,vl ,cvar) (if (eql npos (file-position *compiler-output1*)) (file-position *compiler-output1* ipos) ,end-form)))) (defun c2dm (whole env vl body &aux (cvar (next-cvar))) (when (or *safe-compile* *compiler-check-args*) (wt-nl "check_arg(2);")) (cond (whole (setf (var-ref whole) (vs-push))) (t (vs-push))) (cond (env (setf (var-ref env) (vs-push))) (t (vs-push))) (c2dm-reserve-vl vl) (reset-top) (when whole (c2bind whole)) (when env (c2bind env)) (maybe-wt-c2dm-bind-vl vl cvar (wt-nl "{object V" cvar "=base[0]->c.c_cdr;") (wt "}")) (c2expr body) ) (defun c2dm-reserve-vl (vl) (dolist** (var (car vl)) (c2dm-reserve-v var)) (dolist** (opt (cadr vl)) (c2dm-reserve-v (car opt)) (when (caddr opt) (c2dm-reserve-v (caddr opt)))) (when (caddr vl) (c2dm-reserve-v (caddr vl))) (dolist** (kwd (car (cddddr vl))) (c2dm-reserve-v (cadr kwd)) (when (cadddr kwd) (c2dm-reserve-v (cadddr kwd)))) (dolist** (aux (caddr (cddddr vl))) (c2dm-reserve-v (car aux))) ) (defun c2dm-reserve-v (v) (if (consp v) (c2dm-reserve-vl v) (setf (var-ref v) (vs-push)))) (defun c2dm-bind-vl (vl cvar &aux (requireds (car vl)) (optionals (cadr vl)) (rest (caddr vl)) (key-flag (cadddr vl)) (keywords (car (cddddr vl))) (allow-other-keys (cadr (cddddr vl))) (auxs (caddr (cddddr vl))) ) (declare (object requireds optionals rest key-flag keywords allow-other-keys auxs)) (do ((reqs requireds (cdr reqs))) ((endp reqs)) (declare (object reqs)) (when (or *safe-compile* *compiler-check-args*) (wt-nl "if(endp(V" cvar "))invalid_macro_call();")) (c2dm-bind-loc (car reqs) `(car ,cvar)) (when (or (cdr reqs) optionals rest key-flag *safe-compile* *compiler-check-args*) (wt-nl "V" cvar "=V" cvar "->c.c_cdr;"))) (do ((opts optionals (cdr opts))) ((endp opts)) (declare (object opts)) (let ((opt (car opts))) (declare (object opt)) (wt-nl "if(endp(V" cvar ")){") (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (c2dm-bind-init (car opt) (cadr opt)) (when (caddr opt) (c2dm-bind-loc (caddr opt) nil)) ) (wt-nl "} else {") (c2dm-bind-loc (car opt) `(car ,cvar)) (when (caddr opt) (c2dm-bind-loc (caddr opt) t))) (when (or (cdr opts) rest key-flag *safe-compile* *compiler-check-args*) (wt-nl "V" cvar "=V" cvar "->c.c_cdr;")) (wt "}")) (when rest (c2dm-bind-loc rest `(cvar ,cvar))) (dolist** (kwd keywords) (let ((cvar1 (next-cvar))) (wt-nl "{object V" cvar1 "=getf(V" cvar "," (vv-str (add-symbol (car kwd))) ",OBJNULL);") (wt-nl "if(V" cvar1 "==OBJNULL){") (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (c2dm-bind-init (cadr kwd) (caddr kwd)) (when (cadddr kwd) (c2dm-bind-loc (cadddr kwd) nil)) (wt "} else {")) (c2dm-bind-loc (cadr kwd) `(cvar ,cvar1)) (when (cadddr kwd) (c2dm-bind-loc (cadddr kwd) t)) (wt-nl "}}"))) (when (and (or *safe-compile* *compiler-check-args*) (null rest) (null key-flag)) (wt-nl "if(!endp(V" cvar "))invalid_macro_call();")) (when (and (or *safe-compile* *compiler-check-args*) key-flag (not allow-other-keys)) (wt-nl "check_other_key(V" cvar "," (length keywords)) (dolist** (kwd keywords) (wt "," (vv-str (add-symbol (car kwd))))) (wt ");")) (dolist** (aux auxs) (c2dm-bind-init (car aux) (cadr aux))) ) (defun c2dm-bind-loc (v loc) (if (consp v) (let ((cvar (next-cvar))) (maybe-wt-c2dm-bind-vl v cvar (wt-nl "{object V" cvar "= " loc ";") (wt "}"))) (c2bind-loc v loc))) (defun c2dm-bind-init (v init) (if (consp v) (let* ((*vs* *vs*) (*inline-blocks* 0) (cvar (next-cvar)) (loc (car (inline-args (list init) '(t))))) (maybe-wt-c2dm-bind-vl v cvar (wt-nl "{object V" cvar "= " loc ";") (wt "}")) (close-inline-blocks)) (c2bind-init v init))) gcl/cmpnew/gcl_cmplet.lsp000077500000000000000000000311451242227143400157550ustar00rootroot00000000000000;;; CMPLET Let and Let*. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (eval-when (compile) (or (fboundp 'write-block-open) (load "cmplet.lsp"))) (si:putprop 'let 'c1let 'c1special) (si:putprop 'let 'c2let 'c2) (si:putprop 'let* 'c1let* 'c1special) (si:putprop 'let* 'c2let* 'c2) (defun c1let (args &aux (info (make-info))(setjmps *setjmps*) (forms nil) (vars nil) (vnames nil) ss is ts body other-decls (*vars* *vars*)) (when (endp args) (too-few-args 'let 1 0)) (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) (c1add-globals ss) (dolist** (x (car args)) (cond ((symbolp x) (let ((v (c1make-var x ss is ts))) (push x vnames) (push v vars) (push (default-init (var-type v)) forms))) (t (cmpck (not (and (consp x) (or (endp (cdr x)) (endp (cddr x))))) "The variable binding ~s is illegal." x) (let ((v (c1make-var (car x) ss is ts))) (push (car x) vnames) (push v vars) (push (if (endp (cdr x)) (default-init (var-type v)) (and-form-type (var-type v) (c1expr* (cadr x) info) (cadr x))) forms))))) (setq *vars* (append vars *vars*)) ; (dolist* (v (reverse vars)) (push v *vars*)) (check-vdecl vnames ts is) (setq body (c1decl-body other-decls body)) (add-info info (cadr body)) (setf (info-type info) (info-type (cadr body))) (dolist** (var vars) (check-vref var)) (or (eql setjmps *setjmps*) (setf (info-volatile info) t)) (list 'let info (nreverse vars) (nreverse forms) body) ) (defun c2let (vars forms body &aux (block-p nil) (bindings nil) initials (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (declare (object block-p)) (do ((vl vars (cdr vl)) (fl forms (cdr fl)) (prev-ss nil)) ((endp vl)) (declare (object vl fl)) (let* ((form (car fl)) (var (car vl)) (kind (c2var-kind var))) (declare (object form var)) (cond (kind (setf (var-kind var) kind) (setf (var-loc var) (next-cvar))) ((eq (var-kind var) 'down) (or (si::fixnump (var-loc var)) (wfs-error))) (t (setf (var-ref var) (vs-push)))) (case (var-kind var) ((FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER) (push (list 'c2expr* (list 'var var nil) form) initials)) (otherwise (case (car form) (LOCATION (if (can-be-replaced var body) (progn (setf (var-kind var) 'REPLACED) (setf (var-loc var) (caddr form))) (push (list var (caddr form)) bindings))) (VAR (let ((var1 (caaddr form))) (declare (object var1)) (cond ((or (args-info-changed-vars var1 (cdr fl)) (and (member (var-kind var1) '(SPECIAL GLOBAL)) (member (var-name var1) prev-ss))) (push (list 'c2expr* (cond ((eq (var-kind var) 'object) (list 'var var nil)) ((eq (var-kind var) 'down) ;(push (list var) bindings) (list 'down (var-loc var))) (t(push (list var) bindings) (list 'vs (var-ref var)))) form)initials)) ((and (can-be-replaced var body) (member (var-kind var1) '(LEXICAL REPLACED OBJECT)) (null (var-ref-ccb var1)) (not (is-changed var1 (cadr body)))) (setf (var-kind var) 'REPLACED) (setf (var-loc var) (case (var-kind var1) (LEXICAL (list 'vs (var-ref var1))) (REPLACED (var-loc var1)) (OBJECT (list 'cvar (var-loc var1))) (otherwise (baboon))))) (t (push (list var (list 'var var1 (cadr (caddr form)))) bindings))))) (t (push (list 'c2expr* (cond ((eq (var-kind var) 'object) (list 'var var nil)) ((eq (var-kind var) 'down) ;(push (list var) bindings) (list 'down (var-loc var))) (t(push (list var) bindings) (list 'vs (var-ref var)))) form) initials)) ))) (when (eq (var-kind var) 'SPECIAL) (push (var-name var) prev-ss)) )) (setq block-p (write-block-open vars)) (dolist* (binding (nreverse initials)) (let ((*value-to-go* (second binding))) (c2expr* (third binding)))) (dolist* (binding (nreverse bindings)) (if (cdr binding) (c2bind-loc (car binding) (cadr binding)) (c2bind (car binding)))) (c2expr body) (when block-p (wt "}")) ) (defun c1let* (args &aux (forms nil) (vars nil) (vnames nil) (setjmps *setjmps*) ss is ts body other-decls (info (make-info)) (*vars* *vars*)) (when (endp args) (too-few-args 'let* 1 0)) (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) (c1add-globals ss) (dolist** (x (car args)) (cond ((symbolp x) (let ((v (c1make-var x ss is ts))) (push x vnames) (push (default-init (var-type v)) forms) (push v vars) (push v *vars*))) ((not (and (consp x) (or (endp (cdr x)) (endp (cddr x))))) (cmperr "The variable binding ~s is illegal." x)) (t (let ((v (c1make-var (car x) ss is ts))) (push (car x) vnames) (push (if (endp (cdr x)) (default-init (var-type v)) (and-form-type (var-type v) (c1expr* (cadr x) info) (cadr x))) forms) (push v vars) (push v *vars*))))) (check-vdecl vnames ts is) (setq body (c1decl-body other-decls body)) (add-info info (cadr body)) (setf (info-type info) (info-type (cadr body))) (dolist** (var vars) (check-vref var)) (or (eql setjmps *setjmps*) (setf (info-volatile info) t)) (list 'let* info (nreverse vars) (nreverse forms) body) ) (defun c2let* (vars forms body &aux (block-p nil) (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (declare (object block-p)) (do ((vl vars (cdr vl)) (fl forms (cdr fl))) ((endp vl)) (declare (object vl fl)) (let* ((form (car fl)) (var (car vl)) (kind (c2var-kind var))) (declare (object form var)) (cond (kind (setf (var-kind var) kind) (setf (var-loc var) (next-cvar)))) (if (member (var-kind var) '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER)) nil (case (car form) (LOCATION (cond ((can-be-replaced* var body (cdr fl)) (setf (var-kind var) 'REPLACED) (setf (var-loc var) (caddr form))) ((eq (var-kind var) 'object)) ((eq (var-kind var) 'down) (or (si::fixnump (var-loc var)) (baboon))) (t (setf (var-ref var) (vs-push)) ))) (VAR (let ((var1 (caaddr form))) (declare (object var1)) (cond ((and (can-be-replaced* var body (cdr fl)) (member (var-kind var1) '(LEXICAL REPLACED OBJECT)) (null (var-ref-ccb var1)) (not (args-info-changed-vars var1 (cdr fl))) (not (is-changed var1 (cadr body)))) (setf (var-kind var) 'REPLACED) (setf (var-loc var) (case (var-kind var1) (LEXICAL (list 'vs (var-ref var1))) (REPLACED (var-loc var1)) (OBJECT (list 'cvar (var-loc var1))) (t (baboon))))) ((eq (var-kind var)'object)) (t (setf (var-ref var) (vs-push)) ))) ) ; ((eq (var-kind var) 'object)) (t (unless (eq (var-kind var) 'object) (setf (var-ref var) (vs-push))) ))) )) (setq block-p (write-block-open vars)) (do ((vl vars (cdr vl)) (fl forms (cdr fl)) (var nil) (form nil)) ((null vl)) (setq var (car vl))(setq form (car fl)) ; (print (list (var-kind var) (car form))) (case (var-kind var) ((FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT INTEGER) (let ((*value-to-go* (list 'var var nil))) (c2expr* form))) (REPLACED ) (t (case (car form) (LOCATION (c2bind-loc var (caddr form))) (VAR (c2bind-loc var (list 'var (caaddr form) (cadr (caddr form))))) (t (c2bind-init var form)))))) (c2expr body) (when block-p (wt "}")) ) (defun can-be-replaced (var body) (and (or (eq (var-kind var) 'LEXICAL) (and (eq (var-kind var) 'object) (< (the fixnum (var-register var)) (the fixnum *register-min*)))) (null (var-ref-ccb var)) (not (eq (var-loc var) 'clb)) (not (is-changed var (cadr body))))) (defun can-be-replaced* (var body forms) (and (can-be-replaced var body) (dolist** (form forms t) (when (is-changed var (cadr form)) (return nil))) )) (defun write-block-open (vars) (let ( block-p) (dolist** (var vars) (let ((kind (var-kind var))) (declare (object kind)) (when (member kind '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT INTEGER)) (wt-nl) (unless block-p (wt "{") (setq block-p t)) (wt-var-decl var) ))) block-p )) ;; ---------- stack-let for consing on stack --------- ;; Usage: (stack-let ((a (cons 1 2)) (b (cons 3 4))) (foo a) (print b) 7) ;; where foo must not keep a copy of `a', since the cons will be formed ;; on the c stack. (setf (get 'stack-let 'c1special) 'c1stack-let) (defmacro stack-let (&rest x) (cons `let x)) (defun c1stack-let (args &aux npairs nums) (let ((pairs (car args)) ) (dolist (v pairs) (push (cond ((atom v) v) ((let ((var (car v)) (val (second v))) (and (consp val) (or (eq (car val) 'cons) (and (eq (car val) 'list) (null (cddr val)) (setq val `(cons ,(second val) nil)))) (progn (push (next-cvar) nums) `(,var (stack-cons ,(car nums) ,@ (cdr val))))))) (t (cmpwarn "Stack let = regular let for ~a ~a" v (cdr args)) v)) npairs)) (let ((result (c1expr (cons 'let (cons (nreverse npairs) (cdr args)))))) (list 'stack-let (second result) nums result)))) (setf (get 'stack-let 'c2) 'c2stack-let) (defun c2stack-let (nums form) (let ((n (next-cvar))) (wt-nl "{Cons_Macro" n ";") (c2expr form) (wt "}") (wt-h "#define Cons_Macro" n (format nil " struct cons ~{STcons~a ~^,~};" nums) ))) (push '((fixnum t t) t #.(flags) "(STcons#0.t=t_cons,STcons#0.m=0,STcons#0.c_car=(#1), STcons#0.c_cdr=SAFE_CDR(#2),(object)&STcons#0)") (get 'stack-cons 'inline-always)) ;; ---------- end stack-let for consing on stack --------- gcl/cmpnew/gcl_cmploc.lsp000077500000000000000000000243451242227143400157520ustar00rootroot00000000000000;;; CMPLOC Set-loc and Wt-loc. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (defvar *value-to-go*) ;;; Valid locations are: ;;; NIL ;;; T ;;; 'FUN-VAL' ;;; ( 'VS' vs-address ) ;;; ( 'VS*' vs-address ) ;;; ( 'CCB-VS' ccb-vs ) ;;; ( 'VAR' var-object ccb ) ;;; ( 'VV' vv-index ) ;;; ( 'CVAR' cvar ) ;;; ( 'INLINE' side-effect-p fun/string locs ) ;;; ( 'INLINE-COND' side-effect-p fun/string locs ) ;;; ( 'INLINE-FIXNUM' side-effect-p fun/string locs ) ;;; ( 'INLINE-CHARACTER' side-effect-p fun/string locs ) ;;; ( 'INLINE-LONG-FLOAT' side-effect-p fun/string locs ) ;;; ( 'INLINE-SHORT-FLOAT' side-effect-p fun/string locs ) ;;; ( 'SIMPLE-CALL { SYMLISPCALL-NO-EVENT ;;; | LISPCALL-NO-EVENT ;;; | SYMLISPCALL ;;; | LISPCALL } ;;; vs-index number-of-arguments [ vv-index ] ) ;;; ( 'VS-BASE' offset ) ;;; ( 'CAR' cvar ) ;;; ( 'CADR' cvar ) ;;; ( 'SYMBOL-FUNCTION' vv-index ) ;;; ( 'MAKE-CCLOSURE' cfun cllink ) ;;; ( 'FIXNUM-VALUE' vv-index fixnum-value ) ;;; ( 'FIXNUM-LOC' loc ) ;;; ( 'CHARACTER-VALUE' vv-index character-code ) ;;; ( 'CHARACTER-LOC' loc ) ;;; ( 'LONG-FLOAT-VALUE' vv-index long-float-value ) ;;; ( 'LONG-FLOAT-LOC' loc ) ;;; ( 'SHORT-FLOAT-VALUE' vv-index short-float-value ) ;;; ( 'SHORT-FLOAT-LOC' loc ) ;;; Valid *value-to-go* locations are: ;;; ;;; 'RETURN' The value is returned from the current function. ;;; 'RETURN-FIXNUM' ;;; 'RETURN-CHARACTER' ;;; 'RETURN-LONG-FLOAT' ;;; 'RETURN-SHORT-FLOAT' ;;; 'RETURN-OBJECT ;;; 'TRASH' The value may be thrown away. ;;; 'TOP' The value should be set at the top of vs as if it were ;;; a resulted value of a function call. ;;; ( 'VS' vs-address ) ;;; ( 'VS*' vs-address ) ;;; ( 'CCB-VS' ccb-vs ) ;;; ( 'VAR' var-object ccb ) ;;; ( 'JUMP-TRUE' label ) ;;; ( 'JUMP-FALSE' label ) ;;; ( 'BDS-BIND' vv-index ) ;;; ( 'PUSH-CATCH-FRAME' ) ;;; ( 'DBIND' symbol-name-vv ) (si:putprop 'cvar 'wt-cvar 'wt-loc) (si:putprop 'vv 'wt-vv 'wt-loc) (si:putprop 'car 'wt-car 'wt-loc) (si:putprop 'cdr 'wt-cdr 'wt-loc) (si:putprop 'cadr 'wt-cadr 'wt-loc) (si:putprop 'vs-base 'wt-vs-base 'wt-loc) (si:putprop 'fixnum-value 'wt-fixnum-value 'wt-loc) (si:putprop 'fixnum-loc 'wt-fixnum-loc 'wt-loc) (si:putprop 'integer-loc 'wt-integer-loc 'wt-loc) (si:putprop 'character-value 'wt-character-value 'wt-loc) (si:putprop 'character-loc 'wt-character-loc 'wt-loc) (si:putprop 'long-float-value 'wt-long-float-value 'wt-loc) (si:putprop 'long-float-loc 'wt-long-float-loc 'wt-loc) (si:putprop 'short-float-value 'wt-short-float-value 'wt-loc) (si:putprop 'short-float-loc 'wt-short-float-loc 'wt-loc) (si::putprop 'next-var-arg 'wt-next-var-arg 'wt-loc) (si::putprop 'first-var-arg 'wt-first-var-arg 'wt-loc) (defun wt-first-var-arg () (wt "first")) (defun wt-next-var-arg () (wt "va_arg(ap,object)")) (defun set-loc (loc &aux fd) (cond ((eq *value-to-go* 'return) (set-return loc)) ((eq *value-to-go* 'trash) (cond ((and (consp loc) (member (car loc) '(INLINE INLINE-COND INLINE-FIXNUM inline-integer INLINE-CHARACTER INLINE-LONG-FLOAT INLINE-SHORT-FLOAT)) (cadr loc)) (wt-nl "(void)(") (wt-inline t (caddr loc) (cadddr loc)) (wt ");")) ((and (consp loc) (eq (car loc) 'SIMPLE-CALL)) (wt-nl "(void)" loc ";")))) ((eq *value-to-go* 'top) (unless (eq loc 'fun-val) (set-top loc))) ((eq *value-to-go* 'return-fixnum) (set-return-fixnum loc)) ((eq *value-to-go* 'return-character) (set-return-character loc)) ((eq *value-to-go* 'return-long-float) (set-return-long-float loc)) ((eq *value-to-go* 'return-short-float) (set-return-short-float loc)) ((or (not (consp *value-to-go*)) (not (symbolp (car *value-to-go*)))) (baboon)) ((setq fd (get (car *value-to-go*) 'set-loc)) (apply fd loc (cdr *value-to-go*))) ((setq fd (get (car *value-to-go*) 'wt-loc)) (wt-nl) (apply fd (cdr *value-to-go*)) (wt "= " loc ";")) (t (baboon))) ) (defun wt-loc (loc) (cond ((eq loc nil) (wt "Cnil")) ((eq loc t) (wt "Ct")) ((eq loc 'fun-val) (wt "vs_base[0]")) ((or (not (consp loc)) (not (symbolp (car loc)))) (baboon)) (t (let ((fd (get (car loc) 'wt-loc))) (when (null fd) (baboon)) (apply fd (cdr loc))))) ) (defun set-return (loc) (cond ((eq loc 'fun-val)) ((and (consp loc) (eq (car loc) 'vs) (= (caadr loc) *level*)) (wt-nl "vs_top=(vs_base=base+" (cdadr loc) ")+1;") (base-used)) ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'LEXICAL) (not (var-ref-ccb (cadr loc))) (eql (car (var-ref (cadr loc))) *level*)) (wt-nl "vs_top=(vs_base=base+" (cdr (var-ref (cadr loc))) ")+1;") (base-used)) (t (set-top loc))) ) (defun set-top (loc) (let ((*vs* *vs*)) (wt-nl) (wt-vs (vs-push)) (wt "= " loc ";") (wt-nl "vs_top=(vs_base=base+" (1- *vs*) ")+1;") (base-used))) (defun wt-vs-base (offset) (wt "vs_base[" offset "]")) (defun wt-car (cvar) (wt "(V" cvar "->c.c_car)")) (defun wt-cdr (cvar) (wt "(V" cvar "->c.c_cdr)")) (defun wt-cadr (cvar) (wt "(V" cvar "->c.c_cdr->c.c_car)")) (defun wt-cvar (cvar &optional type) (if type (wt "/* " (symbol-name type) " */")) (wt "V" cvar)) (defun vv-str (vv) (let ((vv (add-object2 vv))) (si::string-concatenate "((object)VV[" (write-to-string vv) "])"))) (defun wt-vv (vv) (wt (vv-str vv))) (defun wt-fixnum-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'FIXNUM)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'INLINE-FIXNUM)) (wt "(long)")(wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (eq (car loc) 'fixnum-value)) (wt "(long)")(wt (caddr loc))) ((and (consp loc) (member (car loc) '(INLINE-SHORT-FLOAT INLINE-LONG-FLOAT))) (wt "((long)(") (wt-inline-loc (caddr loc) (cadddr loc)) (wt "))")) (t (wt "fix(" loc ")")))) (defun wt-integer-loc (loc &optional type &aux (avma t)(first (and (consp loc) (car loc)))) (declare (ignore type)) (case first (inline-fixnum (wt "stoi(") (wt-inline-loc (caddr loc) (cadddr loc)) (wt ")")) (INLINE-INTEGER (setq avma nil) (wt-inline-loc (caddr loc) (cadddr loc))) (fixnum-value (wt "stoi(" (caddr loc) ")")) (var (case (var-kind (cadr loc)) (integer (setq avma nil) (wt "V" (var-loc (cadr loc)))) (fixnum (wt "stoi(V" (var-loc (cadr loc))")")) (otherwise (wt "otoi(" loc ")")))) (otherwise (wt "otoi(" loc ")"))) (and avma (not *restore-avma*)(wfs-error)) ) (defun fixnum-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'FIXNUM)) (eq (car loc) 'INLINE-FIXNUM) (eq (car loc) 'fixnum-value)))) (defun wt-fixnum-value (vv fixnum-value) (if vv (wt (vv-str vv)) (wt "small_fixnum(" fixnum-value ")"))) (defun wt-character-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'CHARACTER)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'INLINE-CHARACTER)) (wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (eq (car loc) 'CHARACTER-VALUE)) (wt (caddr loc))) (t (wt "char_code(" loc ")")))) (defun character-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'CHARACTER)) (eq (car loc) 'INLINE-CHARACTER) (eq (car loc) 'character-value)))) (defun wt-character-value (vv character-code) (declare (ignore character-code)) (wt (vv-str vv))) (defun wt-long-float-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'LONG-FLOAT)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'INLINE-LONG-FLOAT)) (wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (eq (car loc) 'long-float-value)) (wt (caddr loc))) (t (wt "lf(" loc ")")))) (defun long-float-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'LONG-FLOAT)) (eq (car loc) 'INLINE-LONG-FLOAT) (eq (car loc) 'long-float-value)))) (defun wt-long-float-value (vv long-float-value) (declare (ignore long-float-value)) (wt (vv-str vv))) (defun wt-short-float-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'SHORT-FLOAT)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'INLINE-SHORT-FLOAT)) (wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (eq (car loc) 'short-float-value)) (wt (caddr loc))) (t (wt "sf(" loc ")")))) (defun short-float-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'SHORT-FLOAT)) (eq (car loc) 'INLINE-SHORT-FLOAT) (eq (car loc) 'short-float-value)))) (defun wt-short-float-value (vv short-float-value) (declare (ignore short-float-value)) (wt (vv-str vv))) gcl/cmpnew/gcl_cmpmain.lsp000077500000000000000000000672341242227143400161250ustar00rootroot00000000000000;;; CMPMAIN Compiler main program. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; **** Caution **** ;;; This file is machine/OS dependant. ;;; ***************** (in-package 'compiler) (export '(*compile-print* *compile-verbose*)) (import 'si::*tmp-dir* 'compiler) (import 'si::*error-p* 'compiler) ;;; This had been true with Linux 1.2.13 a.out or even older ;;; #+linux (push :ld-not-accept-data *features*) ;;; its now a bug preventing the :linux feature. (defvar *compiler-in-use* nil) (defvar *compiler-compile* nil) (defvar *compiler-input*) (defvar *compiler-output1*) (defvar *compiler-output2*) (defvar *compiler-output-data*) (defvar *compiler-output-i*) (defvar *compile-print* nil) (defvar *compile-verbose* t) (defvar *cmpinclude* "\"cmpinclude.h\"") ;;If the following is a string, then it is inserted instead of ;; the include file cmpinclude.h, EXCEPT for system-p calls. (defvar *cmpinclude-string* t) ;; Let the user write dump c-file etc to /dev/null. (defun get-output-pathname (file ext name &optional (dir (pathname-directory *default-pathname-defaults*)) (device (pathname-device *default-pathname-defaults*))) (cond ((equal file "/dev/null") (pathname file)) #+aix3 ((and (equal name "float") (equal ext "h")) (get-output-pathname file ext "Float" )) (t (make-pathname :device (or (and (not (null file)) (not (eq file t)) (pathname-device file)) device) :directory (or (and (not (null file)) (not (eq file t)) (pathname-directory file)) dir) :name (or (and (not (null file)) (not (eq file t)) (pathname-name file)) name) :type ext)))) (defun safe-system (string) (multiple-value-bind (code result) (system (ts string)) (unless (and (zerop code) (zerop result)) (cerror "Continues anyway." "(SYSTEM ~S) returned a non-zero value ~D." string result) (setq *error-p* t)) (values result))) ;; If this is t we use fasd-data on all but system-p files. If it ;; is :system-p we use it on all files. If nil use it on none. (defvar *fasd-data* t) (defvar *data* nil) (defvar *default-system-p* nil) (defvar *default-c-file* nil) (defvar *default-h-file* nil) (defvar *default-data-file* nil) (defvar *keep-gaz* nil) ;; (list section-length split-file-names next-section-start-file-position) ;; Many c compilers cannot handle the large C files resulting from large lisp files. ;; If *split-files* is a number then, separate compilations for sections ;; *split-files* long, with the ;; will be performed for separate chunks of the lisp files. (defvar *split-files* nil) ;; if (defun check-end (form eof) (cond ((eq form eof) (setf (third *split-files*) nil)) ((> (file-position *compiler-input*) (car *split-files*)) (setf (third *split-files*)(file-position *compiler-input*))))) (defun compile-file (&rest args &aux (*print-pretty* nil) (*package* *package*) (*split-files* *split-files*) (*PRINT-CIRCLE* NIL) (*PRINT-RADIX* NIL) (*PRINT-ARRAY* T) (*PRINT-LEVEL* NIL) (*PRINT-PRETTY* T) (*PRINT-LENGTH* NIL) (*PRINT-GENSYM* T) (*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (*PRINT-ESCAPE* T) (section-length *split-files*) tem) (loop (compiler::init-env) (setq tem (apply 'compiler::compile-file1 args)) (cond ((atom *split-files*)(return tem)) ((and (consp *split-files*) (null (third *split-files*))) (let ((gaz (let ((*DEFAULT-PATHNAME-DEFAULTS* (car args))) (gazonk-name))) (*readtable* (si::standard-readtable))) (setq gaz (get-output-pathname gaz "lsp" (car args))) (with-open-file (st gaz :direction :output) (print `(eval-when (load eval) (dolist (v ',(nreverse (second *split-files*))) (load (merge-pathnames v si::*load-pathname*)))) st)) (setq *split-files* nil) (or (member :output-file args) (setq args (append args (list :output-file (car args))))) (return (prog1 (apply 'compile-file gaz (cdr args)) (unless *keep-gaz* (mdelete-file gaz)))) )) (t nil)) (if (consp *split-files*) (setf (car *split-files*) (+ (third *split-files*) section-length))) )) (defun compile-file1 (input-pathname &key (output-file input-pathname) (o-file t) (c-file *default-c-file*) (h-file *default-h-file*) (data-file *default-data-file*) (c-debug nil) (system-p *default-system-p*) (print nil) (load nil) &aux (*standard-output* *standard-output*) (*error-output* *error-output*) (*compiler-in-use* *compiler-in-use*) (*c-debug* c-debug) (*compile-print* (or print *compile-print*)) (*package* *package*) (*DEFAULT-PATHNAME-DEFAULTS* #"") (*data* (list (make-array 50 :fill-pointer 0 :adjustable t) nil nil)) *init-name* (*fasd-data* *fasd-data*) (*error-count* 0)) (declare (special *c-debug* *init-name* system-p)) (cond (*compiler-in-use* (format t "~&The compiler was called recursively.~%~ Cannot compile ~a.~%" (namestring (merge-pathnames input-pathname #".lsp"))) (setq *error-p* t) (return-from compile-file1 (values))) (t (setq *error-p* nil) (setq *compiler-in-use* t))) (unless (probe-file (merge-pathnames input-pathname #".lsp")) (format t "~&The source file ~a is not found.~%" (namestring (merge-pathnames input-pathname #".lsp"))) (setq *error-p* t) (return-from compile-file1 (values))) (when *compile-verbose* (format t "~&Compiling ~a.~%" (namestring (merge-pathnames input-pathname #".lsp")))) (and *record-call-info* (clear-call-table)) (with-open-file (*compiler-input* (merge-pathnames input-pathname #".lsp")) (cond ((numberp *split-files*) (if (< (file-length *compiler-input*) *split-files*) (setq *split-files* nil) (setq *split-files* (list *split-files* nil 0 nil))))) (cond ((consp *split-files*) (file-position *compiler-input* (third *split-files*)) (setq output-file (make-pathname :directory (pathname-directory output-file) :name (format nil "~a~a" (length (second *split-files*)) (pathname-name (pathname output-file))) :type "o")) (push (pathname-name output-file) (second *split-files*)))) (let* ((eof (cons nil nil)) (dir (or (and (not (null output-file)) (pathname-directory output-file)) (pathname-directory input-pathname))) (name (or (and (not (null output-file)) (pathname-name output-file)) (pathname-name input-pathname))) (device (or (and (not (null output-file)) (pathname-device output-file)) (pathname-device input-pathname))) (o-pathname (get-output-pathname o-file "o" name dir device)) (c-pathname (get-output-pathname c-file "c" name dir device)) (h-pathname (get-output-pathname h-file "h" name dir device)) (data-pathname (get-output-pathname data-file "data" name dir device))) (declare (special dir name )) (init-env) (and (boundp 'si::*gcl-version*) (not system-p) (add-init `(si::warn-version ,si::*gcl-major-version* ,si::*gcl-minor-version* ,si::*gcl-extra-version*))) (when (probe-file "./gcl_cmpinit.lsp") (load "./gcl_cmpinit.lsp" :verbose *compile-verbose*)) (with-open-file (*compiler-output-data* data-pathname :direction :output) (when *fasd-data* (setq *fasd-data* (list (si::open-fasd *compiler-output-data* :output nil nil)))) (wt-data-begin) (if *compiler-compile* (t1expr *compiler-compile*) (let* ((rtb *readtable*) (prev (and (eq (get-macro-character #\# rtb) (get-macro-character #\# (si:standard-readtable))) (get-dispatch-macro-character #\# #\, rtb)))) (if (and prev (eq prev (get-dispatch-macro-character #\# #\, (si:standard-readtable)))) (set-dispatch-macro-character #\# #\, 'si:sharp-comma-reader-for-compiler rtb) (setq prev nil)) ;; t1expr the package ops again.. (if (consp *split-files*) (dolist (v (fourth *split-files*)) (t1expr v))) (unwind-protect (do ((form (read *compiler-input* nil eof) (read *compiler-input* nil eof)) (load-flag (or (eq :defaults *eval-when-defaults*) (member 'load *eval-when-defaults*)))) (nil) (cond ((eq form eof)) (load-flag (t1expr form)) ((maybe-eval nil form))) (cond ((and *split-files* (check-end form eof)) (setf (fourth *split-files*) (reverse (third *data*))) (return nil)) ((eq form eof) (return nil)))) (when prev (set-dispatch-macro-character #\# #\, prev rtb))))) (setq *init-name* (init-name input-pathname system-p)) (when (zerop *error-count*) (when *compile-verbose* (format t "~&End of Pass 1. ~%")) (compiler-pass2 c-pathname h-pathname system-p )) (wt-data-end)) ;;; *compiler-output-data* closed. (init-env) (if (zerop *error-count*) (progn (when *compile-verbose* (format t "~&End of Pass 2. ~%")) (cond (*record-call-info* (dump-fn-data (get-output-pathname output-file "fn" name dir device)))) (cond (o-file (compiler-cc c-pathname o-pathname ) (cond ((probe-file o-pathname) (compiler-build o-pathname data-pathname) (when load (load o-pathname)) (when *compile-verbose* (print-compiler-info) (format t "~&Finished compiling ~a.~%" (namestring output-file) ))) (t (format t "~&Your C compiler failed to compile the intermediate file.~%") (setq *error-p* t)))) (*compile-verbose* (print-compiler-info) (format t "~&Finished compiling ~a.~%" (namestring output-file) ))) (unless c-file (mdelete-file c-pathname)) (unless h-file (mdelete-file h-pathname)) (unless (or data-file #+ld-not-accept-data t system-p) (mdelete-file data-pathname)) o-pathname) (progn (when (probe-file c-pathname) (mdelete-file c-pathname)) (when (probe-file h-pathname) (mdelete-file h-pathname)) (when (probe-file data-pathname) (mdelete-file data-pathname)) (format t "~&No FASL generated.~%") (setq *error-p* t) (values) )))))) (defun gazonk-name () (dotimes (i 1000) (let ((tem (merge-pathnames (format nil "~agazonk_~d_~d.lsp" (if (boundp '*tmp-dir*) *tmp-dir* "") (abs (si::getpid)) i)))) (unless (probe-file tem) (return-from gazonk-name (pathname tem))))) (error "1000 gazonk names used already!")) (defun prin1-cmp (form strm) (let ((*compiler-output-data* strm) (*fasd-data* nil)) (wt-data1 form) ;; this binds all the print stuff )) (defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* #".")) (cond ((not(symbolp name)) (error "Must be a name")) ((and (consp def) (member (car def) '(lambda ))) (or name (setf name 'cmp-anon)) (setf (symbol-function name) def) (compile name)) (def (error "def not a lambda expression")) ((setq tem (macro-function name)) (setf (symbol-function 'cmp-anon) tem) (compile 'cmp-anon) (setf (macro-function name) (macro-function name)) ;; FIXME -- support warnings-p and failures-p. CM 20041119 (values name nil nil)) ((and (setq tem (symbol-function name)) (consp tem)) (let ((na (if (symbol-package name) name 'cmp-anon))) (unless (and (fboundp 'si::init-cmp-anon) (or (si::init-cmp-anon) (fmakunbound 'si::init-cmp-anon))) (with-open-file (st (setq gaz (gazonk-name)) :direction :output)) (let* ((*compiler-compile* `(defun ,na ,@(ecase (car tem) (lambda (cdr tem)) (lambda-block (cddr tem))))) (fi (compile-file gaz))) (when (pathnamep fi) (load fi) (mdelete-file fi))) (unless *keep-gaz* (mdelete-file gaz))) (or (eq na name) (setf (symbol-function name) (symbol-function na))) ;; FIXME -- support warnings-p and failures-p. CM 20041119 (values (symbol-function name) nil nil) )) (t (error "can't compile ~a" name)))) (defun disassemble (name &aux tem) (cond ((and (consp name) (eq (car name) 'lambda)) (eval `(defun cmp-anon ,@ (cdr name))) (disassemble 'cmp-anon)) ((not(symbolp name)) (error "Not a lambda or a name")) ((setq tem(macro-function name)) (setf (symbol-function 'cmp-tmp-macro) tem) (disassemble 'cmp-tmp-macro) (setf (macro-function name) (macro-function name)) name) ((and (setq tem (symbol-function name)) (consp tem) (eq (car tem) 'lambda-block)) (let ((gaz (gazonk-name))) (with-open-file (st gaz :direction :output) (prin1-cmp `(defun ,name ,@ (cddr tem)) st)) (let (*fasd-data*) (compile-file gaz :h-file t :c-file t :data-file t :o-file t)) (let ((cn (get-output-pathname gaz "c" gaz )) (dn (get-output-pathname gaz "data" gaz )) (hn (get-output-pathname gaz "h" gaz )) (on (get-output-pathname gaz "o" gaz ))) (with-open-file (st cn) (do () ((let ((a (read-line st))) (when (>= (si::string-match "gazonk_[0-9]*_[0-9]*.h" a) 0) (format t "~%~d~%" a) a)))) (si::copy-stream st *standard-output*)) (with-open-file (st dn) (si::copy-stream st *standard-output*)) (with-open-file (st hn) (si::copy-stream st *standard-output*)) (when (zerop (system "which objdump >/dev/null")) (safe-system (si::string-concatenate "objdump --source " (namestring on)))) (mdelete-file cn) (mdelete-file dn) (mdelete-file hn) (mdelete-file on) (unless *keep-gaz* (mdelete-file gaz))))) (t (error "can't disassemble ~a" name)))) (defun compiler-pass2 (c-pathname h-pathname system-p &aux (ci *cmpinclude*) (ci (when (stringp ci) (subseq ci 1 (1- (length ci))))) (ci (concatenate 'string si::*system-directory* "../h/" ci)) (system-p (when (probe-file ci) system-p))) (declare (special *init-name*)) (with-open-file (st c-pathname :direction :output) (let ((*compiler-output1* st)) (declare (special *compiler-output1*)) (with-open-file (*compiler-output2* h-pathname :direction :output) (cond ((and (stringp *cmpinclude-string*) (not system-p) (si::fwrite *cmpinclude-string* 0 (length *cmpinclude-string*) *compiler-output1*))) (t (wt-nl1 "#include " *cmpinclude*))) (wt-nl1 "#include \"" (namestring (make-pathname :name (pathname-name h-pathname) :type (pathname-type h-pathname))) "\"") (catch *cmperr-tag* (ctop-write *init-name*)) (terpri *compiler-output1*) ;; write ctl-z at end to make sure preprocessor stops! #+dos (write-char (code-char 26) *compiler-output1*) (terpri *compiler-output2*))))) (defvar *cc* "cc") (defvar *ld* "ld") (defvar *ld-libs* "ld-libs") (defvar *opt-three* "") (defvar *opt-two* "") (defvar *init-lsp* "init-lsp") (defvar *use-buggy* nil) (defun compiler-command (&rest args &aux na ) (declare (special *c-debug*)) (let ((dirlist (pathname-directory (first args))) (name (pathname-name (first args))) dir) (cond (dirlist (setq dir (namestring (make-pathname :directory dirlist)))) (t (setq dir "."))) (setq na (namestring (make-pathname :name name :type (pathname-type(first args))))) #+(or dos winnt) (format nil "~a -I~a ~a ~a -c -w ~s -o ~s" *cc* (concatenate 'string si::*system-directory* "../h") (if (and (boundp '*c-debug*) *c-debug*) " -g " "") (case *speed* (3 *opt-three* ) (2 *opt-two*) (t "")) (namestring (make-pathname :type "c" :defaults (first args))) (namestring (make-pathname :type "o" :defaults (first args))) ) #-(or dos winnt) (format nil "~a -I~a ~a ~a -c ~s -o ~s ~a" *cc* (concatenate 'string si::*system-directory* "../h") (if (and (boundp '*c-debug*) *c-debug*) " -g " "") (case *speed* (3 *opt-three* ) (2 *opt-two*) (t "")) (namestring (first args)) (namestring (second args)) (prog1 #+aix3 (format nil " -w ;ar x /lib/libc.a fsavres.o ; ar qc XXXfsave fsavres.o ; echo init_~a > XXexp ; mv ~a XXX~a ; ld -r -D-1 -bexport:XXexp -bgc XXX~a -o ~a XXXfsave ; rm -f XXX~a XXexp XXXfsave fsavres.o" *init-name* (setq na (namestring (get-output-pathname na "o" nil))) na na na na na) #+(or dlopen irix5) (if (not system-p) (format nil " -w ; mv ~a XX~a ; ld ~a -shared XX~a -o ~a -lc ; rm -f XX~a" (setq na (namestring (get-output-pathname na "o" nil))) na #+ignore-unresolved "-ignore_unresolved" #+expect-unresolved "-expect_unresolved '*'" na na na)) #+bsd ""; "-w" #-(or aix3 bsd irix3) " 2> /dev/null ") ) ) ) #+winnt (defun prep-win-path-acc ( s acc) (let ((pos (search "\~" s))) (if pos (let ((start (subseq s 0 (1+ pos))) (finish (subseq s (1+ pos)))) (prep-win-path-acc finish (concatenate 'string acc start "~"))) (concatenate 'string acc s)))) #+winnt (defun no-device (c) (let* ((c (namestring (truename c))) (p (search ":" c))) (if p (subseq c (1+ p)) c))) ;; #+winnt ;; (defun prep-win-path (c o) ;; (let* ((w si::*wine-detected*) ;; (c (if w (no-device c) c)) ;; (o (if w (no-device o) o))) ;; (prep-win-path-acc (compiler-command c o) ""))) (defun compiler-cc (c-pathname o-pathname) (safe-system (format nil (prog1 #+irix5 (compiler-command c-pathname o-pathname ) #+vax "~a ~@[~*-O ~]-S -I. -w ~a ; as -J -W -o ~A ~A" #+(or system-v e15 dgux sgi ) "~a ~@[~*-O ~]-c -I. ~a 2> /dev/null" #+winnt (prep-win-path-acc (compiler-command c-pathname o-pathname) "") #-winnt (compiler-command c-pathname o-pathname) ) *cc* (if (or (= *speed* 2) (= *speed* 3)) t nil) (namestring c-pathname) (namestring o-pathname) )) #+dont_need (let ((cname (pathname-name c-pathname)) (odir (pathname-directory o-pathname)) (oname (pathname-name o-pathname))) (unless (and (equalp (truename "./") (truename (make-pathname :directory odir))) (equal cname oname)) (rename-file (make-pathname :name cname :type "o") o-pathname) ))) (defun compiler-build (o-pathname data-pathname) #+(and system-v (not e15)) (safe-system (format nil "echo \"\\000\\000\\000\\000\" >> ~A" (namestring o-pathname))) #+(or hp-ux sun sgi) (with-open-file (o-file (namestring o-pathname) :direction :output :if-exists :append) ; we could do a safe-system, but forking is slow on the Iris #+(or hp-ux (and sgi (not irix5))) (dotimes (i 12) (write-char #\^@ o-file)) #+sun ; we could do a safe-system, but forking is slow on the Iris (dolist (v '(0 0 4 16 0 0 0 0)) (write-byte v o-file)) ) #-ld-not-accept-data (when (probe-file o-pathname) (nconc-files o-pathname data-pathname) #+never (safe-system (format nil "cat ~a >> ~A" (namestring data-pathname) (namestring o-pathname))))) (defun print-compiler-info () (format t "~&OPTIMIZE levels: Safety=~d~:[ (No runtime error checking)~;~], Space=~d, Speed=~d~%" (cond ((null *compiler-check-args*) 0) ((null *safe-compile*) 1) ((null *compiler-push-events*) 2) (t 3)) *safe-compile* *space* *speed*)) (defun nconc-files (a b) (let* ((n 256) (tem (make-string n)) (m 0)) (with-open-file (st-a a :direction :output :if-exists :append) (with-open-file (st-b b ) (sloop::sloop do (setq m (si::fread tem 0 n st-b)) while (and m (> m 0)) do (si::fwrite tem 0 m st-a)))))) #+dos (progn (defun directory (x &aux ans) (let* ((pa (pathname x)) (temp "XXDIR") tem (name (pathname-name pa))) (setq pa (make-pathname :directory (pathname-directory pa) :name (or (pathname-name pa) :wild) :type (pathname-type pa))) (setq name (namestring pa)) (safe-system (format nil "ls -d ~a > ~a" name temp)) (with-open-file (st temp) (loop (setq tem (read-line st nil nil)) (if (and tem (setq tem (probe-file tem))) (push tem ans) (return)))) ans)) (defvar *old-compile-file* #'compile-file) (defun compile-file (f &rest l) (let* ((p (pathname f)) dir pwd) (setq dir (pathname-directory p)) (when dir (setq dir (namestring (make-pathname :directory dir :name "."))) (setq pwd (namestring (truename "."))) ) (unwind-protect (progn (if dir (si::chdir dir)) (apply *old-compile-file* f l)) (if pwd (si::chdir pwd))))) (defun user-homedir-pathname () (or (si::getenv "HOME") "/")) ) ; ; These functions are added to build custom images requiring ; the loading of binary objects on systems relocating with dlopen. ; (defun make-user-init (files outn) (let* ((c (pathname outn)) (c (merge-pathnames c (make-pathname :directory '(:current)))) (o (merge-pathnames (make-pathname :type "o") c)) (c (merge-pathnames (make-pathname :type "c") c))) (with-open-file (st c :direction :output) (format st "#include ~a~%~%" *cmpinclude*) (format st "#define load2(a) do {") (format st "printf(\"Loading %s...\\n\",(a));") (format st "load(a);") (format st "printf(\"Finished %s...\\n\",(a));} while(0)~%~%") (let ((p nil)) (dolist (tem files) (when (equal (pathname-type tem) "o") (let ((tem (namestring tem))) (push (list (si::find-init-name tem) tem) p)))) (setq p (nreverse p)) (dolist (tem p) (format st "extern void ~a(void);~%" (car tem))) (format st "~%") (format st "typedef struct {void (*fn)(void);char *s;} Fnlst;~%") (format st "#define NF ~a~%" (length p)) (format st "static Fnlst my_fnlst[NF]={") (dolist (tem p) (when (not (eq tem (car p))) (format st ",~%")) (format st "{~a,\"~a\"}" (car tem) (cadr tem))) (format st "};~%~%") (format st "static int user_init_run;~%") (format st "#define my_load(a_,b_) {if (!user_init_run && (a_) && (b_)) gcl_init_or_load1((a_),(b_));(a_)=0;(b_)=0;}~%~%") (format st "object user_init(void) {~%") (format st "user_init_run=1;~%") (dolist (tem files) (let ((tem (namestring tem))) (cond ((equal (cadr (car p)) tem) (format st "gcl_init_or_load1(~a,\"~a\");~%" (car (car p)) tem) (setq p (cdr p))) (t (format st "load2(\"~a\");~%" tem))))) (format st "return Cnil;}~%~%") (format st "static int my_strncmp(const char *s1,const char *s2,unsigned long n) {") (format st " for (;n--;) if (*s1++!=*s2++) return 1; return 0;}") (format st "int user_match(const char *s,int n) {~%") (format st " Fnlst *f;~%") (format st " for (f=my_fnlst;fs && !my_strncmp(s,f->s,n)) {~%") (format st " my_load(f->fn,f->s);~%") (format st " return 1;~%") (format st " }~%") (format st " }~%") (format st " return 0;~%") (format st "}~%~%"))) (compiler-cc c o) (mdelete-file c) o)) (defun mysub (str it new) (let ((x (search it str))) (unless x (return-from mysub str)) (let ((y (+ (length it) (the fixnum x)))) (declare (fixnum y)) (concatenate (type-of str) (subseq str 0 x) new (mysub (subseq str y) it new))))) (eval-when (compile eval) (defmacro fcr (x) `(load-time-value (si::compile-regexp ,x))) (defmacro sml (x y &optional z) (let ((q (gensym))) `(let ((,q (si::string-match ,x ,y ,@(when z (list z))))) (if (= ,q -1) (length ,y) ,q))))) (defun ts (s &optional (r "")) (declare (string s) (ignorable r)) #+winnt (if (not si::*wine-detected*) s (let* ((x (sml (fcr #u"[^ \n\t]") s)) (y (sml (fcr #u"[ \n\t]") s x)) (f (subseq s x y)) (l (subseq s y)) (k (when (> (length f) 0) (aref f 0))) (q (if (eql k #\") (string k) "")) (f (if (eql k #\") (subseq f 1 (1- (length f))) f)) (f (if (and k (not (eql k #\-))) (namestring (no-device f)) f))) (if k (concatenate 'string r q f q (ts l " ")) ""))) #-winnt s) (defun mdelete-file (x) (delete-file (ts (namestring x)))) (defun link (files image &optional post extra-libs (run-user-init t)) (let* ((ui (make-user-init files "user-init")) (raw (pathname image)) (init (merge-pathnames (make-pathname :name (concatenate 'string "init_" (pathname-name raw)) :type "lsp") raw)) (raw (merge-pathnames raw (truename "./"))) (raw (merge-pathnames (make-pathname :name (concatenate 'string "raw_" (pathname-name raw))) raw)) (map (merge-pathnames (make-pathname :name (concatenate 'string (pathname-name raw) "_map")) raw)) #+winnt (raw (merge-pathnames (make-pathname :type "exe") raw)) ) (with-open-file (st (namestring map) :direction :output)) (safe-system (let* ((par (namestring (make-pathname :directory '(:parent)))) (i (concatenate 'string " " par)) (j (concatenate 'string " " si::*system-directory* par))) (format nil "~a ~a ~a ~a -L~a ~a ~a ~a" (mysub *ld* i j) (namestring raw) (namestring ui) (let ((sfiles "")) (dolist (tem files) (if (equal (pathname-type tem) "o") (setq sfiles (concatenate 'string sfiles " " (namestring tem))))) sfiles) si::*system-directory* #+gnu-ld (format nil "-Wl,-Map ~a" (namestring map)) #-gnu-ld "" (if (stringp extra-libs) extra-libs "") (mysub *ld-libs* i j)))) (mdelete-file ui) (with-open-file (st init :direction :output) (unless run-user-init (format st "(fmakunbound 'si::user-init)~%")) (format st "(setq si::*no-init* '(") (dolist (tem files) (format st " \"~a\"" (pathname-name tem))) (format st "))~%") (with-open-file (st1 (format nil "~a~a" si::*system-directory* *init-lsp*)) (si::copy-stream st1 st)) (if (stringp post) (format st "~a~%" post)) (format st "(si::save-system \"~a\")~%" (ts (namestring image)))) (safe-system (format nil "~a ~a < ~a" (namestring raw) si::*system-directory* (namestring init))) (mdelete-file raw) (mdelete-file init)) image) gcl/cmpnew/gcl_cmpmap.lsp000077500000000000000000000236131242227143400157470ustar00rootroot00000000000000;;; CMPMAP Map functions. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (si:putprop 'mapcar 'c1mapcar 'c1) (si:putprop 'maplist 'c1maplist 'c1) (si:putprop 'mapcar 'c2mapcar 'c2) (si:putprop 'mapc 'c1mapc 'c1) (si:putprop 'mapl 'c1mapl 'c1) (si:putprop 'mapc 'c2mapc 'c2) (si:putprop 'mapcan 'c1mapcan 'c1) (si:putprop 'mapcon 'c1mapcon 'c1) (si:putprop 'mapcan 'c2mapcan 'c2) (defun c1mapcar (args) (c1map-functions 'mapcar t args)) (defun c1maplist (args) (c1map-functions 'mapcar nil args)) (defun c1mapc (args) (c1map-functions 'mapc t args)) (defun c1mapl (args) (c1map-functions 'mapc nil args)) (defun c1mapcan (args) (c1map-functions 'mapcan t args)) (defun c1mapcon (args) (c1map-functions 'mapcan nil args)) (defun c1map-functions (name car-p args &aux funob info) (when (or (endp args) (endp (cdr args))) (too-few-args 'map-function 2 (length args))) (setq funob (c1funob (car args))) (setq info (copy-info (cadr funob))) (list name info funob car-p (c1args (cdr args) info)) ) (defun c2mapcar (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0)) (let ((label (next-label*)) (value-loc (list 'VS (vs-push))) (handy (list 'CVAR (next-cvar))) (handies (mapcar #'(lambda (x) (declare (ignore x)) (list 'CVAR (next-cvar))) args)) save ) (setq save (save-funob funob)) ; (setq args (inline-args args ; (make-list (length args) :initial-element t))) (setq args (push-changed-vars (inline-args args (make-list (length args) :initial-element t)) funob)) (wt-nl "{object " handy ";") (dolist** (loc handies) (wt-nl "object " loc "= " (car args) ";") (pop args)) (cond (*safe-compile* (wt-nl "if(endp(" (car handies) ")") (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) (wt "){")) (t (wt-nl "if(" (car handies) "==Cnil") (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil")) (wt "){"))) (unwind-exit nil 'jump) (wt "}") (wt-nl value-loc "=" handy "=MMcons(Cnil,Cnil);") (wt-label label) (let* ((*value-to-go* (list 'CAR (cadr handy))) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2funcall funob (if car-p (mapcar #'(lambda (loc) (list 'LOCATION *info* (list 'CAR (cadr loc)))) handies) (mapcar #'(lambda (loc) (list 'LOCATION *info* loc)) handies)) save) (wt-label *exit*)) (cond (*safe-compile* (wt-nl (car handies) "=MMcdr(" (car handies) ");") (dolist** (loc (cdr handies)) (wt-nl loc "=MMcdr(" loc ");")) (wt-nl "if(endp(" (car handies) ")") (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) (wt "){")) (t (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil") (dolist** (loc (cdr handies)) (wt "||(" loc "=MMcdr(" loc "))==Cnil")) (wt "){"))) (unwind-exit value-loc 'jump) (wt "}") (wt-nl handy "=MMcdr(" handy ")=MMcons(Cnil,Cnil);") (wt-nl) (wt-go label) (wt "}") (close-inline-blocks) ) ) (defun c2mapc (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0)) (let ((label (next-label*)) value-loc (handies (mapcar #'(lambda (x) (declare (ignore x)) (list 'CVAR (next-cvar))) args)) save ) (setq save (save-funob funob)) ; (setq args (inline-args args ; (make-list (length args) :initial-element t))) (setq args (push-changed-vars (inline-args args (make-list (length args) :initial-element t)) funob)) (setq value-loc (car args)) (wt-nl "{") (dolist** (loc handies) (wt-nl "object " loc "= " (car args) ";") (pop args)) (cond (*safe-compile* (wt-nl "if(endp(" (car handies) ")") (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) (wt "){")) (t (wt-nl "if(" (car handies) "==Cnil") (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil")) (wt "){"))) (unwind-exit nil 'jump) (wt "}") (wt-label label) (let* ((*value-to-go* 'trash) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2funcall funob (if car-p (mapcar #'(lambda (loc) (list 'LOCATION *info* (list 'CAR (cadr loc)))) handies) (mapcar #'(lambda (loc) (list 'LOCATION *info* loc)) handies)) save) (wt-label *exit*)) (cond (*safe-compile* (wt-nl (car handies) "=MMcdr(" (car handies) ");") (dolist** (loc (cdr handies)) (wt-nl loc "=MMcdr(" loc ");")) (wt-nl "if(endp(" (car handies) ")") (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) (wt "){")) (t (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil") (dolist** (loc (cdr handies)) (wt "||(" loc "=MMcdr(" loc "))==Cnil")) (wt "){"))) (unwind-exit value-loc 'jump) (wt "}") (wt-nl) (wt-go label) (wt "}") (close-inline-blocks) ) ) (defun c2mapcan (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0)) (let ((label (next-label*)) (value-loc (list 'VS (vs-push))) (handy (list 'CVAR (next-cvar))) (handies (mapcar #'(lambda (x) (declare (ignore x)) (list 'CVAR (next-cvar))) args)) save ) (setq save (save-funob funob)) ; (setq args (inline-args args ; (make-list (length args) :initial-element t))) (setq args (push-changed-vars (inline-args args (make-list (length args) :initial-element t)) funob)) (wt-nl "{object " handy ";") (dolist** (loc handies) (wt-nl "object " loc "= " (car args) ";") (pop args)) (cond (*safe-compile* (wt-nl "if(endp(" (car handies) ")") (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) (wt "){")) (t (wt-nl "if(" (car handies) "==Cnil") (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil")) (wt "){"))) (unwind-exit nil 'jump) (wt "}") (wt-nl value-loc "=" handy "=MMcons(Cnil,Cnil);") (wt-label label) (let* ((*value-to-go* (list 'cdr (cadr handy))) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*)) ) (c2funcall funob (if car-p (mapcar #'(lambda (loc) (list 'LOCATION *info* (list 'CAR (cadr loc)))) handies) (mapcar #'(lambda (loc) (list 'LOCATION *info* loc)) handies)) save) (wt-label *exit*)) (cond (*safe-compile* (wt-nl "{object cdr_" handy "=MMcdr(" handy ");while(!endp(cdr_" handy ")) {cdr_" handy "=MMcdr(cdr_" handy ");" handy "=MMcdr(" handy ");}}") (wt-nl (car handies) "=MMcdr(" (car handies) ");") (dolist** (loc (cdr handies)) (wt-nl loc "=MMcdr(" loc ");")) (wt-nl "if(endp(" (car handies) ")") (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) (wt "){")) (t (wt-nl "while(MMcdr(" handy ")!=Cnil)" handy "=MMcdr(" handy ");") (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil") (dolist** (loc (cdr handies)) (wt "||(" loc "=MMcdr(" loc "))==Cnil")) (wt "){"))) (wt-nl value-loc "=" value-loc "->c.c_cdr;") (unwind-exit value-loc 'jump) (wt "}") (wt-nl) (wt-go label) (wt "}") (close-inline-blocks) ) ) (defun push-changed-vars (locs funob &aux (locs1 nil) (forms (list funob))) (dolist (loc locs (reverse locs1)) (if (and (consp loc) (eq (car loc) 'VAR) (args-info-changed-vars (cadr loc) forms)) (let ((temp (list 'VS (vs-push)))) (wt-nl temp "= " loc ";") (push temp locs1)) (push loc locs1)))) gcl/cmpnew/gcl_cmpmulti.lsp000077500000000000000000000244541242227143400163300ustar00rootroot00000000000000;;; CMPMULT Multiple-value-call and Multiple-value-prog1. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (si:putprop 'multiple-value-call 'c1multiple-value-call 'c1special) (si:putprop 'multiple-value-call 'c2multiple-value-call 'c2) (si:putprop 'multiple-value-prog1 'c1multiple-value-prog1 'c1special) (si:putprop 'multiple-value-prog1 'c2multiple-value-prog1 'c2) (si:putprop 'values 'c1values 'c1) (si:putprop 'values 'c2values 'c2) (si:putprop 'multiple-value-setq 'c1multiple-value-setq 'c1) (si:putprop 'multiple-value-setq 'c2multiple-value-setq 'c2) (si:putprop 'multiple-value-bind 'c1multiple-value-bind 'c1) (si:putprop 'multiple-value-bind 'c2multiple-value-bind 'c2) (defun c1multiple-value-call (args &aux info funob) (when (endp args) (too-few-args 'multiple-value-call 1 0)) (cond ((endp (cdr args)) (c1funcall args)) (t (setq funob (c1funob (car args))) (setq info (copy-info (cadr funob))) (setq args (c1args (cdr args) info)) (list 'multiple-value-call info funob args))) ) (defun c2multiple-value-call (funob forms &aux (*vs* *vs*) loc top sup) (cond ((endp (cdr forms)) (setq loc (save-funob funob)) (let ((*value-to-go* 'top)) (c2expr* (car forms))) (c2funcall funob 'args-pushed loc)) (t (setq top (next-cvar)) (setq sup (next-cvar)) (setq loc (save-funob funob)) (base-used) ;; Add (sup .var) handling in unwind-exit -- in ;; c2multiple-value-prog1 and c2-multiple-value-call, apparently ;; alone, c2expr-top is used to evaluate arguments, presumably to ;; preserve certain states of the value stack for the purposes of ;; retrieving the final results. c2exprt-top rebinds sup, and ;; vs_top in turn to the new sup, causing non-local exits to lose ;; the true top of the stack vital for subsequent function ;; evaluations. We unwind this stack supremum variable change here ;; when necessary. CM 20040301 (wt-nl "{object *V" top "=base+" *vs* ",*V" sup "=sup;") (dolist** (form forms) (let ((*value-to-go* 'top) (*unwind-exit* (cons (cons 'sup sup) *unwind-exit*))) (c2expr-top* form top)) (wt-nl "while(vs_base=vs_top){") (reset-top) (wt-go (car labels)) (wt "}") (c2bind-loc (car vs) '(vs-base 0)) (unless (endp (cdr vs)) (wt-nl "vs_base++;")))) (wt-nl) (reset-top) (let ((label (next-label))) (wt-nl) (wt-go label) (setq labels (nreverse labels)) (dolist** (v vars) (wt-label (car labels)) (pop labels) (c2bind-loc v nil)) (wt-label label)) (c2expr body) (when block-p (wt "}")) ) gcl/cmpnew/gcl_cmpopt.lsp000077500000000000000000001263231242227143400157760ustar00rootroot00000000000000(in-package 'compiler) ;; The optimizers have been redone to allow more flags ;; The old style optimizations correspond to the first 2 ;; flags. ;; ( arglist result-type flags {string | function}) ;; meaning of the flags slot. ; '((allocates-new-storage ans); might invoke gbc ; (side-effect-p set) ; no effect on arguments ; (constantp) ; always returns same result, ; ;double eval ok. ; (result-type-from-args rfa); if passed args of matching ; ;type result is of result type ; (is))) ;; extends the `integer stack'. ; (cond ((member flag v :test 'eq) ; ;;; valid properties are 'inline-always 'inline-safe 'inline-unsafe ;; Note: The order of the properties is important, since the first ;; one whose arg types and result type can be matched will be chosen. (or (fboundp 'flags) (load "../cmpnew/cmpeval.lsp")) ;;INTEGER-LENGTH (push '((t) t #.(compiler::flags) "immnum_length(#0)") (get 'integer-length 'compiler::inline-always)) ;;LOGCOUNT (push '((t) t #.(compiler::flags) "immnum_count(#0)") (get 'logcount 'compiler::inline-always)) ;;LOGBITP (push '((t t) boolean #.(compiler::flags) "immnum_bitp(#0,#1)") (get 'logbitp 'compiler::inline-always)) ;;ABS (push '((t) t #.(compiler::flags) "immnum_abs(#0)") (get 'abs 'compiler::inline-always)) ;;ASH (push '((t t) t #.(compiler::flags) "immnum_shft(#0,#1)") (get 'ash 'compiler::inline-always)) ;;GCD (push '((t t) t #.(compiler::flags) "immnum_gcd(#0,#1)") (get 'gcd 'compiler::inline-always)) ;;LCM (push '((t t) t #.(compiler::flags) "immnum_lcm(#0,#1)") (get 'lcm 'compiler::inline-always)) ;;BOOLE (push '((t t t) t #.(compiler::flags) "immnum_bool(#0,#1,#2)") (get 'boole 'compiler::inline-always)) (push '((fixnum t t) t #.(compiler::flags) "immnum_boole(#0,#1,#2)") (get 'boole 'compiler::inline-always)) ;;BOOLE3 (push '((fixnum fixnum fixnum) fixnum #.(flags rfa)INLINE-BOOLE3) (get 'boole3 'inline-always)) ;;FP-OKP (push '((t) boolean #.(flags set) "@0;(type_of(#0)==t_stream? ((#0)->sm.sm_fp)!=0: 0 )") (get 'fp-okp 'inline-unsafe)) (push '((stream) boolean #.(flags set)"((#0)->sm.sm_fp)!=0") (get 'fp-okp 'inline-unsafe)) ;;LDB1 (push '((fixnum fixnum fixnum) fixnum #.(flags) "((((~(-1 << (#0))) << (#1)) & (#2)) >> (#1))") (get 'si::ldb1 'inline-always)) ;;LONG-FLOAT-P (push '((t) boolean #.(flags)"type_of(#0)==t_longfloat") (get 'long-float-p 'inline-always)) ;;SFEOF (push '((object) boolean #.(flags set)"(gcl_feof((#0)->sm.sm_fp))") (get 'sfeof 'inline-unsafe)) ;;SGETC1 (push '((object) fixnum #.(flags set rfa) "gcl_getc((#0)->sm.sm_fp)") (get 'sgetc1 'inline-unsafe)) ;;SPUTC (push '((fixnum object) fixnum #.(flags set rfa)"(gcl_putc(#0,(#1)->sm.sm_fp))") (get 'sputc 'inline-unsafe)) (push '((character object) fixnum #.(flags set rfa)"(gcl_putc(#0,(#1)->sm.sm_fp))") (get 'sputc 'inline-unsafe)) ;;READ-BYTE1 (push '((t t) t #.(flags ans set)"read_byte1(#0,#1)") (get 'read-byte1 'inline-unsafe)) ;;READ-CHAR1 (push '((t t) t #.(flags ans set)"read_char1(#0,#1)") (get 'read-char1 'inline-unsafe)) ;;SHIFT<< (push '((fixnum fixnum) fixnum #.(flags)"((#0) << (#1))") (get 'shift<< 'inline-always)) ;;SHIFT>> (push '((fixnum fixnum) fixnum #.(flags set rfa)"((#0) >> (- (#1)))") (get 'shift>> 'inline-always)) ;;SHORT-FLOAT-P (push '((t) boolean #.(flags)"type_of(#0)==t_shortfloat") (get 'short-float-p 'inline-always)) ;;SIDE-EFFECTS (push '(nil t #.(flags ans set)"Ct") (get 'side-effects 'inline-always)) ;;STACK-CONS (push '((fixnum t t) t #.(flags) "(STcons#0.t=t_cons,STcons#0.m=0,STcons#0.c_car=(#1), STcons#0.c_cdr=SAFE_CDR(#2),(object)&STcons#0)") (get 'stack-cons 'inline-always)) ;;SUBLIS1 (push '((t t t) t #.(flags ans set)SUBLIS1-INLINE) (get 'sublis1 'inline-always)) ;;SYMBOL-LENGTH (push '((t) fixnum #.(flags rfa) "@0;(type_of(#0)==t_symbol ? (#0)->s.s_fillp :not_a_variable((#0)))") (get 'symbol-length 'inline-always)) ;;VECTOR-TYPE (push '((t fixnum) boolean #.(flags) "@0;(type_of(#0) == t_vector && (#0)->v.v_elttype == (#1))") (get 'vector-type 'inline-always)) ;;SYSTEM:ASET (push '((t t t) t #.(flags set)"aset1(#0,fixint(#1),#2)") (get 'system:aset 'inline-always)) (push '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)") (get 'system:aset 'inline-always)) (push '((t t t) t #.(flags set)"aset1(#0,fix(#1),#2)") (get 'system:aset 'inline-unsafe)) (push '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)") (get 'system:aset 'inline-unsafe)) (push '(((array t) fixnum t) t #.(flags set)"(#0)->v.v_self[#1]= (#2)") (get 'system:aset 'inline-unsafe)) (push '(((array string-char) fixnum character) character #.(flags rfa set)"(#0)->ust.ust_self[#1]= (#2)") (get 'system:aset 'inline-unsafe)) (push '(((array fixnum) fixnum fixnum) fixnum #.(flags set rfa)"(#0)->fixa.fixa_self[#1]= (#2)") (get 'system:aset 'inline-unsafe)) (push '(((array signed-short) fixnum fixnum) fixnum #.(flags rfa set)"((short *)(#0)->ust.ust_self)[#1]=(#2)") (get 'system:aset 'inline-unsafe)) (push '(((array signed-char) fixnum fixnum) fixnum #.(flags rfa set)"((#0)->ust.ust_self)[#1]=(#2)") (get 'system:aset 'inline-unsafe)) (push '(((array unsigned-short) fixnum fixnum) fixnum #.(flags rfa set) "((unsigned short *)(#0)->ust.ust_self)[#1]=(#2)") (get 'system:aset 'inline-unsafe)) (push '(((array unsigned-char) fixnum fixnum) fixnum #.(flags rfa set)"((#0)->ust.ust_self)[#1]=(#2)") (get 'system:aset 'inline-unsafe)) (push '(((array short-float) fixnum short-float) short-float #.(flags rfa set)"(#0)->sfa.sfa_self[#1]= (#2)") (get 'system:aset 'inline-unsafe)) (push '(((array long-float) fixnum long-float) long-float #.(flags rfa set)"(#0)->lfa.lfa_self[#1]= (#2)") (get 'system:aset 'inline-unsafe)) (push '((t t t t) t #.(flags set) "@0;aset(#0,fix(#1)*(#0)->a.a_dims[1]+fix(#2),#3)") (get 'system:aset 'inline-unsafe)) (push '(((array t) fixnum fixnum t) t #.(flags set) "@0;(#0)->a.a_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") (get 'system:aset 'inline-unsafe)) (push '(((array string-char) fixnum fixnum character) character #.(flags rfa set) "@0;(#0)->ust.ust_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") (get 'system:aset 'inline-unsafe)) (push '(((array fixnum) fixnum fixnum fixnum) fixnum #.(flags set rfa) "@0;(#0)->fixa.fixa_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") (get 'system:aset 'inline-unsafe)) (push '(((array short-float) fixnum fixnum short-float) short-float #.(flags rfa set) "@0;(#0)->sfa.sfa_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") (get 'system:aset 'inline-unsafe)) (push '(((array long-float) fixnum fixnum long-float) long-float #.(flags rfa set) "@0;(#0)->lfa.lfa_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") (get 'system:aset 'inline-unsafe)) ;;SYSTEM:CHAR-SET (push '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)") (get 'system:char-set 'inline-always)) (push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)") (get 'system:char-set 'inline-always)) (push '((t t t) t #.(flags set) "@2;((#0)->ust.ust_self[fix(#1)]=char_code(#2),(#2))") (get 'system:char-set 'inline-unsafe)) (push '((t fixnum character) character #.(flags rfa set)"(#0)->ust.ust_self[#1]= (#2)") (get 'system:char-set 'inline-unsafe)) ;;SYSTEM:ELT-SET (push '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)") (get 'system:elt-set 'inline-always)) (push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)") (get 'system:elt-set 'inline-always)) (push '((t t t) t #.(flags set)"elt_set(#0,fix(#1),#2)") (get 'system:elt-set 'inline-unsafe)) (push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)") (get 'system:elt-set 'inline-unsafe)) ;;SYSTEM:FILL-POINTER-SET (push '((t fixnum) fixnum #.(flags rfa set)"((#0)->st.st_fillp)=(#1)") (get 'system:fill-pointer-set 'inline-unsafe)) ;;SYSTEM:FIXNUMP (push '((t) boolean #.(flags)"type_of(#0)==t_fixnum") (get 'system:fixnump 'inline-always)) (push '((fixnum) boolean #.(flags)"1") (get 'system:fixnump 'inline-always)) ;;SYSTEM:HASH-SET (push '((t t t) t #.(flags rfa) "@2;(sethash(#0,#1,#2),#2)") (get 'si::hash-set 'inline-unsafe)) (push '((t t t) t #.(flags rfa) "@2;(sethash_with_check(#0,#1,#2),#2)") (get 'si::hash-set 'inline-always)) ;;SYSTEM:MV-REF (push '((fixnum) t #.(flags ans set)"(MVloc[(#0)])") (get 'system:mv-ref 'inline-always)) ;;SYSTEM:PUTPROP (push '((t t t) t #.(flags set)"putprop(#0,#1,#2)") (get 'system:putprop 'inline-always)) ;;SYSTEM:SCHAR-SET (push '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)") (get 'system:schar-set 'inline-always)) (push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)") (get 'system:schar-set 'inline-always)) (push '((t t t) t #.(flags set) "@2;((#0)->ust.ust_self[fix(#1)]=char_code(#2),(#2))") (get 'system:schar-set 'inline-unsafe)) (push '((t fixnum character) character #.(flags set rfa)"(#0)->ust.ust_self[#1]= (#2)") (get 'system:schar-set 'inline-unsafe)) ;;SYSTEM:SET-MV (push '((fixnum t) t #.(flags ans set)"(MVloc[(#0)]=(#1))") (get 'system:set-mv 'inline-always)) ;;SYSTEM:SPUTPROP (push '((t t t) t #.(flags set)"sputprop(#0,#1,#2)") (get 'system:sputprop 'inline-always)) ;;SYSTEM:STRUCTURE-DEF (push '((t) t #.(flags)"(#0)->str.str_def") (get 'system:structure-def 'inline-unsafe)) ;;SYSTEM:STRUCTURE-LENGTH (push '((t) fixnum #.(flags rfa)"S_DATA(#0)->length") (get 'system:structure-length 'inline-unsafe)) ;;SYSTEM:STRUCTURE-REF (push '((t t fixnum) t #.(flags ans)"structure_ref(#0,#1,#2)") (get 'system:structure-ref 'inline-always)) ;;SYSTEM:STRUCTURE-SET (push '((t t fixnum t) t #.(flags set)"structure_set(#0,#1,#2,#3)") (get 'system:structure-set 'inline-always)) ;;SYSTEM:STRUCTUREP (push '((t) boolean #.(flags)"type_of(#0)==t_structure") (get 'system:structurep 'inline-always)) ;;SYSTEM:gethash1 (push '((t t) t #.(flags)"({struct htent *e=gethash(#0,#1);e->hte_key != OBJNULL ? e->hte_value : Cnil;})") (get 'system:gethash1 'inline-always)) ;;SYSTEM:SVSET (push '((t t t) t #.(flags set)"aset1(#0,fixint(#1),#2)") (get 'system:svset 'inline-always)) (push '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)") (get 'system:svset 'inline-always)) (push '((t t t) t #.(flags set)"((#0)->v.v_self[fix(#1)]=(#2))") (get 'system:svset 'inline-unsafe)) (push '((t fixnum t) t #.(flags set)"(#0)->v.v_self[#1]= (#2)") (get 'system:svset 'inline-unsafe)) ;;* (push '((t t) t #.(flags ans) "immnum_times(#0,#1)");"number_times(#0,#1)" (get '* 'inline-always)) (push '((fixnum-float fixnum-float) short-float #.(flags)"(double)(#0)*(double)(#1)") (get '* 'inline-always)) (push '((fixnum-float fixnum-float) long-float #.(flags)"(double)(#0)*(double)(#1)") (get '* 'inline-always)) (push '((long-float long-float) long-float #.(flags rfa)"(double)(#0)*(double)(#1)") (get '* 'inline-always)) (push '((short-float short-float) short-float #.(flags rfa)"(#0)*(#1)") (get '* 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags)"(#0)*(#1)") (get '* 'inline-always)) ;;+ ;; (push '((t t) t #.(flags ans)"number_plus(#0,#1)") ;; (get '+ 'inline-always)) (push '((t t) t #.(flags ans)"immnum_plus(#0,#1)") (get '+ 'inline-always)) (push '((fixnum-float fixnum-float) short-float #.(flags)"(double)(#0)+(double)(#1)") (get '+ 'inline-always)) (push '((fixnum-float fixnum-float) long-float #.(flags)"(double)(#0)+(double)(#1)") (get '+ 'inline-always)) (push '((long-float long-float) long-float #.(flags rfa)"(double)(#0)+(double)(#1)") (get '+ 'inline-always)) (push '((short-float short-float) short-float #.(flags rfa)"(#0)+(#1)") (get '+ 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags)"(#0)+(#1)") (get '+ 'inline-always)) ;;- ;; (push '((t) t #.(flags ans)"number_negate(#0)") ;; (get '- 'inline-always)) (push '((t) t #.(flags ans)"immnum_negate(#0)") (get '- 'inline-always)) (push '((t t) t #.(flags ans)"immnum_minus(#0,#1)") (get '- 'inline-always)) ;; (push '((t t) t #.(flags ans)"number_minus(#0,#1)") ;; (get '- 'inline-always)) (push '((fixnum-float fixnum-float) short-float #.(flags)"(double)(#0)-(double)(#1)") (get '- 'inline-always)) (push '((fixnum-float) short-float #.(flags)"-(double)(#0)") (get '- 'inline-always)) (push '((fixnum-float) long-float #.(flags)"-(double)(#0)") (get '- 'inline-always)) (push '((fixnum-float fixnum-float) long-float #.(flags)"(double)(#0)-(double)(#1)") (get '- 'inline-always)) (push '((long-float long-float) long-float #.(flags rfa)"(double)(#0)-(double)(#1)") (get '- 'inline-always)) (push '((short-float short-float) short-float #.(flags rfa)"(#0)-(#1)") (get '- 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags)"(#0)-(#1)") (get '- 'inline-always)) (push '((fixnum) fixnum #.(flags)"-(#0)") (get '- 'inline-always)) ;;/ (push '((fixnum fixnum) fixnum #.(flags)"(#0)/(#1)") (get '/ 'inline-always)) (push '((fixnum-float fixnum-float) short-float #.(flags)"(double)(#0)/(double)(#1)") (get '/ 'inline-always)) (push '((fixnum-float fixnum-float) long-float #.(flags)"(double)(#0)/(double)(#1)") (get '/ 'inline-always)) (push '((long-float long-float) long-float #.(flags rfa)"(double)(#0)/(double)(#1)") (get '/ 'inline-always)) (push '((short-float short-float) short-float #.(flags rfa)"(#0)/(#1)") (get '/ 'inline-always)) ;;/= (push '((t t) boolean #.(flags rfa)"immnum_ne(#0,#1)") (get '/= 'inline-always)) ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)!=0") ;; (get '/= 'inline-always)) (push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)!=(#1)") (get '/= 'inline-always)) ;;1+ ;; (push '((t) t #.(flags ans)"one_plus(#0)") ;; (get '1+ 'inline-always)) (push '((t) t #.(flags ans)"immnum_plus(#0,make_fixnum(1))") (get '1+ 'inline-always)) (push '((fixnum-float) short-float #.(flags)"(double)(#0)+1") (get '1+ 'inline-always)) (push '((fixnum-float) long-float #.(flags)"(double)(#0)+1") (get '1+ 'inline-always)) (push '((fixnum) fixnum #.(flags)"(#0)+1") (get '1+ 'inline-always)) ;;1- ;; (push '((t) t #.(flags ans)"one_minus(#0)") ;; (get '1- 'inline-always)) (push '((t) t #.(flags ans)"immnum_plus(#0,make_fixnum(-1))") (get '1- 'inline-always)) (push '((fixnum) fixnum #.(flags)"(#0)-1") (get '1- 'inline-always)) (push '((fixnum-float) short-float #.(flags)"(double)(#0)-1") (get '1- 'inline-always)) (push '((fixnum-float) long-float #.(flags)"(double)(#0)-1") (get '1- 'inline-always)) ;;< (push '((t t) boolean #.(flags rfa)"immnum_lt(#0,#1)") (get '< 'inline-always)) ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)<0") ;; (get '< 'inline-always)) (push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)<(#1)") (get '< 'inline-always)) ;;compiler::objlt (push '((t t) boolean #.(flags)"((object)(#0))<((object)(#1))") (get 'si::objlt 'inline-always)) ;;<= (push '((t t) boolean #.(flags rfa)"immnum_le(#0,#1)") (get '<= 'inline-always)) ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)<=0") ;; (get '<= 'inline-always)) (push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)<=(#1)") (get '<= 'inline-always)) ;;= (push '((t t) boolean #.(flags rfa)"immnum_eq(#0,#1)") (get '= 'inline-always)) ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)==0") ;; (get '= 'inline-always)) (push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)==(#1)") (get '= 'inline-always)) ;;> (push '((t t) boolean #.(flags rfa)"immnum_gt(#0,#1)") (get '> 'inline-always)) ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)>0") ;; (get '> 'inline-always)) (push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)>(#1)") (get '> 'inline-always)) ;;>= (push '((t t) boolean #.(flags rfa)"immnum_ge(#0,#1)") (get '>= 'inline-always)) ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)>=0") ;; (get '>= 'inline-always)) (push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)>=(#1)") (get '>= 'inline-always)) ;;APPEND (push '((t t) t #.(flags ans)"append(#0,#1)") (get 'append 'inline-always)) ;;AREF (push '((t t) t #.(flags ans)"fLrow_major_aref(#0,fixint(#1))") (get 'aref 'inline-always)) (push '((t fixnum) t #.(flags ans)"fLrow_major_aref(#0,#1)") (get 'aref 'inline-always)) (push '((t t) t #.(flags ans)"fLrow_major_aref(#0,fix(#1))") (get 'aref 'inline-unsafe)) (push '((t fixnum) t #.(flags ans)"fLrow_major_aref(#0,#1)") (get 'aref 'inline-unsafe)) (push '(((array t) fixnum) t #.(flags)"(#0)->v.v_self[#1]") (get 'aref 'inline-unsafe)) (push '(((array string-char) fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]") (get 'aref 'inline-unsafe)) (push '(((array fixnum) fixnum) fixnum #.(flags rfa)"(#0)->fixa.fixa_self[#1]") (get 'aref 'inline-unsafe)) (push '(((array unsigned-char) fixnum) fixnum #.(flags rfa)"(#0)->ust.ust_self[#1]") (get 'aref 'inline-unsafe)) (push '(((array signed-char) fixnum) fixnum #.(flags rfa)"SIGNED_CHAR((#0)->ust.ust_self[#1])") (get 'aref 'inline-unsafe)) (push '(((array unsigned-short) fixnum) fixnum #.(flags rfa) "((unsigned short *)(#0)->ust.ust_self)[#1]") (get 'aref 'inline-unsafe)) (push '(((array signed-short) fixnum) fixnum #.(flags rfa)"((short *)(#0)->ust.ust_self)[#1]") (get 'aref 'inline-unsafe)) (push '(((array short-float) fixnum) short-float #.(flags rfa)"(#0)->sfa.sfa_self[#1]") (get 'aref 'inline-unsafe)) (push '(((array long-float) fixnum) long-float #.(flags rfa)"(#0)->lfa.lfa_self[#1]") (get 'aref 'inline-unsafe)) ;; (push '((t t t) t #.(flags ans) ;; "@0;aref(#0,fix(#1)*(#0)->a.a_dims[1]+fix(#2))") ;; (get 'aref 'inline-unsafe)) (push '(((array t) fixnum fixnum) t #.(flags ) "@0;(#0)->a.a_self[(#1)*(#0)->a.a_dims[1]+#2]") (get 'aref 'inline-unsafe)) (push '(((array string-char) fixnum fixnum) character #.(flags rfa) "@0;(#0)->ust.ust_self[(#1)*(#0)->a.a_dims[1]+#2]") (get 'aref 'inline-unsafe)) (push '(((array fixnum) fixnum fixnum) fixnum #.(flags rfa) "@0;(#0)->fixa.fixa_self[(#1)*(#0)->a.a_dims[1]+#2]") (get 'aref 'inline-unsafe)) (push '(((array short-float) fixnum fixnum) short-float #.(flags rfa) "@0;(#0)->sfa.sfa_self[(#1)*(#0)->a.a_dims[1]+#2]") (get 'aref 'inline-unsafe)) (push '(((array long-float) fixnum fixnum) long-float #.(flags rfa) "@0;(#0)->lfa.lfa_self[(#1)*(#0)->a.a_dims[1]+#2]") (get 'aref 'inline-unsafe)) ;;ARRAY-TOTAL-SIZE (push '((t) fixnum #.(flags rfa)"((#0)->st.st_dim)") (get 'array-total-size 'inline-unsafe)) ;;ARRAYP (push '((t) boolean #.(flags) "@0;type_of(#0)==t_array|| type_of(#0)==t_vector|| type_of(#0)==t_string|| type_of(#0)==t_bitvector") (get 'arrayp 'inline-always)) ;;ATOM (push '((t) boolean #.(flags)"type_of(#0)!=t_cons") (get 'atom 'inline-always)) ;;BIT-VECTOR-P (push '((t) boolean #.(flags)"(type_of(#0)==t_bitvector)") (get 'bit-vector-p 'inline-always)) ;;BOUNDP (push '((t) boolean #.(flags)"(#0)->s.s_dbind!=OBJNULL") (get 'boundp 'inline-unsafe)) ;;CAAAAR (push '((t) t #.(flags)"caaaar(#0)") (get 'caaaar 'inline-safe)) (push '((t) t #.(flags)"CMPcaaaar(#0)") (get 'caaaar 'inline-unsafe)) ;;CAAADR (push '((t) t #.(flags)"caaadr(#0)") (get 'caaadr 'inline-safe)) (push '((t) t #.(flags)"CMPcaaadr(#0)") (get 'caaadr 'inline-unsafe)) ;;CAAAR (push '((t) t #.(flags)"caaar(#0)") (get 'caaar 'inline-safe)) (push '((t) t #.(flags)"CMPcaaar(#0)") (get 'caaar 'inline-unsafe)) ;;CAADAR (push '((t) t #.(flags)"caadar(#0)") (get 'caadar 'inline-safe)) (push '((t) t #.(flags)"CMPcaadar(#0)") (get 'caadar 'inline-unsafe)) ;;CAADDR (push '((t) t #.(flags)"caaddr(#0)") (get 'caaddr 'inline-safe)) (push '((t) t #.(flags)"CMPcaaddr(#0)") (get 'caaddr 'inline-unsafe)) ;;CAADR (push '((t) t #.(flags)"caadr(#0)") (get 'caadr 'inline-safe)) (push '((t) t #.(flags)"CMPcaadr(#0)") (get 'caadr 'inline-unsafe)) ;;CAAR (push '((t) t #.(flags)"caar(#0)") (get 'caar 'inline-safe)) (push '((t) t #.(flags)"CMPcaar(#0)") (get 'caar 'inline-unsafe)) ;;CADAAR (push '((t) t #.(flags)"cadaar(#0)") (get 'cadaar 'inline-safe)) (push '((t) t #.(flags)"CMPcadaar(#0)") (get 'cadaar 'inline-unsafe)) ;;CADADR (push '((t) t #.(flags)"cadadr(#0)") (get 'cadadr 'inline-safe)) (push '((t) t #.(flags)"CMPcadadr(#0)") (get 'cadadr 'inline-unsafe)) ;;CADAR (push '((t) t #.(flags)"cadar(#0)") (get 'cadar 'inline-safe)) (push '((t) t #.(flags)"CMPcadar(#0)") (get 'cadar 'inline-unsafe)) ;;CADDAR (push '((t) t #.(flags)"caddar(#0)") (get 'caddar 'inline-safe)) (push '((t) t #.(flags)"CMPcaddar(#0)") (get 'caddar 'inline-unsafe)) ;;CADDDR (push '((t) t #.(flags)"cadddr(#0)") (get 'cadddr 'inline-safe)) (push '((t) t #.(flags)"CMPcadddr(#0)") (get 'cadddr 'inline-unsafe)) ;;CADDR (push '((t) t #.(flags)"caddr(#0)") (get 'caddr 'inline-safe)) (push '((t) t #.(flags)"CMPcaddr(#0)") (get 'caddr 'inline-unsafe)) ;;CADR (push '((t) t #.(flags)"cadr(#0)") (get 'cadr 'inline-safe)) (push '((t) t #.(flags)"CMPcadr(#0)") (get 'cadr 'inline-unsafe)) ;;CAR (push '((t) t #.(flags)"car(#0)") (get 'car 'inline-safe)) (push '((t) t #.(flags)"CMPcar(#0)") (get 'car 'inline-unsafe)) ;;CDAAAR (push '((t) t #.(flags)"cdaaar(#0)") (get 'cdaaar 'inline-safe)) (push '((t) t #.(flags)"CMPcdaaar(#0)") (get 'cdaaar 'inline-unsafe)) ;;CDAADR (push '((t) t #.(flags)"cdaadr(#0)") (get 'cdaadr 'inline-safe)) (push '((t) t #.(flags)"CMPcdaadr(#0)") (get 'cdaadr 'inline-unsafe)) ;;CDAAR (push '((t) t #.(flags)"cdaar(#0)") (get 'cdaar 'inline-safe)) (push '((t) t #.(flags)"CMPcdaar(#0)") (get 'cdaar 'inline-unsafe)) ;;CDADAR (push '((t) t #.(flags)"cdadar(#0)") (get 'cdadar 'inline-safe)) (push '((t) t #.(flags)"CMPcdadar(#0)") (get 'cdadar 'inline-unsafe)) ;;CDADDR (push '((t) t #.(flags)"cdaddr(#0)") (get 'cdaddr 'inline-safe)) (push '((t) t #.(flags)"CMPcdaddr(#0)") (get 'cdaddr 'inline-unsafe)) ;;CDADR (push '((t) t #.(flags)"cdadr(#0)") (get 'cdadr 'inline-safe)) (push '((t) t #.(flags)"CMPcdadr(#0)") (get 'cdadr 'inline-unsafe)) ;;CDAR (push '((t) t #.(flags)"cdar(#0)") (get 'cdar 'inline-safe)) (push '((t) t #.(flags)"CMPcdar(#0)") (get 'cdar 'inline-unsafe)) ;;CDDAAR (push '((t) t #.(flags)"cddaar(#0)") (get 'cddaar 'inline-safe)) (push '((t) t #.(flags)"CMPcddaar(#0)") (get 'cddaar 'inline-unsafe)) ;;CDDADR (push '((t) t #.(flags)"cddadr(#0)") (get 'cddadr 'inline-safe)) (push '((t) t #.(flags)"CMPcddadr(#0)") (get 'cddadr 'inline-unsafe)) ;;CDDAR (push '((t) t #.(flags)"cddar(#0)") (get 'cddar 'inline-safe)) (push '((t) t #.(flags)"CMPcddar(#0)") (get 'cddar 'inline-unsafe)) ;;CDDDAR (push '((t) t #.(flags)"cdddar(#0)") (get 'cdddar 'inline-safe)) (push '((t) t #.(flags)"CMPcdddar(#0)") (get 'cdddar 'inline-unsafe)) ;;CDDDDR (push '((t) t #.(flags)"cddddr(#0)") (get 'cddddr 'inline-safe)) (push '((t) t #.(flags)"CMPcddddr(#0)") (get 'cddddr 'inline-unsafe)) ;;CDDDR (push '((t) t #.(flags)"cdddr(#0)") (get 'cdddr 'inline-safe)) (push '((t) t #.(flags)"CMPcdddr(#0)") (get 'cdddr 'inline-unsafe)) ;;CDDR (push '((t) t #.(flags)"cddr(#0)") (get 'cddr 'inline-safe)) (push '((t) t #.(flags)"CMPcddr(#0)") (get 'cddr 'inline-unsafe)) ;;CDR (push '((t) t #.(flags)"cdr(#0)") (get 'cdr 'inline-safe)) (push '((t) t #.(flags)"CMPcdr(#0)") (get 'cdr 'inline-unsafe)) ;;CHAR (push '((t t) t #.(flags ans)"elt(#0,fixint(#1))") (get 'char 'inline-always)) (push '((t fixnum) t #.(flags ans)"elt(#0,#1)") (get 'char 'inline-always)) (push '((t t) t #.(flags)"code_char((#0)->ust.ust_self[fix(#1)])") (get 'char 'inline-unsafe)) (push '((t fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]") (get 'char 'inline-unsafe)) ;;CHAR-CODE (push '((character) fixnum #.(flags rfa)"(#0)") (get 'char-code 'inline-always)) ;;CHAR/= (push '((character character) boolean #.(flags)"(#0)!=(#1)") (get 'char/= 'inline-always)) (push '((t t) boolean #.(flags)"!eql(#0,#1)") (get 'char/= 'inline-unsafe)) (push '((t t) boolean #.(flags)"char_code(#0)!=char_code(#1)") (get 'char/= 'inline-unsafe)) ;;CHAR< (push '((character character) boolean #.(flags)"(#0)<(#1)") (get 'char< 'inline-always)) ;;CHAR<= (push '((character character) boolean #.(flags)"(#0)<=(#1)") (get 'char<= 'inline-always)) ;;CHAR= (push '((t t) boolean #.(flags)"eql(#0,#1)") (get 'char= 'inline-unsafe)) (push '((t t) boolean #.(flags)"char_code(#0)==char_code(#1)") (get 'char= 'inline-unsafe)) (push '((character character) boolean #.(flags)"(#0)==(#1)") (get 'char= 'inline-unsafe)) ;;CHAR> (push '((character character) boolean #.(flags)"(#0)>(#1)") (get 'char> 'inline-always)) ;;CHAR>= (push '((character character) boolean #.(flags)"(#0)>=(#1)") (get 'char>= 'inline-always)) ;;CHARACTERP (push '((t) boolean #.(flags)"type_of(#0)==t_character") (get 'characterp 'inline-always)) ;;CODE-CHAR (push '((fixnum) character #.(flags)"(#0)") (get 'code-char 'inline-always)) ;;CONS (push '((t t) t #.(flags ans)"make_cons(#0,#1)") (get 'cons 'inline-always)) (push '((t t) :dynamic-extent #.(flags ans)"ON_STACK_CONS(#0,#1)") (get 'cons 'inline-always)) ;;CONSP (push '((t) boolean #.(flags)"type_of(#0)==t_cons") (get 'consp 'inline-always)) ;;COS (push '((long-float) long-float #.(flags rfa)"cos(#0)") (get 'cos 'inline-always)) ;;DIGIT-CHAR-P (push '((character) boolean #.(flags)"@0; ((#0) <= '9' && (#0) >= '0')") (get 'digit-char-p 'inline-always)) ;;ELT (push '((t t) t #.(flags ans)"elt(#0,fixint(#1))") (get 'elt 'inline-always)) (push '((t fixnum) t #.(flags ans)"elt(#0,#1)") (get 'elt 'inline-always)) (push '((t t) t #.(flags ans)"elt(#0,fix(#1))") (get 'elt 'inline-unsafe)) (push '((t fixnum) t #.(flags ans)"elt(#0,#1)") (get 'elt 'inline-unsafe)) ;;ENDP ;;Must use endp_prop here as generic lisp code containing (endp ;;can be compiled to take function output as its argument, which ;;cannot be redirected via a macro, e.g. endp(cdr(V20)). CM (push '((t) boolean #.(flags)"endp_prop(#0)") (get 'endp 'inline-safe)) (push '((t) boolean #.(flags)"(#0)==Cnil") (get 'endp 'inline-unsafe)) ;;EQ (push '((t t) boolean #.(flags rfa)"(#0)==(#1)") (get 'eq 'inline-always)) (push '((fixnum fixnum) boolean #.(flags rfa)"0") (get 'eq 'inline-always)) ;;EQL (push '((t t) boolean #.(flags rfa)"eql(#0,#1)") (get 'eql 'inline-always)) (push '((fixnum fixnum) boolean #.(flags rfa)"(#0)==(#1)") (get 'eql 'inline-always)) (push '((character character) boolean #.(flags rfa)"(#0)==(#1)") (get 'eql 'inline-always)) ;;EQUAL (push '((t t) boolean #.(flags rfa)"equal(#0,#1)") (get 'equal 'inline-always)) (push '((fixnum fixnum) boolean #.(flags rfa)"(#0)==(#1)") (get 'equal 'inline-always)) ;;EQUALP (push '((t t) boolean #.(flags rfa)"equalp(#0,#1)") (get 'equalp 'inline-always)) (push '((fixnum fixnum) boolean #.(flags rfa)"(#0)==(#1)") (get 'equalp 'inline-always)) ;;EXPT (push '((t t) t #.(flags ans)"number_expt(#0,#1)") (get 'expt 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags)(LAMBDA (LOC1 LOC2) (IF (AND (CONSP LOC1) (EQ (CAR LOC1) 'FIXNUM-LOC) (CONSP (CADR LOC1)) (EQ (CAADR LOC1) 'FIXNUM-VALUE) (EQUAL (CADDR (CADR LOC1)) 2)) (WT "(1<<(" LOC2 "))") (WT "fixnum_expt(" LOC1 #\, LOC2 #\))))) (get 'expt 'inline-always)) ;;FILL-POINTER (push '((t) fixnum #.(flags rfa)"((#0)->st.st_fillp)") (get 'fill-pointer 'inline-unsafe)) ;;FIRST (push '((t) t #.(flags)"car(#0)") (get 'first 'inline-safe)) (push '((t) t #.(flags)"CMPcar(#0)") (get 'first 'inline-unsafe)) ;;FLOAT (push '((fixnum-float) long-float #.(flags)"((longfloat)(#0))") (get 'float 'inline-always)) (push '((fixnum-float) short-float #.(flags)"((shortfloat)(#0))") (get 'float 'inline-always)) ;;FLOATP (push '((t) boolean #.(flags) "@0;type_of(#0)==t_shortfloat||type_of(#0)==t_longfloat") (get 'floatp 'inline-always)) ;;CEILING (push '((t t) t #.(compiler::flags) "immnum_ceiling(#0,#1)") (get 'ceiling 'compiler::inline-always)) ;;FLOOR ; (push '((fixnum fixnum) fixnum #.(flags rfa) ; "@01;(#0>=0&&(#1)>0?(#0)/(#1):ifloor(#0,#1))") ; (get 'floor 'inline-always)) (push '((t t) t #.(compiler::flags) "immnum_floor(#0,#1)") (get 'floor 'compiler::inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa) "@01;({fixnum _t=(#0)/(#1);((#1)<0 && (#0)<=0) || ((#1)>0 && (#0)>=0) || ((#1)*_t == (#0)) ? _t : _t - 1;})") (get 'floor 'inline-always)) ;;FOURTH (push '((t) t #.(flags)"cadddr(#0)") (get 'fourth 'inline-safe)) (push '((t) t #.(flags)"CMPcadddr(#0)") (get 'fourth 'inline-unsafe)) ;;GET (push '((t t t) t #.(flags)"get(#0,#1,#2)") (get 'get 'inline-always)) (push '((t t) t #.(flags)"get(#0,#1,Cnil)") (get 'get 'inline-always)) ;;INTEGERP (push '((t) boolean #.(flags) "@0;type_of(#0)==t_fixnum||type_of(#0)==t_bignum") (get 'integerp 'inline-always)) (push '((fixnum) boolean #.(flags) "1") (get 'integerp 'inline-always)) ;;KEYWORDP (push '((t) boolean #.(flags) "@0;(type_of(#0)==t_symbol&&(#0)->s.s_hpack==keyword_package)") (get 'keywordp 'inline-always)) ;;ADDRESS (push '((t) fixnum #.(flags rfa)"((fixnum)(#0))") (get 'si::address 'inline-always)) ;;NANI (push '((fixnum) t #.(flags rfa)"((object)(#0))") (get 'si::nani 'inline-always)) ;;LENGTH (push '((t) fixnum #.(flags rfa)"length(#0)") (get 'length 'inline-always)) (push '(((array t)) fixnum #.(flags rfa)"(#0)->v.v_fillp") (get 'length 'inline-unsafe)) (push '(((array fixnum)) fixnum #.(flags rfa)"(#0)->v.v_fillp") (get 'length 'inline-unsafe)) (push '((string) fixnum #.(flags rfa)"(#0)->v.v_fillp") (get 'length 'inline-unsafe)) ;;LIST (push '(nil t #.(flags)"Cnil") (get 'list 'inline-always)) (push '((t) t #.(flags ans)"make_cons(#0,Cnil)") (get 'list 'inline-always)) (push '((t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t t t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t t t t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) ;;LIST* (push '((t) t #.(flags)"(#0)") (get 'list* 'inline-always)) (push '((t t) t #.(flags ans)"make_cons(#0,#1)") (get 'list* 'inline-always)) (push '((t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t t t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t t t t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) ;;LISTP (push '((t) boolean #.(flags)"@0;type_of(#0)==t_cons||(#0)==Cnil") (get 'listp 'inline-always)) ;;si::spice-p (push '((t) boolean #.(flags)"@0;type_of(#0)==t_spice") (get 'si::spice-p 'inline-always)) ;;LOGNAND (push '((t t) t #.(compiler::flags) "immnum_nand(#0,#1)") (get 'lognand 'compiler::inline-always)) ;;LOGNOR (push '((t t) t #.(compiler::flags) "immnum_nor(#0,#1)") (get 'lognor 'compiler::inline-always)) ;;LOGEQV (push '((t t) t #.(compiler::flags) "immnum_eqv(#0,#1)") (get 'logeqv 'compiler::inline-always)) ;;LOGANDC1 (push '((t t) t #.(compiler::flags) "immnum_andc1(#0,#1)") (get 'logandc1 'compiler::inline-always)) ;;LOGANDC2 (push '((t t) t #.(compiler::flags) "immnum_andc2(#0,#1)") (get 'logandc2 'compiler::inline-always)) ;;LOGORC1 (push '((t t) t #.(compiler::flags) "immnum_orc1(#0,#1)") (get 'logorc1 'compiler::inline-always)) ;;LOGORC1 (push '((t t) t #.(compiler::flags) "immnum_orc2(#0,#1)") (get 'logorc2 'compiler::inline-always)) ;;LOGAND (push '((t t) t #.(flags)"immnum_and((#0),(#1))") (get 'logand 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) & (#1))") (get 'logand 'inline-always)) ;;LOGIOR (push '((t t) t #.(flags)"immnum_ior((#0),(#1))") (get 'logior 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) | (#1))") (get 'logior 'inline-always)) ;;LOGXOR (push '((t t) t #.(flags)"immnum_xor((#0),(#1))") (get 'logxor 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) ^ (#1))") (get 'logxor 'inline-always)) ;;LOGNOT (push '((t) t #.(flags)"immnum_not(#0)") (get 'lognot 'inline-always)) (push '((fixnum) fixnum #.(flags rfa)"(~(#0))") (get 'lognot 'inline-always)) ;;MAKE-LIST (push '((fixnum) :dynamic-extent #.(flags ans) "@0;(ALLOCA_CONS(#0),ON_STACK_MAKE_LIST(#0))") (get 'make-list 'inline-always)) ;;MAX (push '((t t) t #.(flags) "immnum_max(#0,#1)");"@01;(number_compare(#0,#1)>=0?(#0):#1)" (get 'max 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa)"@01;((#0)>=(#1)?(#0):#1)") (get 'max 'inline-always)) ;;MIN (push '((t t) t #.(flags) "immnum_min(#0,#1)");"@01;(number_compare(#0,#1)<=0?(#0):#1)" (get 'min 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa)"@01;((#0)<=(#1)?(#0):#1)") (get 'min 'inline-always)) ;;LDB (push '((t t) t #.(compiler::flags) "immnum_ldb(#0,#1)") (get 'ldb 'compiler::inline-always)) ;;LDB-TEST (push '((t t) boolean #.(compiler::flags) "immnum_ldbt(#0,#1)") (get 'ldb-test 'compiler::inline-always)) ;;LOGTEST (push '((t t) boolean #.(compiler::flags) "immnum_logt(#0,#1)") (get 'logtest 'compiler::inline-always)) ;;DPB (push '((t t t) t #.(compiler::flags) "immnum_dpb(#0,#1,#2)") (get 'dpb 'compiler::inline-always)) ;;DEPOSIT-FIELD (push '((t t t) t #.(compiler::flags) "immnum_dpf(#0,#1,#2)") (get 'deposit-field 'compiler::inline-always)) ;;MINUSP (push '((t) boolean #.(flags) "immnum_minusp(#0)");"number_compare(small_fixnum(0),#0)>0" (get 'minusp 'inline-always)) (push '((fixnum-float) boolean #.(flags)"(#0)<0") (get 'minusp 'inline-always)) ;;MOD ; (push '((fixnum fixnum) fixnum #.(flags rfa)"@01;(#0>=0&&(#1)>0?(#0)%(#1):imod(#0,#1))") ; (get 'mod 'inline-always)) (push '((t t) t #.(compiler::flags) "immnum_mod(#0,#1)") (get 'mod 'compiler::inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa)"@01;({fixnum _t=(#0)%(#1);((#1)<0 && _t<=0) || ((#1)>0 && _t>=0) ? _t : _t + (#1);})") (get 'mod 'inline-always)) ;;NCONC (push '((t t) t #.(flags set)"nconc(#0,#1)") (get 'nconc 'inline-always)) ;;NOT (push '((t) boolean #.(flags)"(#0)==Cnil") (get 'not 'inline-always)) ;;NREVERSE (push '((t) t #.(flags ans set)"nreverse(#0)") (get 'nreverse 'inline-always)) ;;NTH ; (push '((t t) t #.(flags)"nth(fixint(#0),#1)") ; (get 'nth 'inline-always)) ; (push '((fixnum t) t #.(flags)"nth(#0,#1)") ; (get 'nth 'inline-always)) ; (push '((t t) t #.(flags)"nth(fix(#0),#1)") ; (get 'nth 'inline-unsafe)) ;(push '((fixnum proper-list) proper-list #.(flags rfa)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x->c.c_car;})") ; (get 'nth 'inline-always)) ;(push '(((and (integer 0) (not fixnum)) proper-list) null #.(flags rfa)"Cnil") ; (get 'nth 'inline-always)) (push '((fixnum t) t #.(flags)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x->c.c_car;})") (get 'nth 'inline-unsafe)) ;(push '(((not fixnum) proper-list) null #.(flags rfa)"Cnil") ; (get 'nth 'inline-unsafe)) ;;NTHCDR ; (push '((t t) t #.(flags)"nthcdr(fixint(#0),#1)") ; (get 'nthcdr 'inline-always)) ; (push '((fixnum t) t #.(flags)"nthcdr(#0,#1)") ; (get 'nthcdr 'inline-always)) ; (push '((t t) t #.(flags)"nthcdr(fix(#0),#1)") ; (get 'nthcdr 'inline-unsafe)) ;(push '((fixnum proper-list) proper-list #.(flags rfa)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})") ; (get 'nthcdr 'inline-always)) ;(push '(((and (integer 0) (not fixnum)) proper-list) null #.(flags rfa)"Cnil") ; (get 'nthcdr 'inline-always)) (push '((fixnum t) t #.(flags)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})") (get 'nthcdr 'inline-unsafe)) ;(push '(((not fixnum) proper-list) null #.(flags rfa)"Cnil") ; (get 'nthcdr 'inline-unsafe)) ;;NULL (push '((t) boolean #.(flags)"(#0)==Cnil") (get 'null 'inline-always)) ;;NUMBERP (push '((t) boolean #.(flags) "@0;type_of(#0)==t_fixnum|| type_of(#0)==t_bignum|| type_of(#0)==t_ratio|| type_of(#0)==t_shortfloat|| type_of(#0)==t_longfloat|| type_of(#0)==t_complex") (get 'numberp 'inline-always)) ;;PLUSP (push '((t) boolean #.(flags) "immnum_plusp(#0)");"number_compare(small_fixnum(0),#0)<0" (get 'plusp 'inline-always)) (push '((fixnum-float) boolean #.(flags)"(#0)>0") (get 'plusp 'inline-always)) ;;PRIN1 (push '((t t) t #.(flags set)"prin1(#0,#1)") (get 'prin1 'inline-always)) (push '((t) t #.(flags set)"prin1(#0,Cnil)") (get 'prin1 'inline-always)) ;;PRINC (push '((t t) t #.(flags set)"princ(#0,#1)") (get 'princ 'inline-always)) (push '((t) t #.(flags set)"princ(#0,Cnil)") (get 'princ 'inline-always)) ;;PRINT (push '((t t) t #.(flags set)"print(#0,#1)") (get 'print 'inline-always)) (push '((t) t #.(flags set)"print(#0,Cnil)") (get 'print 'inline-always)) ;;PROBE-FILE (push '((t) boolean #.(flags)"(file_exists(#0))") (get 'probe-file 'inline-always)) ;;RATIOP (push '((t) boolean #.(flags) "type_of(#0)==t_ratio") (get 'ratiop 'inline-always)) ;;REM (push '((t t) t #.(compiler::flags) "immnum_rem(#0,#1)") (get 'rem 'compiler::inline-always)) #+TRUNCATE_USE_C (push '((fixnum fixnum) fixnum #.(flags rfa)"(#0)%(#1)") (get 'rem 'inline-always)) ;;REMPROP (push '((t t) t #.(flags set)"remprop(#0,#1)") (get 'remprop 'inline-always)) ;;REST (push '((t) t #.(flags)"cdr(#0)") (get 'rest 'inline-safe)) (push '((t) t #.(flags)"CMPcdr(#0)") (get 'rest 'inline-unsafe)) ;;REVERSE (push '((t) t #.(flags ans)"reverse(#0)") (get 'reverse 'inline-always)) ;;SCHAR (push '((t t) t #.(flags ans)"elt(#0,fixint(#1))") (get 'schar 'inline-always)) (push '((t fixnum) t #.(flags ans)"elt(#0,#1)") (get 'schar 'inline-always)) (push '((t t) t #.(flags rfa)"code_char((#0)->ust.ust_self[fix(#1)])") (get 'schar 'inline-unsafe)) (push '((t fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]") (get 'schar 'inline-unsafe)) ;;SECOND (push '((t) t #.(flags)"cadr(#0)") (get 'second 'inline-safe)) (push '((t) t #.(flags)"CMPcadr(#0)") (get 'second 'inline-unsafe)) ;;SIN (push '((long-float) long-float #.(flags rfa)"sin(#0)") (get 'sin 'inline-always)) ;;STRING (push '((t) t #.(flags ans)"coerce_to_string(#0)") (get 'string 'inline-always)) ;;STRINGP (push '((t) boolean #.(flags)"type_of(#0)==t_string") (get 'stringp 'inline-always)) ;;SVREF ;; (push '((t t) t #.(flags ans)"aref1(#0,fixint(#1))") ;; (get 'svref 'inline-always)) ;; (push '((t fixnum) t #.(flags ans)"aref1(#0,#1)") ;; (get 'svref 'inline-always)) (push '((t t) t #.(flags)"(#0)->v.v_self[fix(#1)]") (get 'svref 'inline-unsafe)) (push '((t fixnum) t #.(flags)"(#0)->v.v_self[#1]") (get 'svref 'inline-unsafe)) ;;SYMBOL-NAME (push '((t) t #.(flags ans)"symbol_name(#0)") (get 'symbol-name 'inline-always)) ;;SYMBOL-PLIST (push (list '(t) t #.(flags) "((#0)->s.s_plist)") (get 'symbol-plist 'inline-unsafe)) ;;SYMBOLP (push '((t) boolean #.(flags)"type_of(#0)==t_symbol") (get 'symbolp 'inline-always)) ;;TAN (push '((long-float) long-float #.(flags rfa)"tan(#0)") (get 'tan 'inline-always)) ;;SQRT (push '((long-float) long-float #.(flags rfa)"sqrt((double)#0)") (get 'sqrt 'inline-always)) ;;TERPRI (push '((t) t #.(flags set)"terpri(#0)") (get 'terpri 'inline-always)) (push '(nil t #.(flags set)"terpri(Cnil)") (get 'terpri 'inline-always)) ;;THIRD (push '((t) t #.(flags)"caddr(#0)") (get 'third 'inline-safe)) (push '((t) t #.(flags)"CMPcaddr(#0)") (get 'third 'inline-unsafe)) ;;TRUNCATE (push '((t t) t #.(compiler::flags) "immnum_truncate(#0,#1)") (get 'truncate 'compiler::inline-always)) #+TRUNCATE_USE_C (push '((fixnum fixnum) fixnum #.(flags rfa)"(#0)/(#1)") (get 'truncate 'inline-always)) (push '((fixnum-float) fixnum #.(flags)"(fixnum)(#0)") (get 'truncate 'inline-always)) ;;VECTORP (push '((t) boolean #.(flags) "@0;type_of(#0)==t_vector|| type_of(#0)==t_string|| type_of(#0)==t_bitvector") (get 'vectorp 'inline-always)) ;;WRITE-CHAR (push '((t) t #.(flags set) "@0;(writec_stream(char_code(#0),Vstandard_output->s.s_dbind),(#0))") (get 'write-char 'inline-unsafe)) ;;EVENP (push '((t) boolean #.(compiler::flags) "immnum_evenp(#0)") (get 'evenp 'compiler::inline-always)) ;;ODDP (push '((t) boolean #.(compiler::flags) "immnum_oddp(#0)") (get 'oddp 'compiler::inline-always)) ;;SIGNUM (push '((t) t #.(compiler::flags) "immnum_signum(#0)") (get 'signum 'compiler::inline-always)) ;;ZEROP (push '((t) boolean #.(flags) "immnum_zerop(#0)");"number_compare(small_fixnum(0),#0)==0" (get 'zerop 'inline-always)) (push '((fixnum-float) boolean #.(flags)"(#0)==0") (get 'zerop 'inline-always)) ;;CMOD (push '((t) t #.(flags) "cmod(#0)") (get 'system:cmod 'inline-always)) ;;CTIMES (push '((t t) t #.(flags) "ctimes(#0,#1)") (get 'system:ctimes 'inline-always)) ;;CPLUS (push '((t t) t #.(flags) "cplus(#0,#1)") (get 'system:cplus 'inline-always)) ;;CDIFFERENCE (push '((t t) t #.(flags) "cdifference(#0,#1)") (get 'system:cdifference 'inline-always)) ;;si::static-inverse-cons (push '((t) t #.(compiler::flags) "({object _y=(object)fixint(#0);is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-always)) (push '((fixnum) t #.(compiler::flags) "({object _y=(object)#0;is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-always)) (push '((t) t #.(compiler::flags) "({object _y=(object)fix(#0);is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-unsafe)) (push '((fixnum) t #.(compiler::flags) "({object _y=(object)#0;is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-unsafe)) ;;symbol-value (push '((t) t #.(compiler::flags) "(#0)->s.s_dbind") (get 'symbol-value 'compiler::inline-unsafe)) (push '((t) t #.(compiler::flags) "@0;type_of(#0)!=t_symbol ? (not_a_symbol(#0),Cnil) : ((#0)->s.s_dbind==OBJNULL ? (FEerror(\"unbound variable\",0),Cnil) : (#0)->s.s_dbind)") (get 'symbol-value 'compiler::inline-always)) (push '((symbol) t #.(compiler::flags) "@0;(#0)->s.s_dbind==OBJNULL ? (FEerror(\"unbound variable\",0),Cnil) : (#0)->s.s_dbind") (get 'symbol-value 'compiler::inline-always)) ;;acons (push '((t t t) t #.(compiler::flags) "MMcons(MMcons((#0),(#1)),(#2))") (get 'acons 'compiler::inline-always)) gcl/cmpnew/gcl_cmpspecial.lsp000077500000000000000000000135571242227143400166200ustar00rootroot00000000000000;;; CMPSPECIAL Miscellaneous special forms. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (si:putprop 'quote 'c1quote 'c1special) (si:putprop 'function 'c1function 'c1special) (si:putprop 'function 'c2function 'c2) (si:putprop 'the 'c1the 'c1special) (si:putprop 'eval-when 'c1eval-when 'c1special) (si:putprop 'declare 'c1declare 'c1special) (si:putprop 'compiler-let 'c1compiler-let 'c1special) (si:putprop 'compiler-let 'c2compiler-let 'c2) (defun c1quote (args) (when (endp args) (too-few-args 'quote 1 0)) (unless (endp (cdr args)) (too-many-args 'quote 1 (length args))) (c1constant-value (car args) t) ) (defun c1eval-when (args) (when (endp args) (too-few-args 'eval-when 1 0)) (dolist** (situation (car args) (c1nil)) (case situation (eval (return-from c1eval-when (c1progn (cdr args)))) ((load compile)) (otherwise (cmperr "The situation ~s is illegal." situation)))) ) (defun c1declare (args) (cmperr "The declaration ~s was found in a bad place." (cons 'declare args)) ) (defun c1the (args &aux info form type) (when (or (endp args) (endp (cdr args))) (too-few-args 'the 2 (length args))) (unless (endp (cddr args)) (too-many-args 'the 2 (length args))) (setq form (c1expr (cadr args))) (setq info (copy-info (cadr form))) (setq type (type-and (type-filter (car args)) (info-type info))) (when (null type) (when (and (type>= 'boolean (type-filter (car args))) (type>= (type-filter (car args)) 'boolean)) (return-from c1the (c1the (list 'boolean `(unless (eq nil ,(cadr args)) t))))) (cmpwarn "Type mismatch was found in ~s." (cons 'the args))) (setf (info-type info) type) (list* (car form) info (cddr form)) ) (defun c1compiler-let (args &aux (symbols nil) (values nil)) (when (endp args) (too-few-args 'compiler-let 1 0)) (dolist** (spec (car args)) (cond ((consp spec) (cmpck (not (and (symbolp (car spec)) (or (endp (cdr spec)) (endp (cddr spec))))) "The variable binding ~s is illegal." spec) (push (car spec) symbols) (push (if (endp (cdr spec)) nil (eval (cadr spec))) values)) ((symbolp spec) (push spec symbols) (push nil values)) (t (cmperr "The variable binding ~s is illegal." spec)))) (setq symbols (reverse symbols)) (setq values (reverse values)) (setq args (progv symbols values (c1progn (cdr args)))) (list 'compiler-let (cadr args) symbols values args) ) (defun c2compiler-let (symbols values body) (progv symbols values (c2expr body))) (defun c1function (args &aux fd) (when (endp args) (too-few-args 'function 1 0)) (unless (endp (cdr args)) (too-many-args 'function 1 (length args))) (let ((fun (car args))) (cond ((symbolp fun) (cond ((and (setq fd (c1local-closure fun)) (eq (car fd) 'call-local)) (list 'function *info* fd)) (t (let ((info (make-info :sp-change (null (get fun 'no-sp-change))))) (list 'function info (list 'call-global info fun)) )))) ((and (consp fun) (eq (car fun) 'lambda)) (cmpck (endp (cdr fun)) "The lambda expression ~s is illegal." fun) (let ((*vars* (cons 'cb *vars*)) (*funs* (cons 'cb *funs*)) (*blocks* (cons 'cb *blocks*)) (*tags* (cons 'cb *tags*))) (setq fun (c1lambda-expr (cdr fun))) (list 'function (cadr fun) fun))) (t (cmperr "The function ~s is illegal." fun)))) ) (defun c2function (funob) (case (car funob) (call-global (unwind-exit (list 'symbol-function (add-symbol (caddr funob))))) (call-local (if (cadddr funob) (unwind-exit (list 'ccb-vs (fun-ref-ccb (caddr funob)))) (unwind-exit (list 'vs* (fun-ref (caddr funob)))))) (t ;;; Lambda closure. (let ((fun (make-fun :name 'closure :cfun (next-cfun)))) (push (list 'closure (if (null *clink*) nil (cons 'fun-env 0)) *ccb-vs* fun funob) *local-funs*) (push fun *closures*) (cond (*clink* (unwind-exit (list 'make-cclosure (fun-cfun fun) *clink* (fun-name fun)))) (t (unwind-exit (list 'vv (cons 'si::|#,| `(si::mc nil ,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun)))))))))) )) ) (si:putprop 'symbol-function 'wt-symbol-function 'wt-loc) (si:putprop 'make-cclosure 'wt-make-cclosure 'wt-loc) (defun wt-symbol-function (vv) (if *safe-compile* (wt "symbol_function(" (vv-str vv) ")") (wt "(" (vv-str vv) "->s.s_gfdef)"))) (defun wt-make-cclosure (cfun clink fname) (wt-nl "make_cclosure_new(" (c-function-name "LC" cfun fname) ",Cnil,") (wt-clink clink) (wt ",Cdata)")) gcl/cmpnew/gcl_cmptag.lsp000077500000000000000000000347511242227143400157520ustar00rootroot00000000000000;;; CMPTAG Tagbody and Go. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (import 'si::switch) (import 'si::switch-finish) (si:putprop 'tagbody 'c1tagbody 'c1special) (si:putprop 'tagbody 'c2tagbody 'c2) (si:putprop 'go 'c1go 'c1special) (si:putprop 'go 'c2go 'c2) (defstruct tag name ;;; Tag name. ref ;;; Referenced or not. T or NIL. ref-clb ;;; Cross local function reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the vs-address for the ;;; tagbody id, or NIL. ref-ccb ;;; Cross closure reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the vs-address for the ;;; block id, or NIL. label ;;; Where to jump. A label. unwind-exit ;;; Where to unwind-no-exit. var ;;; The tag-name holder. A VV index. switch ;;; tag for switch. A fixnum or 'default ) (defvar *tags* nil) ;;; During Pass 1, *tags* holds a list of tag objects and the symbols 'CB' ;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on ;;; *tags* when the compiler begins to process a closure. 'LB' will be pushed ;;; on *tags* when *level* is incremented. (defun jumps-to-p (clause tag-name &aux tem) ;;Does CLAUSE have a go TAG-NAME in it? (cond ((atom clause)nil) ((and (eq (car clause) 'go) (tag-p (setq tem (cadddr (cdr clause)))) (eq (tag-name tem) tag-name))) (t (or (jumps-to-p (car clause) tag-name) (jumps-to-p (cdr clause) tag-name))))) (defvar *reg-amount* 60) ;;amount to increase var-register for each variable reference in side a loop (defun add-reg1 (form) ;;increase the var-register in FORM for all vars (cond ((atom form) (cond ((typep form 'var) (setf (var-register form) (the fixnum (+ (the fixnum (var-register form)) (the fixnum *reg-amount*)))) ))) (t (add-reg1 (car form)) (add-reg1 (cdr form))))) (defun add-loop-registers (tagbody) ;;Find a maximal iteration interval in TAGBODY from first to end ;;then increment the var-register slot. (do ((v tagbody (cdr v)) (end nil) (first nil)) ((null v) (do ((ww first (cdr ww))) ((eq ww end)(add-reg1 (car ww))) (add-reg1 (car ww)))) (cond ((typep (car v) 'tag) (or first (setq first v)) (do ((w (cdr v) (cdr w)) (name (tag-name (car v)))) ((null w) ) (cond ((jumps-to-p (car w) name) (setq end w)))))))) (defun c1tagbody (body &aux (*tags* *tags*) (info (make-info))) ;;; Establish tags. (setq body (mapcar #'(lambda (x) (cond ((or (symbolp x) (integerp x)) (let ((tag (make-tag :name x :ref nil :ref-ccb nil :ref-clb nil))) (push tag *tags*) tag)) (t x))) body)) ;;; Process non-tag forms. (setq body (mapcar #'(lambda (x) (if (typep x 'tag) x (c1expr* x info))) body)) ;;; Delete redundant tags. (do ((l body (cdr l)) (body1 nil) (ref nil) (ref-clb nil) (ref-ccb nil)) ((endp l) (if (or ref-ccb ref-clb ref) (progn (setq body1 (nreverse body1)) ;; If ref-ccb is set, we will cons up the environment, hence ;; all tags which had level boundary references must be changed ;; to ccb references. FIXME -- review this logic carefully ;; CM 20040228 (when ref-ccb (dolist (l body1) (when (and (typep l 'tag) (tag-ref-clb l)) (setf (tag-ref-ccb l) t)))) (cond ((or ref-clb ref-ccb) (incf *setjmps*)) (t (add-loop-registers body1 ))) (list 'tagbody info ref-clb ref-ccb body1)) (list 'progn info (nreverse (cons (c1nil) body1))))) (declare (object l ref ref-clb ref-ccb)) (if (typep (car l) 'tag) (cond ((tag-ref-ccb (car l)) (push (car l) body1) (setf (tag-var (car l)) (add-object (tag-name (car l)))) (setq ref-ccb t)) ((tag-ref-clb (car l)) (push (car l) body1) (setf (tag-var (car l)) (add-object (tag-name (car l)))) (setq ref-clb t)) ((tag-ref (car l)) (push (car l) body1) (setq ref t))) (push (car l) body1)))) (defun c2tagbody (ref-clb ref-ccb body) (cond (ref-ccb (c2tagbody-ccb body)) (ref-clb (c2tagbody-clb body)) (t (c2tagbody-local body)))) (defun c2tagbody-local (body &aux (label (next-label))) ;;; Allocate labels. (dolist** (x body) (when (typep x 'tag) (setf (tag-label x) (next-label*)) (setf (tag-unwind-exit x) label))) (let ((*unwind-exit* (cons label *unwind-exit*))) (c2tagbody-body body)) ) (defun c2tagbody-body (body) (do ((l body (cdr l)) (written nil)) ((endp (cdr l)) (cond (written (unwind-exit nil)) ((typep (car l) 'tag) (wt-switch-case (tag-switch (car l))) (wt-label (tag-label (car l))) (unwind-exit nil)) (t (let* ((*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*)) (*value-to-go* 'trash)) (c2expr (car l)) (wt-label *exit*)) (unless (eq (caar l) 'go) (unwind-exit nil))))) (declare (object l written)) (cond (written (setq written nil)) ((typep (car l) 'tag) (wt-switch-case (tag-switch (car l))) (wt-label (tag-label (car l)))) (t (let* ((*exit* (if (typep (cadr l) 'tag) (progn (setq written t) (tag-label (cadr l))) (next-label))) (*unwind-exit* (cons *exit* *unwind-exit*)) (*value-to-go* 'trash)) (c2expr (car l)) (and (typep (cadr l) 'tag) (wt-switch-case (tag-switch (cadr l)))) (wt-label *exit*)))))) (defun c2tagbody-clb (body &aux (label (next-label)) (*vs* *vs*)) (let ((*unwind-exit* (cons 'frame *unwind-exit*)) (ref-clb (vs-push))) (wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();") (wt-nl "frs_push(FRS_CATCH,") (wt-vs ref-clb) (wt ");") (wt-nl "if(nlj_active){") (wt-nl "nlj_active=FALSE;") ;;; Allocate labels. (dolist** (tag body) (when (typep tag 'tag) (setf (tag-label tag) (next-label*)) (setf (tag-unwind-exit tag) label) (when (tag-ref-clb tag) (setf (tag-ref-clb tag) ref-clb) (wt-nl "if(eql(nlj_tag," (vv-str (tag-var tag)) ")) {") (wt-nl " ") (reset-top) (wt-nl " ") (wt-go (tag-label tag)) (wt-nl "}")))) (wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);") (wt-nl "}") (let ((*unwind-exit* (cons label *unwind-exit*))) (c2tagbody-body body)))) (defun c2tagbody-ccb (body &aux (label (next-label)) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (let ((*unwind-exit* (cons 'frame *unwind-exit*)) (ref-clb (vs-push)) ref-ccb) (wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();") (wt-nl) (wt-vs ref-clb) (wt "=MMcons(") (wt-vs ref-clb) (wt ",") (wt-clink) (wt ");") (clink ref-clb) (setq ref-ccb (ccb-vs-push)) (wt-nl "frs_push(FRS_CATCH,") (wt-vs* ref-clb) (wt ");") (wt-nl "if(nlj_active){") (wt-nl "nlj_active=FALSE;") ;;; Allocate labels. (dolist** (tag body) (when (typep tag 'tag) (setf (tag-label tag) (next-label*)) (setf (tag-unwind-exit tag) label) (when (or (tag-ref-clb tag) (tag-ref-ccb tag)) (setf (tag-ref-clb tag) ref-clb) (when (tag-ref-ccb tag) (setf (tag-ref-ccb tag) ref-ccb)) (wt-nl "if(eql(nlj_tag," (vv-str (tag-var tag)) ")) {") (wt-nl " ") (reset-top) (wt-nl " ") (wt-go (tag-label tag)) (wt-nl "}")))) (wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);") (wt-nl "}") (let ((*unwind-exit* (cons label *unwind-exit*))) (c2tagbody-body body)))) (defun c1go (args) (cond ((endp args) (too-few-args 'go 1 0)) ((not (endp (cdr args))) (too-many-args 'go 1 (length args))) ((not (or (symbolp (car args)) (integerp (car args)))) "The tag name ~s is not a symbol nor an integer." (car args))) (do ((tags *tags* (cdr tags)) (name (car args)) (ccb nil) (clb nil)) ((endp tags) (cmperr "The tag ~s is undefined." name)) (declare (object name ccb clb)) (case (car tags) (cb (setq ccb t)) (lb (setq clb t)) (t (when (eq (tag-name (car tags)) name) (let ((tag (car tags))) (cond (ccb (setf (tag-ref-ccb tag) t)) (clb (setf (tag-ref-clb tag) t)) (t (setf (tag-ref tag) t))) (return (list 'go *info* clb ccb tag)))))))) (defun c2go (clb ccb tag) (cond (ccb (c2go-ccb tag)) (clb (c2go-clb tag)) (t (c2go-local tag)))) (defun c2go-local (tag) (unwind-no-exit (tag-unwind-exit tag)) (wt-nl) (wt-go (tag-label tag))) (defun c2go-clb (tag) (wt-nl "vs_base=vs_top;") (wt-nl "unwind(frs_sch(") (if (tag-ref-ccb tag) (wt-vs* (tag-ref-clb tag)) (wt-vs (tag-ref-clb tag))) (wt ")," (vv-str (tag-var tag)) ");")) (defun c2go-ccb (tag) (wt-nl "{frame_ptr fr;") (wt-nl "fr=frs_sch(") (wt-ccb-vs (tag-ref-ccb tag)) (wt ");") (wt-nl "if(fr==NULL)FEerror(\"The GO tag ~s is missing.\",1," (vv-str (tag-var tag)) ");") (wt-nl "vs_base=vs_top;") (wt-nl "unwind(fr," (vv-str (tag-var tag)) ");}")) (defun wt-switch-case (x) (cond (x (wt-nl (if (typep x 'fixnum) "case " "") x ":")))) (defun c1switch(form &aux (*tags* *tags*)) (let* ((switch-op (car form)) (body (cdr form)) (switch-op-1 (c1expr switch-op))) (cond ((and (typep (second switch-op-1 ) 'info) (subtypep (info-type (second switch-op-1)) 'fixnum)) ;;optimize into a C switch: ;;If we ever get GCC to do switch's with an enum arg, ;;which don't do bounds checking, then we will ;;need to carry over the restricted range. ;;more generally the compiler should carry along the original type ;;decl, not just the coerced one. This needs another slot in ;;info. (or (member t body) (setq body (append body (list t)))) ;; Remove duplicate tags in C switch statement -- CM 20031112 (setq body (let (tags new-body) (dolist (b body) (cond ((or (symbolp b) (integerp b)) (unless (member b tags) (push b tags) (push b new-body))) (t (push b new-body)))) (nreverse new-body))) (setq body (mapcar #'(lambda (x) (cond ((or (symbolp x) (integerp x)) (let ((tag (make-tag :name x :ref nil :ref-ccb nil :ref-clb nil))) (cond((typep x 'fixnum) (setf (tag-ref tag) t) (setf (tag-switch tag) x)) ((eq t x) (setf (tag-ref tag) t) (setf (tag-switch tag) "default"))) tag)) (t x))) body)) (let ((tem (c1tagbody `(,@ body switch-finish-label)))) (nconc (list 'switch (cadr tem) switch-op-1) (cddr tem)) )) (t (c1expr (cmp-macroexpand-1 (cons 'switch form))))))) (defun c2switch (op ref-clb ref-ccb body &aux (*inline-blocks* 0)(*vs* *vs*)) (let ((args (inline-args (list op ) '(fixnum )))) (wt-inline-loc "switch(#0){" args) (cond (ref-ccb (c2tagbody-ccb body)) (ref-clb (c2tagbody-clb body)) (t (c2tagbody-local body))) (wt "}") (unwind-exit nil) (close-inline-blocks))) ;; SWITCH construct for Common Lisp. (TEST &body BODY) (in package SI) ;; TEST must evaluate to something of INTEGER TYPE. If test matches one ;; of the labels (ie integers) in the body of switch, control will jump ;; to that point. It is an error to have two or more constants which are ;; eql in the the same switch. If none of the constants match the value, ;; then control moves to a label T. If there is no label T, control ;; flows as if the last term in the switch were a T. It is an error ;; however if TEST were declared to be in a given integer range, and at ;; runtime a value outside that range were provided. The value of a ;; switch construct is undefined. If you wish to return a value use a ;; block construct outside the switch and a return-from. `GO' may also ;; be used to jump to labels in the SWITCH. ;; Control falls through from case to case, just as if the cases were ;; labels in a tagbody. To jump to the end of the switch, use ;; (switch-finish). ;; The reason for using a new construct rather than building on CASE, is ;; that CASE does not allow the user to use invoke a `GO' if necessary. ;; to switch from one case to another. Also CASE does not allow sharing ;; of parts of code between different cases. They have to be either the ;; same or disjoint. ;; The SWITCH may be implemented very efficiently using a jump table, if ;; the range of cases is not too much larger than the number of cases. ;; If the range is much larger than the number of cases, a binary ;; splitting of cases might be used. ;; Sample usage: ;; (defun goo (x) ;; (switch x ;; 1 (princ "x is one, ") ;; 2 (princ "x is one or two, ") ;; (switch-finish) ;; 3 (princ "x is three, ") ;; (switch-finish) ;; t (princ "none"))) ;; We provide a Common Lisp macro for implementing the above construct: (defmacro switch (test &body body &aux cases) (dolist (v body) (cond ((integerp v) (push `(if (eql ,v ,test) (go ,v) nil) cases)))) `(tagbody ,@ (nreverse cases) (go t) ,@ body ,@ (if (member t body) nil '(t)) switch-finish-label )) (defmacro switch-finish nil '(go switch-finish-label)) (si::putprop 'switch 'c1switch 'c1special) (si::putprop 'switch 'c2switch 'c2) gcl/cmpnew/gcl_cmptest.lsp000077500000000000000000000201041242227143400161410ustar00rootroot00000000000000;;; CMPTEST Functions for compiler test. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (defun self-compile () (with-open-file (log "lsplog" :direction :output) (let ((*standard-output* (make-broadcast-stream *standard-output* log))) ; (self-compile2 "cmpbind") ; (self-compile2 "cmpblock") ; (self-compile2 "cmpcall") ; (self-compile2 "cmpcatch") (self-compile2 "cmpenv") ; (self-compile2 "cmpeval") ; (self-compile2 "cmpflet") ; (self-compile2 "cmpfun") ; (self-compile2 "cmpif") ; (self-compile2 "cmpinline") (self-compile2 "cmplabel") ; (self-compile2 "cmplam") ; (self-compile2 "cmplet") ; (self-compile2 "cmploc") ; (self-compile2 "cmpmap") ; (self-compile2 "cmpmulti") ; (self-compile2 "cmpspecial") ; (self-compile2 "cmptag") ; (self-compile2 "cmptop") ; (self-compile2 "cmptype") (self-compile2 "cmputil") ; (self-compile2 "cmpvar") ; (self-compile2 "cmpvs") ; (self-compile2 "cmpwt") )) t) (defun setup () ; (allocate 'cons 800) ; (allocate 'string 256) ; (allocate 'structure 32) ; (allocate-relocatable-pages 128) ; (load ":udd:common:cmpnew:cmpinline.lsp") (load ":udd:common:cmpnew:cmputil.lsp") ; (load ":udd:common:cmpnew:cmptype.lsp") ; (load ":udd:common:cmpnew:cmpbind.lsp") ; (load ":udd:common:cmpnew:cmpblock.lsp") (load ":udd:common:cmpnew:cmpcall.lsp") ; (load ":udd:common:cmpnew:cmpcatch.lsp") ; (load ":udd:common:cmpnew:cmpenv.lsp") ; (load ":udd:common:cmpnew:cmpeval.lsp") (load ":udd:common:cmpnew:cmpflet.lsp") ; (load ":udd:common:cmpnew:cmpfun.lsp") ; (load ":udd:common:cmpnew:cmpif.lsp") (load ":udd:common:cmpnew:cmplabel.lsp") ; (load ":udd:common:cmpnew:cmplam.lsp") ; (load ":udd:common:cmpnew:cmplet.lsp") (load ":udd:common:cmpnew:cmploc.lsp") ; (load ":udd:common:cmpnew:cmpmain.lsp") ; (load ":udd:common:cmpnew:cmpmap.lsp") ; (load ":udd:common:cmpnew:cmpmulti.lsp") ; (load ":udd:common:cmpnew:cmpspecial.lsp") ; (load ":udd:common:cmpnew:cmptag.lsp") (load ":udd:common:cmpnew:cmptop.lsp") ; (load ":udd:common:cmpnew:cmpvar.lsp") ; (load ":udd:common:cmpnew:cmpvs.lsp") ; (load ":udd:common:cmpnew:cmpwt.lsp") ; (load ":udd:common:cmpnew:lfun_list") ; (load ":udd:common:cmpnew:cmpopt.lsp") ) (defun cli () (process ":cli.pr")) (defun load-fasl () (load "cmpinline") (load "cmputil") (load "cmpbind") (load "cmpblock") (load "cmpcall") (load "cmpcatch") (load "cmpenv") (load "cmpeval") (load "cmpflet") (load "cmpfun") (load "cmpif") (load "cmplabel") (load "cmplam") (load "cmplet") (load "cmploc") (load "cmpmap") (load "cmpmulti") (load "cmpspecial") (load "cmptag") (load "cmptop") (load "cmptype") (load "cmpvar") (load "cmpvs") (load "cmpwt") (load "cmpmain.lsp") (load "lfun_list.lsp") (load "cmpopt.lsp") ) (setq *macroexpand-hook* 'funcall) (defun self-compile1 (file) (prin1 file) (terpri) (compile-file1 file :fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t)) (defun self-compile2 (file) (prin1 file) (terpri) (compile-file1 file :fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t) (prin1 (load file)) (terpri)) (defvar *previous-form* nil) (defun cmp (form) (setq *previous-form* form) (again)) (defun again () (init-env) (print *previous-form*) (terpri) (setq *compiler-output1* *standard-output*) (setq *compiler-output2* *standard-output*) (setq *compiler-output-data* *standard-output*) (let ((prev (get-dispatch-macro-character #\# #\,))) (set-dispatch-macro-character #\# #\, 'si:sharp-comma-reader-for-compiler) (unwind-protect (t1expr *previous-form*) (set-dispatch-macro-character #\# #\, prev))) (catch *cmperr-tag* (ctop-write "test")) t) ;(defun make-cmpmain-for-unix () ; (print "unixmain") ; (format t "~&The old value of *FEATURES* is ~s." *features*) ; (let ((*features* '(unix common kcl))) ; (format t "~&The new value of *FEATURES* is ~s." *features*) ; (init-env) ; (compile-file1 "cmpmain.lsp" ; :output-file "unixmain" ; :c-file t ; :h-file t ; :data-file t ; :system-p t ; )) ; (format t "~&The resumed value of *FEATURES* is ~s." *features*) ; ) (defun compiler-make-ufun () (make-ufun '( "cmpbind.lsp" "cmpblock.lsp" "cmpcall.lsp" "cmpcatch.lsp" "cmpenv.lsp" "cmpeval.lsp" "cmpflet.lsp" "cmpfun.lsp" "cmpif.lsp" "cmpinline.lsp" "cmplabel.lsp" "cmplam.lsp" "cmplet.lsp" "cmploc.lsp" "cmpmain.lsp" "cmpmap.lsp" "cmpmulti.lsp" "cmpspecial.lsp" "cmptag.lsp" "cmptop.lsp" "cmptype.lsp" "cmputil.lsp" "cmpvar.lsp" "cmpvs.lsp" "cmpwt.lsp" )) t) (defun remrem () (do-symbols (x (find-package 'lisp)) (remprop x 'inline-always) (remprop x 'inline-safe) (remprop x 'inline-unsafe)) (do-symbols (x (find-package 'system)) (remprop x 'inline-always) (remprop x 'inline-safe) (remprop x 'inline-unsafe))) (defun ckck () (do-symbols (x (find-package 'lisp)) (when (or (get x 'inline-always) (get x 'inline-safe) (get x 'inline-unsafe)) (print x))) (do-symbols (x (find-package 'si)) (when (or (get x 'inline-always) (get x 'inline-safe) (get x 'inline-unsafe)) (print x)))) (defun make-cmpopt (&aux (eof (cons nil nil))) (with-open-file (in "cmpopt.db") (with-open-file (out "cmpopt.lsp" :direction :output) (print '(in-package 'compiler) out) (terpri out) (terpri out) (do ((x (read in nil eof) (read in nil eof))) ((eq x eof)) (apply #'(lambda (property return-type side-effectp new-object-p name arg-types body) (when (stringp body) (do ((i 0 (1+ i)) (l nil) (l1 nil)) ((>= i (length body)) (when l1 (setq body (concatenate 'string "@" (reverse l1) ";" body)))) (when (char= (aref body i) #\#) (incf i) (cond ((member (aref body i) l) (pushnew (aref body i) l1)) (t (push (aref body i) l)))))) (print `(push '(,arg-types ,return-type ,side-effectp ,new-object-p ,body) (get ',name ',property)) out)) (cdr x))) (terpri out)))) gcl/cmpnew/gcl_cmptop.lsp000077500000000000000000001740631242227143400160020ustar00rootroot00000000000000;;; CMPTOP Compiler top-level. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (defvar *objects* (make-hash-table :test 'eq)) ;(defvar *objects* nil) (defvar *constants* nil) (defvar *sharp-commas* nil) (defvar *function-links* nil) (defvar *c-gc* t) ;if we gc the c stack. (defvar *c-vars*) ;list of *c-vars* to put at beginning of function. ;;number of address registers available not counting the ;;frame pointer and the stack pointer ;;If sup and base are used, then their are even 2 less ;;To do: If the regs hold data then there are really more available; (defvar *free-address-registers* 5) (defvar *free-data-registers* 6) ;;Inside t3defun this collects the list of downward closures defined. (defvar *downward-closures* nil) (defvar *volatile*) (defvar *setjmps* 0) ;; Functions may use a block of C stack space. ;; (cs . i) will become Vcs[i]. (defvar *cs* 0) ;; Holds list of local-functions resulting from c1function of ;; a lambda. Is used to eliminate mix of downward and regular closures. (defvar *local-functions* nil) ;;; *objects* holds ( { object vv-index }* ). ;;; *constants* holds ( { symbol vv-index }* ). ;;; *sharp-commas* holds ( vv-index* ), indicating that the value ;;; of each vv should be turned into an object from a string before ;;; defining the current function during loading process, so that ;;; sharp-comma-macros may be evaluated correctly. ;;; *function-links* ( {symbol vv-index} ) for function symbols needing link (defvar *global-funs* nil) ;;; *global-funs* holds ;;; ( { global-fun-name cfun }* ) (defvar *closures* nil) (defvar *local-funs* nil) ;;; *closure* holds fun-objects for closures. (defvar *top-level-forms* nil) (defvar *non-package-operation* nil) ;;; *top-level-forms* holds ( { top-level-form }* ). ;;; ;;; top-level-form: ;;; ( 'DEFUN' fun-name cfun lambda-expr doc-vv sp) ;;; | ( 'DEFMACRO' macro-name cfun lambda-expr doc-vv sp) ;;; | ( 'ORDINARY' cfun expr) ;;; | ( 'DECLARE' var-name-vv ) ;;; | ( 'DEFVAR' var-name-vv expr doc-vv) ;;; | ( 'CLINES' string ) ;;; | ( 'DEFCFUN' header vs-size body) ;;; | ( 'DEFENTRY' fun-name cfun cvspecs type cfun-name ) ;;; | ( 'SHARP-COMMA' vv ) (defvar *reservations* nil) (defvar *reservation-cmacro* nil) ;;; *reservations* holds (... ( cmacro . value ) ...). ;;; *reservation-cmacro* holds the cmacro current used as vs reservation. (defvar *global-entries* nil) ;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...). ;;; Package operations. (si:putprop 'make-package t 'package-operation) (si:putprop 'in-package t 'package-operation) (si:putprop 'shadow t 'package-operation) (si:putprop 'shadowing-import t 'package-operation) (si:putprop 'export t 'package-operation) (si:putprop 'unexport t 'package-operation) (si:putprop 'use-package t 'package-operation) (si:putprop 'unuse-package t 'package-operation) (si:putprop 'import t 'package-operation) (si:putprop 'provide t 'package-operation) (si:putprop 'require t 'package-operation) (si:putprop 'defpackage:defpackage t 'package-operation) ;;; Pass 1 top-levels. (si:putprop 'eval-when 't1eval-when 't1) (si:putprop 'progn 't1progn 't1) (si:putprop 'macrolet 't1macrolet 't1) (si:putprop 'defun 't1defun 't1) (si:putprop 'defmacro 't1defmacro 't1) (si:putprop 'clines 't1clines 't1) (si:putprop 'defcfun 't1defcfun 't1) (si:putprop 'defentry 't1defentry 't1) (si:putprop 'defla 't1defla 't1) ;;; Top-level macros. (si:putprop 'defconstant t 'top-level-macro) (si:putprop 'defparameter t 'top-level-macro) (si:putprop 'defstruct t 'top-level-macro) (si:putprop 'deftype t 'top-level-macro) (si:putprop 'defsetf t 'top-level-macro) ;;; Pass 2 initializers. (si:putprop 'defun 't2defun 't2) (si:putprop 'defmacro 't2defmacro 't2) (si:putprop 'declare 't2declare 't2) (si:putprop 'defentry 't2defentry 't2) (si:putprop 'si:putprop 't2putprop 't2) ;;; Pass 2 C function generators. (si:putprop 'defun 't3defun 't3) (si:putprop 'defmacro 't3defmacro 't3) (si:putprop 'ordinary 't3ordinary 't3) (si:putprop 'sharp-comma 't3sharp-comma 't3) (si:putprop 'clines 't3clines 't3) (si:putprop 'defcfun 't3defcfun 't3) (si:putprop 'defentry 't3defentry 't3) (eval-when (compile eval) (defmacro lambda-list (lambda-expr) `(caddr ,lambda-expr)) (defmacro ll-requireds (lambda-list) `(car ,lambda-list)) (defmacro ll-keywords (lambda-list) `(nth 4 ,lambda-list)) (defmacro ll-optionals (lambda-list) `(nth 1 ,lambda-list)) (defmacro ll-keywords-p (lambda-list) `(nth 3 ,lambda-list)) (defmacro ll-rest (lambda-list) `(nth 2 ,lambda-list)) (defmacro ll-allow-other-keys (lambda-list) `(nth 5 ,lambda-list)) (defmacro vargd (min max) `(+ ,min (ash ,max 8))) (defmacro let-pass3 (binds &body body &aux res) (let ((usual '((*c-vars* nil) (*vs* 0) (*max-vs* 0) (*level* 0) (*ccb-vs* 0) (*clink* nil) (*unwind-exit* (list *exit*)) (*value-to-go* *exit*) (*reservation-cmacro* (next-cmacro)) (*sup-used* nil) (*restore-avma* nil) (*base-used* nil) (*cs* 0) ))) (dolist (v binds) (or (assoc (car v) usual) (push v usual))) (do ((v (setq usual (copy-list usual)) (cdr v))) ((null v)) (let ((tem (assoc (caar v) binds))) (if tem (setf (car v) tem)))) `(let* ,usual ,@body))) ) ;; FIXME case does not optimize as well (defun dash-to-underscore-int (str beg end) (declare (string str) (fixnum beg end)) (unless (< beg end) (return-from dash-to-underscore-int str)) (let ((ch (aref str beg))) (declare (character ch)) (setf (aref str beg) (cond ((eql ch #\-) #\_) ((eql ch #\/) #\_) ((eql ch #\.) #\_) ((eql ch #\_) #\_) ((eql ch #\!) #\E) ((eql ch #\*) #\A) (t (if (alphanumericp ch) ch #\$))))) (dash-to-underscore-int str (1+ beg) end)) (defun dash-to-underscore (str) (declare (string str)) (let ((new (copy-seq str))) (dash-to-underscore-int new 0 (length new)))) (defun init-name (p &optional sp (gp t) (dc t) (nt t)) (cond ((not sp) "code") ((not (pathnamep p)) (init-name (pathname p) sp gp dc nt)) (gp (init-name (truename (merge-pathnames p #".lsp")) sp nil dc nt)) ((pathname-type p) (init-name (make-pathname :host (pathname-host p) :device (pathname-device p) :directory (pathname-directory p) :name (pathname-name p) :version (pathname-version p)) sp gp dc nt)) ; #-aosvs(dc (string-downcase (init-name p sp gp nil nt))) ((and nt (let* ((pn (pathname-name p)) (pp (make-pathname :name pn))) (and (not (equal pp p)) (eql 4 (string<= "gcl_" pn)) (init-name pp sp gp dc nil))))) ((dash-to-underscore (namestring p))))) ;; FIXME consider making this a macro (defun c-function-name (prefix num fname) #-gprof(declare (ignore fname)) (si::string-concatenate (string prefix) (write-to-string num) #+gprof(let ((fname (string fname))) (si::string-concatenate "__" (dash-to-underscore fname) "__" (if (boundp '*compiler-input*) (subseq (init-name *compiler-input* t) 4) ""))))) (defun t1expr (form &aux (*current-form* form) (*first-error* t)) (catch *cmperr-tag* (when (consp form) (let ((fun (car form)) (args (cdr form)) fd) (declare (object fun args)) (cond ((symbolp fun) (cond ((eq fun 'si:|#,|) (cmperr "Sharp-comma-macro is in a bad place.")) ((get fun 'package-operation) (when *non-package-operation* (cmpwarn "The package operation ~s was in a bad place." form)) (let ((res (if (setq fd (macro-function fun)) (cmp-expand-macro fd fun (copy-list (cdr form))) form))) (maybe-eval t res) (wt-data-package-operation res))) ((setq fd (get fun 't1)) (when *compile-print* (print-current-form)) (funcall fd args)) ((get fun 'top-level-macro) (when *compile-print* (print-current-form)) (t1expr (cmp-macroexpand-1 form))) ((get fun 'c1) (t1ordinary form)) ((setq fd (or (macro-function fun) (cadr (assoc fun *funs*)))) (let ((res (cmp-expand-macro fd fun (copy-list (cdr form))) )) (t1expr res))) (t (t1ordinary form)) )) ((consp fun) (t1ordinary form)) (t (cmperr "~s is illegal function." fun))) ))) ) (defun declaration-type (type) (cond ((equal type "") "void") ((equal type "long ") "object ") (t type))) (defvar *vaddress-list*) ;; hold addresses of C functions, and other data (defvar *vind*) ;; index in the VV array where the address is. (defvar *Inits*) (defun ctop-write (name &aux def (*function-links* nil) *c-vars* (*volatile* " VOL ") *vaddress-list* (*vind* 0) *inits* *current-form* *vcs-used*) (declare (special *current-form* *vcs-used*)) (setq *top-level-forms* (nreverse *top-level-forms*)) ;;; Initialization function. (wt-nl1 "void init_" name "(){" #+sgi3d "Init_Links ();" "do_init((void *)VV);" "}") ;; write all the inits. (dolist* (*current-form* *top-level-forms*) (setq *first-error* t) (setq *vcs-used* nil) (when (setq def (get (car *current-form*) 't2)) (apply def (cdr *current-form*)))) ;;; C function definitions. (dolist* (*current-form* *top-level-forms*) (setq *first-error* t) (setq *vcs-used* nil) (when (setq def (get (car *current-form*) 't3)) (apply def (cdr *current-form*)))) ;;; Local function and closure function definitions. (let (lf) (block local-fun-process (loop (when (endp *local-funs*) (return-from local-fun-process)) (setq lf (car *local-funs*)) (pop *local-funs*) (setq *vcs-used* nil) (apply 't3local-fun lf)))) ;;; Global entries for directly called functions. (dolist* (x *global-entries*) (setq *vcs-used* nil) (apply 'wt-global-entry x)) ;;; Fastlinks (dolist* (x *function-links*) (setq *vcs-used* nil) (wt-function-link x)) #+sgi3d (progn (wt-nl1 "" "static void Init_Links () {") (dolist* (x *function-links*) (let ((num (second x))) (wt-nl "Lnk" num " = LnkT" num ";"))) (wt-nl1 "}")) ;;; Declarations in h-file. (dolist* (fun *closures*) (wt-h "static void " (c-function-name "LC" (fun-cfun fun) (fun-name fun)) "();")) (dolist* (x *reservations*) (wt-h "#define VM" (car x) " " (cdr x))) ;;*next-vv* is the index of the last entry pushed onto the data vector ;;*vind* is the index of the next constant to be pushed. ;;make sure enough room in VV to handle *vind* ;;reserve a spot for the Cdata which will be swapped for the (si::%init..): (push-data-incf nil) ;Ensure there is enough room to write t (dotimes (i (- *vind* *next-vv* +1)) (push-data-incf nil)) ;; now *next-vv* >= *vind* ;; reserve space for the Cdata the cfdata object as the ;; last entry in the VV vector. (wt-h "static void * VVi[" (+ 1 *next-vv*) "]={") (wt-h "#define Cdata VV[" *next-vv* "]") (or *vaddress-list* (wt-h 0)) (do ((v (nreverse *Vaddress-List*) (cdr v))) ((null v) (wt-h "};")) (wt-h "(void *)(" (caar v) (if (cdr v) ")," ")"))) (wt-h "#define VV (VVi)") (wt-data-file) ; (break "f") (dolist (x *function-links* ) (let ((num (second x)) (type (third x)) (args (fourth x)) (newtype nil)) (cond ((eq type 'proclaimed-closure) (wt-h "static object Lclptr"num";") (setq newtype "")) (t (setq newtype (if type (Rep-type type) "")))) (if (and (not (null type)) (not (eq type 'proclaimed-closure)) (or args (not (eq t type)))) (progn (wt-h "static " (declaration-type newtype) " LnkT" num "(object,...);") #-sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")() = (" (declaration-type newtype) "(*)()) LnkT" num ";") #+sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")();")) (progn (wt-h "static " (declaration-type newtype) " LnkT" num "();") #-sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")() = LnkT" num ";") #+sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")();")))))) ;; this default will be as close to the the decision of the x3j13 committee ;; as I can make it. Valid values of *eval-when-defaults* are ;; a sublist of '(compile eval load) (defvar *eval-when-defaults* :defaults) (defun maybe-eval (default-action form) (or default-action (and (symbolp (car form)) (setq default-action (get (car form) 'eval-at-compile)))) (cond ((or (and default-action (eq :defaults *eval-when-defaults*)) (and (consp *eval-when-defaults*)(member 'compile *eval-when-defaults* ))) (if form (cmp-eval form)) t))) (defun t1eval-when (args &aux load-flag compile-flag) (when (endp args) (too-few-args 'eval-when 1 0)) (dolist** (situation (car args)) (case situation ((load :load-toplevel) (setq load-flag t)) ((compile :compile-toplevel) (setq compile-flag t)) ((eval :execute)) (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal." situation)))) (let ((*eval-when-defaults* (car args))) (cond (load-flag (t1progn (cdr args))) (compile-flag (cmp-eval (cons 'progn (cdr args))))))) (defun t1macrolet(args &aux (*funs* *funs*)) (dolist (def (car args)) (push (list (car def) (caddr (si:defmacro* (car def) (cadr def) (cddr def)))) *funs*)) (dolist (form (cdr args)) (t1expr form))) (defvar *compile-ordinaries* nil) (defun t1progn (args) (cond ((equal (car args) ''compile) (let ((*compile-ordinaries* t)) (t1progn (cdr args)))) (t (dolist** (form args) (t1expr form))))) ;; (defun foo (x) .. -> (defun foo (g102 &aux (x g102)) ... (defun cmpfix-args (args bind &aux tem (lam (copy-list (second args)))) (dolist (v bind) (setq tem (member (car v) lam)) (and tem (setf (car tem) (second v)))) (cond ((setq tem (member '&aux lam)) (setf (cdr tem) (append bind (cdr tem)))) (t (setf lam (append lam (cons '&aux bind))))) (list* (car args) lam (cddr args))) (defun t1defun (args &aux (setjmps *setjmps*) (defun 'defun) (*sharp-commas* nil)) (when (or (endp args) (endp (cdr args))) (too-few-args 'defun 2 (length args))) (cmpck (not (symbolp (car args))) "The function name ~s is not a symbol." (car args)) (maybe-eval nil (cons 'defun args)) (tagbody top (setq *non-package-operation* t) (setq *local-functions* nil) (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil) lambda-expr (*special-binding* nil) (cfun (or (get (car args) 'Ufun) (next-cfun))) (doc nil) (fname (car args))) (declare (object fname)) (setq lambda-expr (c1lambda-expr (cdr args) fname)) (or (eql setjmps *setjmps*) (setf (info-volatile (cadr lambda-expr)) t)) (check-downward (cadr lambda-expr)) ;;provide a simple way for the user to declare functions to ;;have fixed args without having to count them, and make mistakes. (cond ((get fname 'fixed-args) ;the number of regular args in definition (let ((n (length (car (lambda-list lambda-expr))))) (setf (get fname 'fixed-args) n);;for error checking. (proclaim (list 'function fname (make-list n :initial-element t) t))))) (cond ((and (get fname 'proclaimed-function) ;; check the args: (let ((lambda-list (lambda-list lambda-expr))bind) (declare (object lambda-list)) (and (null (cadr lambda-list)) ;;; no optional (null (caddr lambda-list)) ;;; no rest (null (cadddr lambda-list)) ;;; no keyword (< (length (car lambda-list)) call-arguments-limit) ;;; less than 10 requireds ;;; For all required parameters... (do ((vars (car lambda-list) (cdr vars)) (types (get fname 'proclaimed-arg-types) (cdr types)) (problem)) ((endp vars) (and (endp types) (cond (bind (setq args (cmpfix-args args bind)) (go top)) (t (not problem))))) (declare (object vars types)) (let ((var (car vars))) (declare (object var)) (cond ((equal (car types) '*)(return nil))) (unless (and (or (and (or (eq (var-kind var) 'LEXICAL) (and (eq (var-kind var) 'special) (eq (car types) t))) (not (var-ref-ccb var)) (not (eq (var-loc var) 'clb))) (progn (push (list (var-name var) (gensym)) bind) t)) (type-and (car types) (var-type var)) (or (member (car types) '(fixnum character long-float short-float)) (eq (var-loc var) 'object) *c-gc* (not (is-changed var (cadr lambda-expr))))) (unless bind (cmpwarn "Calls to ~a will be VERY SLOW. Recommend not to proclaim. ~%;;The arg caused the problem. ~a" fname (var-name var))) (setq problem t)))) (numberp cfun)))) ;;whew: it is acceptable. (push (list fname (get fname 'proclaimed-arg-types) (get fname 'proclaimed-return-type) (flags set ans) (make-inline-string cfun (get fname 'proclaimed-arg-types) fname)) *inline-functions*)) ((and ;(get fname 'proclaimed-function) (eq (get fname 'proclaimed-return-type) t)) ; (setq me lambda-list) ; (setq me (lambda-list lambda-expr)) ; (print args) )) ;; variable number of args; (when (cadddr lambda-expr) (setq doc (cadddr lambda-expr))) (add-load-time-sharp-comma) (push (list defun fname cfun lambda-expr doc *special-binding*) *top-level-forms*) (push (cons fname cfun) *global-funs*) ))) (defun make-inline-string (cfun args fname) (if (null args) (format nil "~d()" (c-function-name "LI" cfun fname)) (let ((o (make-array 100 :element-type 'string-char :fill-pointer 0 :adjustable t ))) (format o "~d(" (c-function-name "LI" cfun fname)) (do ((l args (cdr l)) (n 0 (1+ n))) ((endp (cdr l)) (format o "#~d)" n)) (declare (fixnum n)) (format o "#~d," n)) o))) (defun cs-push (&optional type) (let ((tem (next-cvar))) (push (if type (cons type tem) tem) *c-vars*) tem)) ; For the moment only two types are recognized. (defun f-type (x) (if (var-p x) (setq x (var-type x))) (cond ((and x (subtypep x 'fixnum)) 1) (t 0))) (defun proclaimed-argd (args return) (let ((ans (length args)) (i 8) (type (the fixnum (f-type return))) (begin t)) (declare (fixnum ans i)) (loop (if (not (eql 0 type)) (setq ans (the fixnum (+ ans (the fixnum (ash (the fixnum type) (the (integer 0 30) i))))))) (when begin (setq i 10) (setq begin nil)) (if (null args) (return ans)) (setq i (the fixnum (+ i 2))) (setq type (f-type (pop args)))))) (defun wt-if-proclaimed (fname cfun lambda-expr) (cond ((fast-link-proclaimed-type-p fname) (cond ((unless (member '* (get fname 'proclaimed-arg-types)) (assoc fname *inline-functions*)) (add-init `(si::mfsfun ',fname ,(add-address (c-function-name "LI" cfun fname)) ,(proclaimed-argd (get fname 'proclaimed-arg-types) (get fname 'proclaimed-return-type) ) ) ) t) (t (let ((arg-c (length (car (lambda-list lambda-expr)))) (arg-p (length (get fname 'proclaimed-arg-types))) (va (member '* (get fname 'proclaimed-arg-types)))) (cond (va (or (>= arg-c) (- arg-p (length va)) (cmpwarn "~a needs ~a args. ~a supplied." fname (- arg-p (length va)) arg-c))) ((not (eql arg-c arg-p)) (cmpwarn "~%;; ~a Number of proclaimed args was ~a. ~ ~%;;Its definition had ~a." fname arg-p arg-c)) ;((>= arg-c 10.)) ;checked above ;(cmpwarn " t1defun only likes 10 args ~ ; ~%for proclaimed functions") (t (cmpwarn " ~a is proclaimed but not in *inline-functions* ~ ~%T1defun could not assure suitability of args for C call" fname )))) nil))))) (defun volatile (info) (if (info-volatile info) "VOL " "")) (defun register (var) (cond ((and (equal *volatile* "") (>= (the fixnum (var-register var)) (the fixnum *register-min*))) "register ") (t ""))) (defun vararg-p (x) (and (equal (get x 'proclaimed-return-type) t) (do ((v (get x 'proclaimed-arg-types) (cdr v))) ((null v) t) (or (consp v) (return nil)) (or (eq (car v) t) (eq (car v) '*) (return nil))))) (defun maxargs (lambda-list) ; any function can take &allow-other-keys in ANSI lisp (cond ( ; (or (ll-allow-other-keys lambda-list)(ll-rest lambda-list)) (or (ll-keywords-p lambda-list) (ll-rest lambda-list)) 64) (t (+ (length (car lambda-list)) ;reg (length (ll-optionals lambda-list)) (* 2 (length (ll-keywords lambda-list))))))) (defun add-address (a) ;; if need ampersand before function for address ;; (setq a (string-concatenate "&" a)) (push (list a) *vaddress-list*) (prog1 *vind* (incf *vind*))) (defun t2defun (fname cfun lambda-expr doc sp) (declare (ignore cfun lambda-expr doc sp)) (cond ((get fname 'no-global-entry)(return-from t2defun nil))) (cond ((< *space* 2) (setf (get fname 'debug-prop) t) ))) (defun si::add-debug (fname x) (si::putprop fname x 'si::debug)) (defun t3init-fun (fname cfun lambda-expr doc) (when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation))) (cond ((wt-if-proclaimed fname cfun lambda-expr)) ((vararg-p fname) (let ((keyp (ll-keywords-p (lambda-list lambda-expr)))) ; (wt-h "static object LI" cfun "();") (if keyp (add-init `(si::mfvfun-key ',fname ,(add-address (c-function-name "LI" cfun fname)) ,(vargd (length (car (lambda-list lambda-expr))) (maxargs (lambda-list lambda-expr))) ,(add-address (format nil "&LI~akey" cfun))) ) (add-init `(si::mfvfun ',fname ,(add-address (c-function-name "LI" cfun fname)) ,(vargd (length (car (lambda-list lambda-expr))) (maxargs (lambda-list lambda-expr)))) )))) ((numberp cfun) (wt-h "static void " (c-function-name "L" cfun fname) "();") (add-init `(si::mf ',fname ,(add-address (c-function-name "L" cfun fname))))) (t (wt-h cfun "();") (add-init `(si::mf ',fname ,(add-address (c-function-name "" cfun fname))))))) (defun t3defun (fname cfun lambda-expr doc sp &aux inline-info (*current-form* (list 'defun fname)) (*volatile* (volatile (second lambda-expr))) *downward-closures*) (cond ((dolist (v *inline-functions*) (or (si::fixnump (nth 3 v)) (error "Old style inline")) (and (eq (car v) fname) (not (nth 5 v)) ; ie.not 'link-call or 'ifuncall (return (setq inline-info v)))) ;;; Add global entry information. (when (not (fast-link-proclaimed-type-p fname)) (push (list fname cfun (cadr inline-info) (caddr inline-info)) *global-entries*)) ;;; Local entry (analyze-regs (cadr lambda-expr) 0) (t3defun-aux 't3defun-local-entry (case (caddr inline-info) (fixnum 'return-fixnum) (character 'return-character) (long-float 'return-long-float) (short-float 'return-short-float) (otherwise 'return-object)) fname cfun lambda-expr sp inline-info )) ((vararg-p fname) (analyze-regs (cadr lambda-expr) 0) (t3defun-aux 't3defun-vararg 'return-object fname cfun lambda-expr sp)) (t (analyze-regs (cadr lambda-expr) 2) (t3defun-aux 't3defun-normal 'return fname cfun lambda-expr sp))) (wt-downward-closure-macro cfun) (t3init-fun fname cfun lambda-expr doc) (add-debug-info fname lambda-expr)) (defun t3defun-aux (f *exit* &rest lis) (let-pass3 () (apply f lis))) (defun t3defun-local-entry (fname cfun lambda-expr sp inline-info &aux specials (requireds (caaddr lambda-expr))) (do ((vl requireds (cdr vl)) (types (cadr inline-info) (cdr types))) ((endp vl)) (declare (object vl types)) (cond ((eq (var-kind (car vl)) 'special) (push (cons (car vl) (var-loc (car vl))) specials)) (t (setf (var-kind (car vl)) (case (car types) (fixnum 'FIXNUM) (character 'CHARACTER) (long-float 'LONG-FLOAT) (short-float 'SHORT-FLOAT) (otherwise 'OBJECT)))) ) (setf (var-loc (car vl)) (next-cvar))) (wt-comment "local entry for function " fname) (wt-h "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "();") (wt-nl1 "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "(") (wt-requireds requireds (cadr inline-info)) ;;; Now the body. (let ((cm *reservation-cmacro*) (*tail-recursion-info* (if *do-tail-recursion* (cons fname requireds) nil)) (*unwind-exit* *unwind-exit*)) (wt-nl1 "{ ") (assign-down-vars (cadr lambda-expr) cfun 't3defun) (wt " VMB" cm " VMS" cm " VMV" cm) (when sp (wt-nl "bds_check;")) (when *compiler-push-events* (wt-nl "ihs_check;")) (when *tail-recursion-info* (push 'tail-recursion-mark *unwind-exit*) (wt-nl "goto TTL;") (wt-nl1 "TTL:;")) (dolist (v specials) (wt-nl "bds_bind(" (vv-str (cdr v)) ",V" (var-loc (car v)) ");") (push 'bds-bind *unwind-exit*) (setf (var-kind (car v)) 'SPECIAL) (setf (var-loc (car v)) (cdr v))) (c2expr (caddr (cddr lambda-expr))) ;;; Use base if defined for lint (if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) t (wt-nl "base[0]=base[0];")) ;;; Make sure to return object if necessary (if (equal "object " (rep-type (caddr inline-info))) (wt-nl "return Cnil;")) (wt-nl1 "}") (wt-V*-macros cm (caddr inline-info)) )) (defvar *vararg-use-vs* nil) (defun set-up-var-cvs (var) (cond (*vararg-use-vs* (setf (var-ref var) (vs-push))) ; ((numberp (var-loc var))) (t (setf (var-ref var) (cvs-push))))) (defun t3defun-vararg (fname cfun lambda-expr sp &aux reqs *vararg-use-vs* block-p labels (deflt t) key-offset (*inline-blocks* 0) rest-var (ll (lambda-list lambda-expr)) (is-var-arg (or (ll-rest ll) (ll-optionals ll) (ll-keywords-p ll))) (first (unless (car ll) is-var-arg))) (dolist (v (car ll)) (push (list 'cvar (next-cvar)) reqs)) (wt-comment "local entry for function " fname) (let ((tmp "")) (wt-nl1 "static object " (c-function-name "LI" cfun fname) "(") (when reqs (do ((v reqs (cdr v))) ((null v)) (wt "object " (car v)) (setq tmp (concatenate 'string tmp "object")) (or (null (cdr v)) (progn (wt ",") (setq tmp (concatenate 'string tmp ",")))))) (when is-var-arg (when first (wt "object first") (setq tmp (concatenate 'string tmp "object"))) (wt ",...") (setq tmp (concatenate 'string tmp ",..."))) (wt ")") (wt-h "static object " (c-function-name "LI" cfun fname) "(" tmp ");")) ; (when reqs (wt-nl "object ") ; (wt-list reqs) (wt ";")) ; (if is-var-arg (wt-nl "va_dcl ")) ;;; Now the body. (let ((cm *reservation-cmacro*) (*tail-recursion-info* ;; to do: When can we do tail recursion? ;; Should be able to do the optionals case, where the ;; optional defaults are constants. But this ;; is probably not worth it. (and *do-tail-recursion* (not (ll-rest ll)) (dolist* (var (ll-requireds ll) t) (when (var-ref-ccb var) (return nil))) (null (ll-optionals ll)) (null (ll-keywords ll)) (cons fname (car ll)))) (*unwind-exit* *unwind-exit*)) (wt-nl1 "{ ") (when is-var-arg (wt-nl "va_list ap;")) (wt-nl "int narg = VFUN_NARGS;") (assign-down-vars (cadr lambda-expr) cfun 't3defun) (wt " VMB" cm " VMS" cm " VMV" cm) (when sp (wt-nl "bds_check;")) (when *compiler-push-events* (wt-nl "ihs_check;")) (or is-var-arg (wt-nl "if ( narg!= " (length reqs) ") vfun_wrong_number_of_args(small_fixnum(" (length reqs) "));")) (flet ((do-decl (var) (and (eql (var-loc var) 'clb) (setf *vararg-use-vs* t)) (let ((kind (c2var-kind var))) (declare (object kind)) (when kind (let ((cvar (next-cvar))) (setf (var-kind var) kind) (setf (var-loc var) cvar) (wt-nl) (unless block-p (wt "{") (setq block-p t)) (wt-var-decl var) ))))) (dolist** (var (car ll)) (do-decl var)) (dolist** (opt (ll-optionals ll)) (do-decl (car opt)) (when (caddr opt) (do-decl (caddr opt)))) (when (ll-rest ll) (do-decl (ll-rest ll))) (dolist** (kwd (ll-keywords ll)) (do-decl (cadr kwd)) (when (cadddr kwd) (do-decl (cadddr kwd)))) ) ;;; Use Vcs for lint ; (if *vararg-use-vs* t (progn (wt-nl "Vcs[0]=Vcs[0];"))) ;;; start va_list at beginning (when is-var-arg (wt-nl "va_start(ap," (if first "first" (car (last reqs))) ");")) ;;; Check arguments. (when (and (or *safe-compile* *compiler-check-args*) (car ll)) (wt-nl "if(narg <" (length (car ll)) ") too_few_arguments();")) ;;; Allocate the parameters. (dolist** (var (car ll)) (set-up-var-cvs var)) (dolist** (opt (ll-optionals ll)) (set-up-var-cvs (car opt))) (when (ll-rest ll) (set-up-var-cvs (ll-rest ll))) (setf key-offset (if *vararg-use-vs* *vs* *cs*)) (dolist** (kwd (ll-keywords ll)) (set-up-var-cvs (cadr kwd))) (dolist** (kwd (ll-keywords ll)) (set-up-var-cvs (cadddr kwd))) ;;bind the params: (do ((v reqs (cdr v)) (vl (car ll) (cdr vl))) ((null v)) (c2bind-loc (car vl) (car v))) (when (ll-optionals ll) (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (wt-nl "narg = narg - " (length reqs) ";") (dolist** (opt (ll-optionals ll)) (push (next-label) labels) (wt-nl "if (" (if (cdr labels) "--" "") "narg <= 0) ") (wt-go (car labels)) (wt-nl "else {" ) (c2bind-loc (car opt) (if first (list 'first-var-arg) (list 'next-var-arg))) (setq first nil) (wt "}") (when (caddr opt) (c2bind-loc (caddr opt) t)))) (setq labels (nreverse labels)) (let ((label (next-label))) (wt-nl "--narg; ") (wt-go label) ;;; Bind unspecified optional parameters. (dolist** (opt (ll-optionals ll)) (wt-label (car labels)) (pop labels) (c2bind-init (car opt) (cadr opt)) (when (caddr opt) (c2bind-loc (caddr opt) nil))) ; (if (or (ll-rest ll)(ll-keywords-p ll))(wt-nl "narg=0;")) (wt-label label) )) (if (ll-rest ll) (progn (setq rest-var (cs-push)) (cond ((ll-optionals ll)) (t (wt-nl "narg= narg - " (length (car ll)) ";"))) (wt-nl "V" rest-var " = ") (let ((*rest-on-stack* (or (eq (var-type (ll-rest ll)) :dynamic-extent) *rest-on-stack*))) (if (ll-keywords-p ll) (cond (*rest-on-stack* (wt "(ALLOCA_CONS(narg),ON_STACK_MAKE_LIST(narg));")) (t (wt "make_list(narg);"))) (cond (*rest-on-stack* (wt "(ALLOCA_CONS(narg),ON_STACK_LIST_VECTOR_NEW(narg," (if first "first" "OBJNULL") ",ap));" )) (t (wt "list_vector_new(narg," (if first "first" "OBJNULL") ",ap);")))) (c2bind-loc (ll-rest ll) (list 'cvar rest-var))))) (when (ll-keywords-p ll) (cond ((ll-rest ll)) ((ll-optionals ll)) (t (wt-nl "narg= narg - " (length (car ll)) ";"))) (setq deflt (mapcar 'caddr (ll-keywords ll))) (let ((vkdefaults nil) (n (length (ll-keywords ll)))) (do* ((v deflt (cdr v)) (kwds (ll-keywords ll) (cdr kwds)) (kwd (car kwds) (car kwds))) ((null v)) (unless (and (eq (caar v) 'location) (eq (third (car v)) nil)) (setq vkdefaults t)) (when (or (not (and (eq (caar v) 'location) (let ((tem (third (car v)))) (or (eq tem nil) (and (consp tem) (member (car tem) '(vv fixnum-value)) ))))) ;; the supplied-p variable is not there (not (eq (var-kind (cadddr kwd)) 'DUMMY))) (setf Vkdefaults t) (setf (car v) 0))) (if (> (length deflt) 15) (setq vkdefaults t)) (wt-nl "{") (inc-inline-blocks) (let ((*compiler-output1* *compiler-output2*)) (when vkdefaults (terpri *compiler-output2*) (wt "static object VK" cfun "defaults[" (length deflt) "]={") (do ((v deflt(cdr v))(tem)) ((null v)) (wt "(void *)") (cond ((eql (car v) 0) (wt "-1")) ;; must be location ((and (eq (setq tem (third (car v))) nil)) (wt "-2")) ((and (consp tem) (eq (car tem) 'vv)) (wt (add-object2 (add-object (second tem))) )) ((and (consp tem) (eq (car tem) 'fixnum-value)) ; (print (setq ttem tem)) (break) (wt (add-object2 (add-object (third tem))) )) (t (baboon))) (if (cdr v) (wt ","))) (wt "};")) (terpri *compiler-output2*) (wt "static struct { short n,allow_other_keys;" "object *defaults;") (wt-nl " KEYTYPE keys[" (max n 1) "];") (wt "} " "LI" cfun "key=") (wt "{" (length (ll-keywords ll)) "," (if (ll-allow-other-keys ll) 1 0) ",") (if vkdefaults (wt "VK" cfun "defaults") (wt "Cstd_key_defaults")) (when (ll-keywords ll) (wt ",{") (do ((v (reverse (ll-keywords ll)) (cdr v))) ((null v)) ;; We write this list backwards for convenience ;; in stepping through it in parse_key (wt "(void *)") ; (print (setq ss v))(break "h") (wt (add-object2 (add-symbol (caar v)))) (if (cdr v) (wt ","))) (wt "}")) (wt "};") ) (cond ((ll-rest ll) (wt-nl "parse_key_rest_new(" (list 'cvar rest-var) ",")) (t (wt-nl "parse_key_new_new("))) (if (eql 0 *cs*)(setq *cs* 1)) (wt "narg," (if *vararg-use-vs* "base " (progn (setq *vcs-used* t) "Vcs ")) "+" key-offset",(struct key *)(void *)&LI" cfun "key," (if first "first" "OBJNULL") ",ap);") )) ;; bind keywords (dolist** (kwd (ll-keywords ll)) (cond ((not (eql 0 (pop deflt))) ;; keyword default bound by parse_key.. and no supplied-p (c2bind (cadr kwd))) (t (wt-nl "if(") (wt-vs (var-ref (cadr kwd))) (wt "==OBJNULL){") (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (c2bind-init (cadr kwd) (caddr kwd))) (unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind-loc (cadddr kwd) nil)) (wt-nl "}else{") (c2bind (cadr kwd)) (unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind-loc (cadddr kwd) t)) (wt "}"))) ) (when *tail-recursion-info* (push 'tail-recursion-mark *unwind-exit*) (wt-nl "goto TTL;") (wt-nl1 "TTL:;")) (c2expr (caddr (cddr lambda-expr))) ;;; End va_list at function end (when is-var-arg (wt-nl "va_end(ap);")) ;;; Use base if defined for lint (if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) t (wt-nl "base[0]=base[0];")) ;;; Need to ensure return of type object (wt-nl "return Cnil;") (wt "}") (when block-p (wt-nl "}")) (close-inline-blocks) (wt-V*-macros cm (get fname 'proclaimed-return-type)) )) (defun t3defun-normal (fname cfun lambda-expr sp) (wt-comment "function definition for " fname) (if (numberp cfun) (wt-nl1 "static void " (c-function-name "L" cfun fname) "()") (wt-nl1 cfun "()")) (wt-nl1 "{" "register object *" *volatile*"base=vs_base;") (assign-down-vars (cadr lambda-expr) cfun 't3defun) (wt-nl "register object *" *volatile*"sup=base+VM" *reservation-cmacro* ";") (wt " VC" *reservation-cmacro*) (if *safe-compile* (wt-nl "vs_reserve(VM" *reservation-cmacro* ");") (wt-nl "vs_check;")) (when sp (wt-nl "bds_check;")) (when *compiler-push-events* (wt-nl "ihs_check;")) (c2lambda-expr (lambda-list lambda-expr) (caddr (cddr lambda-expr)) fname) (wt-nl1 "}") (push (cons *reservation-cmacro* *max-vs*) *reservations*) (wt-h "#define VC" *reservation-cmacro*) (wt-cvars) ) ;;Macros for conditionally writing vs_base ..preamble, and for setting ;;up the return. (defun wt-V*-macros (cm return-type) (declare (ignore return-type)) (push (cons cm *max-vs*) *reservations*) (if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) ;;note if (proclaim '(function foo () t)) ;;(defun foo () (goo)) ;then *max-vs*=0,*sup-used*=t;--wfs (wt-h "#define VMB" cm) (wt-h "#define VMB" cm " " "register object *" *volatile*"base=vs_top;")) ;;tack following onto the VMB macro.. (wt-cvars) (if *sup-used* (wt-h "#define VMS" cm " " " register object *" *volatile*"sup=vs_top+" *max-vs* ";vs_top=sup;") (if (zerop *max-vs*) (wt-h "#define VMS" cm) (wt-h "#define VMS" cm " vs_top += " *max-vs* ";"))) (if (zerop *max-vs*) (wt-h "#define VMV" cm) (if *safe-compile* (wt-h "#define VMV" cm " vs_reserve(" *max-vs* ");") (wt-h "#define VMV" cm " vs_check;"))) (if (zerop *max-vs*) (wt-h "#define VMR" cm "(VMT" cm ") return(VMT" cm ");") (wt-h "#define VMR" cm "(VMT" cm ") vs_top=base ; return(VMT" cm ");")) ) ;;Write the required args as c arguments, and declarations for the arguments. (defun wt-requireds (requireds arg-types) (do ((vl requireds (cdr vl))) ((endp vl)) (declare (object vl)) (let ((cvar (next-cvar))) (setf (var-loc (car vl)) cvar) (wt "V" cvar)) (unless (endp (cdr vl)) (wt ","))) (wt ") ") (when requireds (wt-nl1) (do ((vl requireds (cdr vl)) (types arg-types (cdr types)) (prev-type nil)) ((endp vl) (wt ";")) (declare (object vl)) (if prev-type (wt ";")) (wt *volatile* (register (car vl)) (rep-type (car types))) (setq prev-type (car types)) (wt "V" (var-loc (car vl)))))) (defun add-debug-info (fname lambda-expr &aux locals) (cond ((>= *space* 2)) ((null (get fname 'debug-prop)) (warn "~a has a duplicate definition in this file" fname)) (t (remprop fname 'debug-prop) (let ((leng 0)) (do-referred (va (second lambda-expr)) (when (and (consp (var-ref va)) (si::fixnump (cdr (var-ref va)))) (setq leng (max leng (cdr (var-ref va)))))) (setq locals (make-list (1+ leng))) (do-referred (va (second lambda-expr)) (when (and (consp (var-ref va)) ;always fixnum ? (si::fixnump (cdr (var-ref va)))) (setf (nth (cdr (var-ref va)) locals) (var-name va)))) (setf (get fname 'si::debug) locals) (let ((locals (get fname 'si::debug))) (if (and locals (or (cdr locals) (not (null (car locals))))) (add-init `(si::debug ',fname ',locals) ) )) )))) ;;Checks the register slots of variables, and finds which ;;variables should be in registers, zero'ing the register slot ;;in the remaining. Data and address variables are done separately. (defun analyze-regs (info for-sup-base) (let ((addr-regs (- *free-address-registers* for-sup-base))) (cond ((zerop *free-data-registers*) (analyze-regs1 info addr-regs)) (t (let ((addr (make-info)) (data (make-info))) (do-referred (v info) (cond ((member (var-type v) '(FIXNUM CHARACTER SHORT-FLOAT LONG-FLOAT) :test #'eq) (push-referred v data)) (t (push-referred v addr)))) (analyze-regs1 addr addr-regs) (analyze-regs1 data *free-data-registers*)))))) (defun analyze-regs1 (info want ) (let ((tem 0)(real-min 3)(this-min 100000)(want want)(have 0)) (declare (fixnum tem real-min this-min want have)) (tagbody START (do-referred (v info) (setq tem (var-register v)) (cond ((>= tem real-min) (setq have (the fixnum (+ have 1))) (cond ((< tem this-min ) (setq this-min tem))) (cond ((> have want) (go NEXT))) ))) (cond ((< have want) (setq real-min (- real-min 1)))) (do-referred (v info) (cond ((< (the fixnum (var-register v)) real-min) (setf (var-register v) 0)))) (return-from analyze-regs1 real-min) NEXT (setq have 0) (setq real-min (the fixnum (+ this-min 1))) (setq this-min 1000000) (go START) ))) (defun wt-global-entry (fname cfun arg-types return-type) (cond ((get fname 'no-global-entry)(return-from wt-global-entry nil))) (wt-comment "global entry for the function " fname) (wt-nl1 "static void " (c-function-name "L" cfun fname) "()") (wt-nl1 "{ register object *base=vs_base;") (when (or *safe-compile* *compiler-check-args*) (wt-nl "check_arg(" (length arg-types) ");")) (wt-nl "base[0]=" (case return-type (fixnum (if (zerop *space*) "CMPmake_fixnum" "make_fixnum")) (character "code_char") (long-float "make_longfloat") (short-float "make_shortfloat") (otherwise "")) "(" (c-function-name "LI" cfun fname) "(") (do ((types arg-types (cdr types)) (n 0 (1+ n))) ((endp types)) (declare (object types) (fixnum n)) (wt (case (car types) (fixnum "fix") (character "char_code") (long-float "lf") (short-float "sf") (otherwise "")) "(base[" n "])") (unless (endp (cdr types)) (wt ","))) (wt "));") (wt-nl "vs_top=(vs_base=base)+1;") (wt-nl1 "}") ) (defun rep-type (type) (case type (fixnum "long ") (integer "MP_INT * ") (character "unsigned char ") (short-float "float ") (long-float "double ") (otherwise "object "))) (defun t1defmacro (args) (when (or (endp args) (endp (cdr args))) (too-few-args 'defmacro 2 (length args))) (cmpck (not (symbolp (car args))) "The macro name ~s is not a symbol." (car args)) (maybe-eval t (cons 'defmacro args)) (setq *non-package-operation* t) (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil) (*sharp-commas* nil) (*special-binding* nil) macro-lambda (cfun (next-cfun))) (setq macro-lambda (c1dm (car args) (cadr args) (cddr args))) (add-load-time-sharp-comma) (push (list 'defmacro (car args) cfun (cddr macro-lambda) (car macro-lambda) ;doc (cadr macro-lambda) ; ppn *special-binding*) *top-level-forms*)) ) (defun t2defmacro (fname cfun macro-lambda doc ppn sp) (declare (ignore macro-lambda doc ppn sp)) (wt-h "static void " (c-function-name "L" cfun fname) "();") ) (defun t3defmacro (fname cfun macro-lambda doc ppn sp &aux (*volatile* (if (get fname 'contains-setjmp) " VOL " ""))) (let-pass3 ((*exit* 'return)) (wt-comment "macro definition for " fname) (wt-nl1 "static void " (c-function-name "L" cfun fname) "()") (wt-nl1 "{register object *" *volatile* "base=vs_base;") (assign-down-vars (nth 4 macro-lambda) cfun ;*dm-info* 't3defun) (wt-nl "register object *"*volatile* "sup=base+VM" *reservation-cmacro* ";") (wt " VC" *reservation-cmacro*) (if *safe-compile* (wt-nl "vs_reserve(VM" *reservation-cmacro* ");") (wt-nl "vs_check;")) (when sp (wt-nl "bds_check;")) (when *compiler-push-events* (wt-nl "ihs_check;")) (c2dm (car macro-lambda) (cadr macro-lambda) (caddr macro-lambda) (cadddr macro-lambda)) (wt-nl1 "}") (push (cons *reservation-cmacro* *max-vs*) *reservations*) (wt-h "#define VC" *reservation-cmacro*) (wt-cvars) (when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation) )) (when ppn (add-init `(si::putprop ',fname ',ppn 'si::pretty-print-format) )) (add-init `(si::MM ',fname ,(add-address (c-function-name "L" cfun fname))) ) )) (defun t1ordinary (form &aux tem ) (setq *non-package-operation* t) ;; check for top level functions (cond ((or *compile-ordinaries* (when (listp form) (member (car form) '(let let* flet labels)))) (maybe-eval nil form) (let ((gen (gensym "progn 'compile"))) (proclaim `(function ,gen nil t)) (t1expr `(defun ,gen (), form nil)) (push (list 'ordinary `(,gen) ) *top-level-forms*))) ;;Hack to things like (setq bil #'(lambda () ...)) or (foo nil #'(lambda () ..)) ;; but not (let ((x ..)) (setq bil #'(lambda () ..))) ;; for the latter you must use (progn 'compile ...) ((and (consp form) (symbolp (car form)) (or (eq (car form) 'setq) (not (special-form-p (car form)))) (do ((v (cdr form) (and (consp v) (cdr v))) (i 1 (the fixnum (+ 1 i)))) ((or (>= i 1000) (not (consp v))) nil) (declare (fixnum i)) (cond ((and (consp (car v)) (eq (caar v) 'function) (consp (setq tem (second (car v)))) (eq (car tem) 'lambda)) (let ((gen (gensym))) (t1expr `(defun ,gen ,@ (cdr tem))) (return-from t1ordinary (t1ordinary (append (subseq form 0 i) `((symbol-function ', gen)) (nthcdr (+ 1 i) form)))))))))) (t (maybe-eval nil form) (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil) (*sharp-commas* nil)) (push (list 'ordinary form) *top-level-forms*) nil )))) (defun t3ordinary (form) (cond ((atom form)) ((constantp form)) (t (add-init form )))) (defun add-load-time-sharp-comma () (dolist* (vv (reverse *sharp-commas*)) (cond ((atom vv) (wfs-error))) (push (cons 'sharp-comma vv) *top-level-forms*))) (defun t3sharp-comma (vv val) (add-init `(si::setvv ,vv ,val) )) (defun t2declare (vv) vv (wfs-error)) ;; Some top level functions which should be eval'd in the :default case ;; for eval-when (setf (get 'si::*make-special 'eval-at-compile) t) (setf (get 'si::*make-constant 'eval-at-compile) t) (setf (get 'proclaim 'eval-at-compile) t) (setf (get 'si::define-structure 't1) 't1define-structure) (defun t1define-structure (args) (maybe-eval t `(si::define-structure ,@args ,(not (maybe-eval nil nil)))) (t1ordinary (cons 'si::define-structure args))) (si:putprop 'dbind 'set-dbind 'set-loc) (defun set-dbind (loc vv) (wt-nl (vv-str vv) "->s.s_dbind = " loc ";")) (defun t1clines (args) (dolist** (s args) (cmpck (not (stringp s)) "The argument to CLINE, ~s, is not a string." s)) (push (list 'clines args) *top-level-forms*)) (defun t3clines (ss) (dolist** (s ss) (wt-nl1 s))) (defun t1defcfun (args &aux (body nil)) (when (or (endp args) (endp (cdr args))) (too-few-args 'defcfun 2 (length args))) (cmpck (not (stringp (car args))) "The first argument to defCfun ~s is not a string." (car args)) (cmpck (not (numberp (cadr args))) "The second argument to defCfun ~s is not a number." (cadr args)) (dolist** (s (cddr args)) (cond ((stringp s) (push s body)) ((consp s) (cond ((symbolp (car s)) (cmpck (special-form-p (car s)) "Special form ~s is not allowed in defCfun." (car s)) (push (list (cons (car s) (parse-cvspecs (cdr s)))) body)) ((and (consp (car s)) (symbolp (caar s)) (not (if (eq (caar s) 'quote) (or (endp (cdar s)) (not (endp (cddar s))) (endp (cdr s)) (not (endp (cddr s)))) (special-form-p (caar s))))) (push (cons (cons (caar s) (if (eq (caar s) 'quote) (list (add-object (cadar s))) (parse-cvspecs (cdar s)))) (parse-cvspecs (cdr s))) body)) (t (cmperr "The defCfun body ~s is illegal." s)))) (t (cmperr "The defCfun body ~s is illegal." s)))) (push (list 'defcfun (car args) (cadr args) (nreverse body)) *top-level-forms*) ) (defun t3defcfun (header vs-size body &aux fd) (wt-comment "C function defined by " 'defcfun) (wt-nl1 header) (wt-h header ";") (wt-nl1 "{") (wt-nl1 "object *vs=vs_top;") (when (> vs-size 0) (wt-nl1 "object *old_top=vs_top+" vs-size ";")(wt-nl "vs_top=old_top;")) (wt-nl1 "{") (dolist** (s body) (cond ((stringp s) (wt-nl1 s)) ((eq (caar s) 'quote) (wt-nl1 (cadadr s)) (case (caadr s) (object (wt "=" (vv-str (cadar s)) ";")) (otherwise (wt "=object_to_" (string-downcase (symbol-name (caadr s))) "(" (vv-str (cadar s)) ");")))) (t (wt-nl1 "{vs_base=vs_top=old_top;") (dolist** (arg (cdar s)) (wt-nl1 "vs_push(") (case (car arg) (object (wt (cadr arg))) (char (wt "code_char((long)" (cadr arg) ")")) (int (when (zerop *space*) (wt "CMP")) (wt "make_fixnum((long)(" (cadr arg) "))")) (float (wt "make_shortfloat((double)" (cadr arg) ")")) (double (wt "make_longfloat((double)" (cadr arg) ")"))) (wt ");")) (cond ((setq fd (assoc (caar s) *global-funs*)) (cond (*compiler-push-events* (wt-nl1 "ihs_push(" (vv-str (add-symbol (caar s))) ");") (wt-nl1 (c-function-name "L" (cdr fd) (caar s)) "();") (wt-nl1 "ihs_pop();")) (t (wt-nl1 (c-function-name "L" (cdr fd) (caar s)) "();")))) (*compiler-push-events* (wt-nl1 "super_funcall(" (vv-str (add-symbol (caar s))) ");")) (*safe-compile* (wt-nl1 "super_funcall_no_event(" (vv-str (add-symbol (caar s))) ");")) (t (wt-nl1 "CMPfuncall(" (vv-str (add-symbol (caar s))) "->s.s_gfdef);")) ) (unless (endp (cdr s)) (wt-nl1 (cadadr s)) (case (caadr s) (object (wt "=vs_base[0];")) (otherwise (wt "=object_to_" (string-downcase (symbol-name (caadr s))) "(vs_base[0]);"))) (dolist** (dest (cddr s)) (wt-nl1 "vs_base++;") (wt-nl1 (cadr dest)) (case (car dest) (object (wt "=(vs_base= (type1 type2) (equal (type-and type1 type2) type2)) (defun reset-info-type (info) (if (info-type info) (let ((info1 (copy-info info))) (setf (info-type info1) t) info1) info)) (defun and-form-type (type form original-form &aux type1) (setq type1 (type-and type (info-type (cadr form)))) (when (null type1) (cmpwarn "The type of the form ~s is not ~s." original-form type)) (if (eq type1 (info-type (cadr form))) form (let ((info (copy-info (cadr form)))) (setf (info-type info) type1) (list* (car form) info (cddr form))))) (defun check-form-type (type form original-form) (when (null (type-and type (info-type (cadr form)))) (cmpwarn "The type of the form ~s is not ~s." original-form type))) (defun default-init (type) (case type (fixnum (cmpwarn "The default value of NIL is not FIXNUM.")) (character (cmpwarn "The default value of NIL is not CHARACTER.")) (long-float (cmpwarn "The default value of NIL is not LONG-FLOAT.")) (short-float (cmpwarn "The default value of NIL is not SHORT-FLOAT.")) (integer (cmpwarn "The default value of NIL is not INTEGER")) ) (c1nil)) gcl/cmpnew/gcl_cmputil.lsp000077500000000000000000000164731242227143400161550ustar00rootroot00000000000000;;; CMPUTIL Miscellaneous Functions. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (export '(*suppress-compiler-warnings* *suppress-compiler-notes* *compiler-break-enable*)) (defmacro safe-compile (&rest forms) `(when *safe-compile* ,@forms)) (defvar *current-form* '|compiler preprocess|) (defvar *first-error* t) (defvar *error-count* 0) (defconstant *cmperr-tag* (cons nil nil)) (defun cmperr (string &rest args &aux (*print-case* :upcase)) (print-current-form) (format t "~&;;; ") (apply #'format t string args) (incf *error-count*) (throw *cmperr-tag* '*cmperr-tag*)) (defmacro cmpck (condition string &rest args) `(if ,condition (cmperr ,string ,@args))) (defun too-many-args (name upper-bound n &aux (*print-case* :upcase)) (print-current-form) (format t ";;; ~S requires at most ~R argument~:p, ~ but ~R ~:*~[were~;was~:;were~] supplied.~%" name upper-bound n) (incf *error-count*) (throw *cmperr-tag* '*cmperr-tag*)) (defun too-few-args (name lower-bound n &aux (*print-case* :upcase)) (print-current-form) (format t ";;; ~S requires at least ~R argument~:p, ~ but only ~R ~:*~[were~;was~:;were~] supplied.~%" name lower-bound n) (incf *error-count*) (throw *cmperr-tag* '*cmperr-tag*)) (defvar *suppress-compiler-warnings* nil) (defun cmpwarn (string &rest args &aux (*print-case* :upcase)) (unless *suppress-compiler-warnings* (print-current-form) (format t ";; Warning: ") (apply #'format t string args) (terpri)) nil) (defvar *suppress-compiler-notes* nil) (defun cmpnote (string &rest args &aux (*print-case* :upcase)) (unless *suppress-compiler-notes* (terpri) (format t ";; Note: ") (apply #'format t string args)) nil) (defun print-current-form () (when *first-error* (setq *first-error* nil) (fresh-line) (cond ((and (consp *current-form*) (eq (car *current-form*) 'si:|#,|)) (format t "; #,~s is being compiled.~%" (cdr *current-form*))) (t (let ((*print-length* 2) (*print-level* 2)) (format t "; ~s is being compiled.~%" *current-form*))))) nil) (defun undefined-variable (sym &aux (*print-case* :upcase)) (print-current-form) (format t ";; The variable ~s is undefined.~%~ ;; The compiler will assume this variable is a global.~%" sym) nil) (defun baboon (&aux (*print-case* :upcase)) (print-current-form) (format t ";;; A bug was found in the compiler. Contact Taiichi.~%") (incf *error-count*) (break) ; (throw *cmperr-tag* '*cmperr-tag*) ) ;;; Internal Macros with type declarations (defmacro dolist* ((v l &optional (val nil)) . body) (let ((temp (gensym))) `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp))) ((endp ,temp) ,val) (declare (object ,v)) ,@body))) (defmacro dolist** ((v l &optional (val nil)) . body) (let ((temp (gensym))) `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp))) ((endp ,temp) ,val) (declare (object ,temp ,v)) ,@body))) (defmacro dotimes* ((v n &optional (val nil)) . body) (let ((temp (gensym))) `(do* ((,temp ,n) (,v 0 (1+ ,v))) ((>= ,v ,temp) ,val) (declare (fixnum ,v)) ,@body))) (defmacro dotimes** ((v n &optional (val nil)) . body) (let ((temp (gensym))) `(do* ((,temp ,n) (,v 0 (1+ ,v))) ((>= ,v ,temp) ,val) (declare (fixnum ,temp ,v)) ,@body))) (defun cmp-eval (form) (let ((x (multiple-value-list (cmp-toplevel-eval `(eval ',form))))) (if (car x) (let ((*print-case* :upcase)) (incf *error-count*) (print-current-form) (format t ";;; The form ~s was not evaluated successfully.~%~ ;;; You are recommended to compile again.~%" form) nil) (values-list (cdr x))))) ;(si::putprop 'setf 'c1setf 'c1special) ;;The PLACE may be a local macro, so we must take care to expand it ;;before trying to call the macro form of setf, or an error will ;(defun c1setf (args &aux fd) ; (cond ((and ; (consp (car args)) ; (symbolp (caar args)) ; (setq fd (cmp-macro-function (caar args)))) ; (c1expr `(setf ,(cmp-expand-macro fd (caar args) (cdar args)) ; ,@ (cdr args)))) ; (t ; (c1expr (cmp-expand-macro (macro-function 'setf) ; 'setf ; args))))) (defun macro-def-p (form &aux (fname (when (consp form) (car form)))) (when (symbolp fname) (or (member-if (lambda (x) (when (consp x) (eq (car x) fname))) *funs*) (macro-function fname)))) (defun do-macro-expansion (how form &aux env) (dolist (v *funs*) (when (consp v) (push (list (car v) 'macro (cadr v)) env))) (when env (setq env (list nil (nreverse env) nil))) (let ((x (multiple-value-list (cmp-toplevel-eval `(,@how ',form ',env))))) (if (car x) (let ((*print-case* :upcase)) (incf *error-count*) (print-current-form) (format t ";;; The macro form ~s was not expanded successfully.~%" form) `(error "Macro-expansion of ~s failed at compile time." ',form)) (cadr x)))) (defun cmp-macroexpand (form) (if (macro-def-p form) (do-macro-expansion '(macroexpand) form) form)) (defun cmp-macroexpand-1 (form) (if (macro-def-p form) (do-macro-expansion '(macroexpand-1) form) form)) (defun cmp-expand-macro (fd fname args &aux env (form (cons fname args))) (if (macro-def-p form) (do-macro-expansion `(funcall *macroexpand-hook* ',fd) form) form)) (defvar *compiler-break-enable* nil) (defun cmp-toplevel-eval (form) (let* ((si::*ihs-base* si::*ihs-top*) (si::*ihs-top* (1- (si::ihs-top))) (*break-enable* *compiler-break-enable*) (si::*break-hidden-packages* (cons (find-package 'compiler) si::*break-hidden-packages*))) (si:error-set form))) (dolist (v '(si::cdefn lfun inline-safe inline-unsafe inline-always c1conditional c2 c1 c1+ co1 si::structure-access co1special top-level-macro t3 t2 t1 package-operation)) (si::putprop v t 'compiler-prop )) (defun compiler-def-hook (symbol code) symbol code nil) (defun compiler-clear-compiler-properties (symbol code) code (let ((v (symbol-plist symbol)) w) (tagbody top (setq w (car v)) (cond ((and (symbolp w) (get w 'compiler-prop)) (setq v (cddr v)) (remprop symbol w)) (t (setq v (cddr v)))) (or (null v) (go top))) (compiler-def-hook symbol code) )) ;hi gcl/cmpnew/gcl_cmpvar.lsp000077500000000000000000000431761242227143400157700ustar00rootroot00000000000000;;; CMPVAR Variables. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (si:putprop 'var 'c2var 'c2) (si:putprop 'location 'c2location 'c2) (si:putprop 'setq 'c1setq 'c1special) (si:putprop 'setq 'c2setq 'c2) (si:putprop 'progv 'c1progv 'c1special) (si:putprop 'progv 'c2progv 'c2) (si:putprop 'psetq 'c1psetq 'c1) (si:putprop 'psetq 'c2psetq 'c2) (si:putprop 'var 'set-var 'set-loc) (si:putprop 'var 'wt-var 'wt-loc) (defstruct var name ;;; Variable name. kind ;;; One of LEXICAL, SPECIAL, GLOBAL, REPLACED, FIXNUM, ;;; CHARACTER, LONG-FLOAT, SHORT-FLOAT, and OBJECT. ref ;;; Referenced or not. ;;; During Pass1, T, NIL, or IGNORE. ;;; During Pass2, the vs-address for the variable. ref-ccb ;;; Cross closure reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the ccb-vs for the variable, or NIL. loc ;;; For SPECIAL and GLOBAL, the vv-index for variable name. ;;; For others, this field is used to indicate whether ;;; to be allocated on the value-stack: OBJECT means ;;; the variable is declared as OBJECT, and CLB means ;;; the variable is referenced across Level Boundary and thus ;;; cannot be allocated on the C stack. Note that OBJECT is ;;; set during variable binding and CLB is set when the ;;; variable is used later, and therefore CLB may supersede ;;; OBJECT. ;;; For REPLACED, the actual location of the variable. ;;; For FIXNUM, CHARACTER, LONG-FLOAT, SHORT-FLOAT, and ;;; OBJECT, the cvar for the C variable that holds the value. ;;; Not used for LEXICAL. (type t) ;;; Type of the variable. (register 0) ;;; If greater than specified am't this goes into register. ) ;;; A special binding creates a var object with the kind field SPECIAL, ;;; whereas a special declaration without binding creates a var object with ;;; the kind field GLOBAL. Thus a reference to GLOBAL may need to make sure ;;; that the variable has a value. (defvar *vars* nil) (defvar *register-min* 4) ;criteria for putting in register. (defvar *undefined-vars* nil) (defvar *special-binding* nil) ;;; During Pass 1, *vars* holds a list of var objects and the symbols 'CB' ;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on ;;; *vars* when the compiler begins to process a closure. 'LB' will be pushed ;;; on *vars* when *level* is incremented. ;;; *GLOBALS* holds a list of var objects for those variables that are ;;; not defined. This list is used only to suppress duplicated warnings when ;;; undefined variables are detected. (defun c1make-var (name specials ignores types &aux x) (let ((var (make-var :name name))) (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name) (cmpck (constantp name) "The constant ~s is being bound." name) (cond ((or (member name specials) (si:specialp name)) (setf (var-kind var) 'SPECIAL) (setf (var-loc var) (add-symbol name)) (cond ((setq x (assoc name types)) (setf (var-type var) (cdr x))) ((setq x (get name 'cmp-type)) (setf (var-type var) x))) (setq *special-binding* t)) (t (dolist** (v types) (cond ((eq (car v) name) (case (cdr v) (object (setf (var-loc var) 'object)) (register (setf (var-register var) (+ (var-register var) 100))) (t (setf (var-type var) (cdr v))))))) (and (boundp '*c-gc*) *c-gc* (or (null (var-type var)) (eq t (var-type var))) (setf (var-loc var) 'object)) (setf (var-kind var) 'LEXICAL))) (let ((ign (member name ignores))) (when ign (setf (var-ref var) (if (eq (cadr ign) 'ignorable) 'IGNORABLE 'IGNORE)))) var) ) (defun check-vref (var) (when (and (eq (var-kind var) 'LEXICAL) (not (var-ref var)) ;;; This field may be IGNORE. (not (var-ref-ccb var))) (cmpwarn "The variable ~s is not used." (var-name var)))) (defun c1var (name) (let ((info (make-info)) (vref (c1vref name))) (push-referred (car vref) info) (setf (info-type info) (var-type (car vref))) (list 'var info vref)) ) ;;; A variable reference (vref for short) is a pair ;;; ( var-object ccb-reference ) (defun c1vref (name &aux (ccb nil) (clb nil)) (declare (object ccb clb)) (dolist* (var *vars* (let ((var (sch-global name))) (unless var (unless (si:specialp name) (undefined-variable name)) (setq var (make-var :name name :kind 'GLOBAL :loc (add-symbol name) :type (or (get name 'cmp-type) t) )) (push var *undefined-vars*)) (list var ccb))) (cond ((eq var 'cb) (setq ccb t)) ((eq var 'lb) (setq clb t)) ((eq (var-name var) name) (when (eq (var-ref var) 'IGNORE) (cmpwarn "The ignored variable ~s is used." name) (setf (var-ref var) t)) (cond (ccb (setf (var-ref-ccb var) t)) (clb (when (eq (var-kind var) 'lexical) (setf (var-loc var) 'clb)) (setf (var-ref var) t)) (t (setf (var-ref var) t) (setf (var-register var) (the fixnum (+ 1 (the fixnum (var-register var))))) )) (return-from c1vref (list var ccb))))) ) (defun c2var-kind (var) (if (and (eq (var-kind var) 'LEXICAL) (not (var-ref-ccb var)) (not (eq (var-loc var) 'clb))) (if (eq (var-loc var) 'OBJECT) 'OBJECT (let ((type (var-type var))) (declare (object type)) (cond ((type>= 'fixnum type) 'FIXNUM) ; ((type>= 'integer type) 'INTEGER) ((type>= 'CHARACTER type) 'CHARACTER) ((type>= 'long-float type) 'LONG-FLOAT) ((type>= 'short-float type) 'SHORT-FLOAT) ((and (boundp '*c-gc*) *c-gc* 'OBJECT)) (t nil)))) nil) ) (defun c2var (vref) (unwind-exit (cons 'var vref) nil 'single-value)) (defun c2location (loc) (unwind-exit loc nil 'single-value)) (defun check-downward (info &aux no-down ) (dolist (v *local-functions*) (cond ((eq (car v) 'function) (setq no-down t) (dolist (w *local-functions*) (cond ((eq (car w) 'downward-function) (setf (car w) 'function)))) (return nil)))) (setq *local-functions* nil) (cond (no-down (do-referred (var info) (if (eq (var-kind var) 'down) (setf (var-kind var) 'lexical)))))) (defun assign-down-vars (info cfun inside &aux (ind 0) ) (do-referred (var info) (cond ((eq (var-kind var) 'down) ;;don't do twice since this list may have duplicates. (cond ((integerp (var-loc var) ) ;(or (integerp (var-ref var)) (print var)) (setq ind (max ind (1+ (var-loc var)))) (setf (var-ref var) (var-loc var)) ;delete later ) ;((integerp (var-loc var)) (break "bil")) (t (setf (var-ref var) ind) ;delete later (setf (var-loc var) ind) (setf ind (+ ind 1))))))) (cond ((> ind 0) ;;(wt-nl "object Dbase[" ind "];") (cond ((eq inside 't3defun) (wt-nl "object base0[" ind "];"))) ;DCnames gets defined at end whe (push 'dcnames *downward-closures*) (wt-nl "DCnames"cfun ""))) ind) (si::putprop 'down 'wt-down 'wt-loc) (defun wt-down (n) (or (si::fixnump n) (wfs-error)) (wt "base0[" n "]")) (defun wt-var (var ccb) (case (var-kind var) (LEXICAL (cond (ccb (wt-ccb-vs (var-ref-ccb var))) ((var-ref-ccb var) (wt-vs* (var-ref var))) ((and (eq t (var-ref var)) (si:fixnump (var-loc var)) *c-gc* (eq t (var-type var))) (setf (var-kind var) 'object) (wt-var var ccb)) (t (wt-vs (var-ref var))))) (SPECIAL (wt "(" (vv-str (var-loc var)) "->s.s_dbind)")) (REPLACED (wt (var-loc var))) (DOWN (wt-down (var-loc var))) (GLOBAL (if *safe-compile* (wt "symbol_value(" (vv-str (var-loc var)) ")") (wt "(" (vv-str (var-loc var)) "->s.s_dbind)"))) (t (case (var-kind var) (FIXNUM (when (zerop *space*) (wt "CMP")) (wt "make_fixnum")) (INTEGER (wt "make_integer")) (CHARACTER (wt "code_char")) (LONG-FLOAT (wt "make_longfloat")) (SHORT-FLOAT (wt "make_shortfloat")) (OBJECT) (t (baboon))) (wt "(V" (var-loc var) ")")) )) ;; When setting bignums across setjmps, cannot use alloca as longjmp ;; restores the C stack. FIXME -- only need malloc when reading variable ;; outside frame. CM 20031201 (defmacro bignum-expansion-storage () `(if (and (boundp '*unwind-exit*) (member 'frame *unwind-exit*)) "gcl_gmp_alloc" "alloca")) (defun set-var (loc var ccb) (unless (and (consp loc) (eq (car loc) 'var) (eq (cadr loc) var) (eq (caddr loc) ccb)) (case (var-kind var) (LEXICAL (wt-nl) (cond (ccb (wt-ccb-vs (var-ref-ccb var))) ((var-ref-ccb var) (wt-vs* (var-ref var))) (t (wt-vs (var-ref var)))) (wt "= " loc ";")) (SPECIAL (wt-nl "(" (vv-str (var-loc var)) "->s.s_dbind)= " loc ";")) (GLOBAL (if *safe-compile* (wt-nl "setq(" (vv-str (var-loc var)) "," loc ");") (wt-nl "(" (vv-str (var-loc var)) "->s.s_dbind)= " loc ";"))) (DOWN (wt-nl "") (wt-down (var-loc var)) (wt "=" loc ";")) (INTEGER (let ((first (and (consp loc) (car loc))) (n (var-loc var))) (case first (inline-fixnum (wt-nl "ISETQ_FIX(V"n",V"n"alloc,") (wt-inline-loc (caddr loc) (cadddr loc))) (fixnum-value (wt-nl "ISETQ_FIX(V"n",V"n"alloc,"(caddr loc))) (var (case (var-kind (cadr loc)) (integer (wt "SETQ_II(V"n",V"n"alloc,V" (var-loc (cadr loc)) "," (bignum-expansion-storage))) (fixnum (wt "ISETQ_FIX(V"n",V"n"alloc,V" (var-loc (cadr loc)))) (otherwise (wt "SETQ_IO(V"n",V"n"alloc,"loc "," (bignum-expansion-storage))))) (vs (wt "SETQ_IO(V"n",V"n"alloc,"loc "," (bignum-expansion-storage))) (otherwise (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*)) (save-avma '(nil integer)) (wt-nl "SETQ_II(V"n",V" n"alloc,") (wt-integer-loc loc (cons 'set-var var)) (wt "," (bignum-expansion-storage) ");") (close-inline-blocks)) (return-from set-var nil)) ) (wt ");"))) (t (wt-nl "V" (var-loc var) "= ") (case (var-kind var) (FIXNUM (wt-fixnum-loc loc)) (CHARACTER (wt-character-loc loc)) (LONG-FLOAT (wt-long-float-loc loc)) (SHORT-FLOAT (wt-short-float-loc loc)) (OBJECT (wt-loc loc)) (t (baboon))) (wt ";")) ))) (defun sch-global (name) (dolist* (var *undefined-vars* nil) (when (eq (var-name var) name) (return-from sch-global var)))) (defun c1add-globals (globals) (dolist** (name globals) (push (make-var :name name :kind 'GLOBAL :loc (add-symbol name) :type (let ((x (get name 'cmp-type))) (if x x t)) ) *vars*)) ) (defun c1setq (args) (cond ((endp args) (c1nil)) ((endp (cdr args)) (too-few-args 'setq 2 1)) ((endp (cddr args)) (c1setq1 (car args) (cadr args))) (t (do ((pairs args (cddr pairs)) (forms nil)) ((endp pairs) (c1expr (cons 'progn (nreverse forms)))) (declare (object pairs)) (cmpck (endp (cdr pairs)) "No form was given for the value of ~s." (car pairs)) (push (list 'setq (car pairs) (cadr pairs)) forms) ))) ) (defun c1setq1 (name form &aux (info (make-info)) type form1 name1) (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name) (cmpck (constantp name) "The constant ~s is being assigned a value." name) (setq name1 (c1vref name)) (push-changed (car name1) info) (setq form1 (c1expr form)) (add-info info (cadr form1)) (setq type (type-and (var-type (car name1)) (info-type (cadr form1)))) (when (null type) (cmpwarn "Type mismatches between ~s and ~s." name form)) (unless (eq type (info-type (cadr form1))) (let ((info1 (copy-info (cadr form1)))) (setf (info-type info1) type) (setq form1 (list* (car form1) info1 (cddr form1))))) (setf (info-type info) type) (list 'setq info name1 form1) ) (defun c2setq (vref form) (let ((*value-to-go* (cons 'var vref))) (c2expr* form)) (case (car form) (LOCATION (c2location (caddr form))) (otherwise (unwind-exit (cons 'var vref)))) ) (defun c1progv (args &aux symbols values (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'progv 2 (length args))) (setq symbols (c1expr* (car args) info)) (setq values (c1expr* (cadr args) info)) (list 'progv info symbols values (c1progn* (cddr args) info)) ) (defun c2progv (symbols values body &aux (cvar (next-cvar)) (*unwind-exit* *unwind-exit*)) (wt-nl "{object symbols,values;") (wt-nl "bds_ptr V" cvar "=bds_top;") (push cvar *unwind-exit*) (let ((*vs* *vs*)) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* symbols) (wt-nl "symbols= " *value-to-go* ";")) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* values) (wt-nl "values= " *value-to-go* ";")) (wt-nl "while(!endp(symbols)){") (when *safe-compile* (wt-nl "if(type_of(MMcar(symbols))!=t_symbol)") (wt-nl "FEinvalid_variable(\"~s is not a symbol.\",MMcar(symbols));")) (wt-nl "if(endp(values))bds_bind(MMcar(symbols),OBJNULL);") (wt-nl "else{bds_bind(MMcar(symbols),MMcar(values));") (wt-nl "values=MMcdr(values);}") (wt-nl "symbols=MMcdr(symbols);}") ) (c2expr body) (wt "}") ) (defun c1psetq (args &aux (vrefs nil) (forms nil) (info (make-info :type '(member nil)))) (do ((l args (cddr l))) ((endp l)) (declare (object l)) (cmpck (not (symbolp (car l))) "The variable ~s is not a symbol." (car l)) (cmpck (constantp (car l)) "The constant ~s is being assigned a value." (car l)) (cmpck (endp (cdr l)) "No form was given for the value of ~s." (car l)) (let* ((vref (c1vref (car l))) (form (c1expr (cadr l))) (type (type-and (var-type (car vref)) (info-type (cadr form))))) (unless (equal type (info-type (cadr form))) (let ((info1 (copy-info (cadr form)))) (setf (info-type info1) type) (setq form (list* (car form) info1 (cddr form))))) (push vref vrefs) (push form forms) (push-changed (car vref) info) (add-info info (cadar forms))) ) (list 'psetq info (nreverse vrefs) (nreverse forms)) ) (defun c2psetq (vrefs forms &aux (*vs* *vs*) (saves nil) (blocks 0)) (dolist** (vref vrefs) (if (or (args-info-changed-vars (car vref) (cdr forms)) (args-info-referred-vars (car vref) (cdr forms))) (case (caar forms) (LOCATION (push (cons vref (caddar forms)) saves)) (otherwise (if (member (var-kind (car vref)) '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)) (let* ((kind (var-kind (car vref))) (cvar (next-cvar)) (temp (list 'var (make-var :kind kind :loc cvar) nil))) (wt-nl "{" *volatile* (rep-type kind) "V" cvar ";") (incf blocks) (let ((*value-to-go* temp)) (c2expr* (car forms))) (push (cons vref temp) saves)) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* (car forms)) (push (cons vref *value-to-go*) saves))))) (let ((*value-to-go* (cons 'var vref))) (c2expr* (car forms)))) (pop forms)) (dolist** (save saves) (set-var (cdr save) (caar save) (cadar save))) (dotimes (i blocks) (wt "}")) (unwind-exit nil) ) (defun wt-var-decl (var) (cond ((var-p var) (let ((n (var-loc var))) (cond ((eq (var-kind var) 'integer)(wt "IDECL("))) (wt *volatile* (register var) (rep-type (var-kind var)) "V" n ) (if (eql (var-kind var) 'integer) (wt ",V"n"space,V"n"alloc)")) (wt ";"))) (t (wfs-error)))) gcl/cmpnew/gcl_cmpvs.lsp000077500000000000000000000054741242227143400156270ustar00rootroot00000000000000;;; CMPVS Value stack manager. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (si:putprop 'vs 'set-vs 'set-loc) (si:putprop 'vs 'wt-vs 'wt-loc) (si:putprop 'vs* 'wt-vs* 'wt-loc) (si:putprop 'ccb-vs 'wt-ccb-vs 'wt-loc) (defvar *vs* 0) (defvar *max-vs* 0) (defvar *clink* nil) (defvar *ccb-vs* 0) ;; We need an initial binding for *initial-ccb-vs* for use in defining ;; local functions at the toplevel in c2flet and c2labels. CM ;; 20031130. (defvar *initial-ccb-vs* 0) (defvar *level* 0) (defvar *vcs-used*) ;;; *vs* holds the offset of the current vs-top. ;;; *max-vs* holds the maximum offset so far. ;;; *clink* holds NIL or the vs-address of the last ccb object. ;;; *ccb-vs* holds the top of the level 0 vs. ;;; *initial-ccb-vs* holds the value of *ccb-vs* when Pass 2 began to process ;;; a local (possibly closure) function. ;;; *level* holds the current function level. *level* is 0 for a top-level ;;; function. (defun vs-push () (prog1 (cons *level* *vs*) (incf *vs*) (setq *max-vs* (max *vs* *max-vs*)))) (defun set-vs (loc vs) (unless (and (consp loc) (eq (car loc) 'vs) (equal (cadr loc) vs)) (wt-nl) (wt-vs vs) (wt "= " loc ";"))) (defun wt-vs (vs) (cond ((eq (car vs) 'cvar) (wt "V" (second vs))) ((eq (car vs) 'cs) (setq *vcs-used* t) (wt "Vcs[" (cdr vs) "]")) ((eq (car vs) 'fun-env) (wt "fun->cc.cc_turbo[" (cdr vs) "]")) (t (if (= (car vs) *level*) (wt "base[" (cdr vs) "]") (wt "base" (car vs) "[" (cdr vs) "]"))))) (defun wt-vs* (vs) (wt "(" )(wt-vs vs) (wt "->c.c_car)")) (defun wt-ccb-vs (ccb-vs) (wt "(fun->cc.cc_turbo[" (- *initial-ccb-vs* ccb-vs) "]->c.c_car)")) (defun clink (vs) (setq *clink* vs)) (defun wt-clink (&optional (clink *clink*)) (if (null clink) (wt "Cnil") (wt-vs clink))) (defun ccb-vs-push () (incf *ccb-vs*)) (defun cvs-push () (prog1 (cons 'cs *cs*) (incf *cs*) )) (defun wt-list (l) (do ((v l (cdr v))) ((null v)) (wt (car v)) (or (null (cdr v)) (wt ",")))) gcl/cmpnew/gcl_cmpwt.lsp000077500000000000000000000170531242227143400156250ustar00rootroot00000000000000;;; CMPWT Output routines. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (eval-when (compile eval) (require 'FASDMACROS "../cmpnew/gcl_fasdmacros.lsp") (defmacro data-vector () `(car *data*)) (defmacro data-inits () `(second *data*)) (defmacro data-package-ops () `(third *data*)) ) (defun wt-comment (message &optional (symbol nil)) (princ " /* " *compiler-output1*) (princ message *compiler-output1*) (when symbol (let ((s (symbol-name symbol))) (declare (string s)) (dotimes** (n (length s)) (let ((c (schar s n))) (declare (character c)) (unless (char= c #\/) (princ c *compiler-output1*)))))) (princ " */ " *compiler-output1*) nil ) (defun wt1 (form) (cond ((or (stringp form) (integerp form) (characterp form)) (princ form *compiler-output1*)) ((or (typep form 'long-float) (typep form 'short-float)) (format *compiler-output1* "~10,,,,,,'eG" form)) (t (wt-loc form))) nil) (defun wt-h1 (form) (cond ((consp form) (let ((fun (get (car form) 'wt))) (if fun (apply fun (cdr form)) (cmpiler-error "The location ~s is undefined." form)))) (t (princ form *compiler-output2*))) nil) (defvar *fasd-data*) (defvar *hash-eq* nil) (defvar *run-hash-equal-data-checking* nil) (defun memoized-hash-equal (x depth);FIXME implement all this in lisp (declare (fixnum depth)) (when *run-hash-equal-data-checking* (unless *hash-eq* (setq *hash-eq* (make-hash-table :test 'eq))) (or (gethash x *hash-eq*) (setf (gethash x *hash-eq*) (if (> depth 3) 0 (if (typep x 'cons) (logxor (setq depth (the fixnum (1+ depth)));FIXME? (logxor (memoized-hash-equal (car x) depth) (memoized-hash-equal (cdr x) depth))) (si::hash-equal x depth))))))) (defun push-data-incf (x) (vector-push-extend (cons (memoized-hash-equal x -1000) x) (data-vector)) (incf *next-vv*)) (defun wt-data1 (expr) (let ((*print-radix* nil) (*print-base* 10) (*print-circle* t) (*print-pretty* nil) (*print-level* nil) (*print-length* nil) (*print-case* :downcase) (*print-gensym* t) (*print-array* t) ;;This forces the printer to add the float type in the .data file. (*READ-DEFAULT-FLOAT-FORMAT* t) (si::*print-package* t) (si::*print-structure* t)) (terpri *compiler-output-data*) (prin1 expr *compiler-output-data*))) (defun verify-data-vector(vec &aux v) (dotimes (i (length vec)) (setq v (aref vec i)) (let ((has (memoized-hash-equal (cdr v) -1000))) (cond ((not (eql (car v) has)) (cmpwarn "A form or constant:~% ~s ~%has changed during the eval compile procedure!.~% The changed form will be the one put in the compiled file" (cdr v))))) (setf (aref vec i) (cdr v))) vec ) (defun add-init (x &optional endp) (let ((tem (cons (memoized-hash-equal x -1000) x))) (setf (data-inits) (if endp (nconc (data-inits) (list tem)) (cons tem (data-inits) ))) x)) (defun wt-data-file () (verify-data-vector (data-vector)) (let* ((vec (coerce (nreverse (data-inits)) 'vector))) (verify-data-vector vec) (setf (aref (data-vector) (- (length (data-vector)) 1)) (cons 'si::%init vec)) (setf (data-package-ops) (nreverse (data-package-ops))) (cond (*fasd-data* (wt-fasd-data-file)) (t (format *compiler-output-data* " ~%#(") (dolist (v (data-package-ops)) (format *compiler-output-data* "#! ") (wt-data1 v)) (wt-data1 (data-vector)) (format *compiler-output-data* "~%)~%") )))) (defun wt-fasd-data-file ( &aux (x (data-vector)) tem) ; (si::find-sharing-top (data-package-ops) (fasd-table (car *fasd-data*))) (si::find-sharing-top x (fasd-table (car *fasd-data*))) (cond ((setq tem (data-package-ops)) (dolist (v tem) (put-op d_eval_skip *compiler-output-data*) (si::write-fasd-top v (car *fasd-data*))))) (si::write-fasd-top x (car *fasd-data*)) ; (sloop::sloop for (k v) in-table (fasd-table (car *fasd-data*)) ; when (>= v 0) do (print (list k v))) (si::close-fasd (car *fasd-data*))) (defun wt-data-begin ()) (defun wt-data-end ()) (defun wt-data-package-operation (x) (push x (data-package-ops))) (defmacro wt (&rest forms &aux (fl nil)) (dolist** (form forms (cons 'progn (reverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output1*) fl) (push `(wt1 ,form) fl)))) (defmacro wt-h (&rest forms &aux (fl nil)) (cond ((endp forms) '(princ " " *compiler-output2*)) ((stringp (car forms)) (dolist** (form (cdr forms) (list* 'progn `(princ ,(concatenate 'string " " (car forms)) *compiler-output2*) (reverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output2*) fl) (push `(wt-h1 ,form) fl)))) (t (dolist** (form forms (list* 'progn '(princ " " *compiler-output2*) (reverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output2*) fl) (push `(wt-h1 ,form) fl)))))) (defmacro wt-nl (&rest forms &aux (fl nil)) (cond ((endp forms) '(princ " " *compiler-output1*)) ((stringp (car forms)) (dolist** (form (cdr forms) (list* 'progn `(princ ,(concatenate 'string " " (car forms)) *compiler-output1*) (reverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output1*) fl) (push `(wt1 ,form) fl)))) (t (dolist** (form forms (list* 'progn '(princ " " *compiler-output1*) (reverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output1*) fl) (push `(wt1 ,form) fl)))))) (defmacro wt-nl1 (&rest forms &aux (fl nil)) (cond ((endp forms) '(princ " " *compiler-output1*)) ((stringp (car forms)) (dolist** (form (cdr forms) (list* 'progn `(princ ,(concatenate 'string " " (car forms)) *compiler-output1*) (nreverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output1*) fl) (push `(wt1 ,form) fl)))) (t (dolist** (form forms (list* 'progn '(princ " " *compiler-output1*) (nreverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output1*) fl) (push `(wt1 ,form) fl)))))) gcl/cmpnew/gcl_collectfn.lsp000077500000000000000000000305511242227143400164420ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;;;; ;;; Copyright (c) 1989 by William Schelter,University of Texas ;;;;; ;;; All rights reserved ;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; See the doc/DOC file for information on emit-fn and ;; make-all-proclaims. The basic idea is to utilize information gathered ;; by the compiler in a compile of a system of files in order to generate ;; better code on subsequent compiles of the system. To do this a file ;; sys-proclaim.lisp should be produced. ;; Additionally cross reference information about functions in the system is ;; collected. (in-package 'compiler) (import 'sloop::sloop) (defstruct fn name ;; name of THIS FUNCTION def ;; defun, defmacro value-type ;; If this function's body contained ;; (cond ((> a 3) 7) ;; ((> a 1) (foo))) ;; then the return type of 7 is known at compile time ;; and value-type would be fixnum. [see return-type] fun-values ;; list of functions whose values are the values of THIS FN ;; (foo) in the previous example. callees ;; list of all functions called by THIS FUNCTION return-type ;; Store a return-type computed from the fun-values ;; and value-type field. This computation is done later. arg-types ;; non optional arg types. no-emit ;; if not nil don't emit declaration. macros ) (defvar *other-form* (make-fn)) (defvar *all-fns* nil) (defvar *call-table* (make-hash-table)) (defvar *current-fn* nil) (defun add-callee (fname) (cond ((consp fname) (or (eq (car fname) 'values) (add-callee (car fname)))) ((eq fname 'single-value)) (fname (pushnew fname (fn-callees (current-fn)))))) (defun add-macro-callee (fname) (or ;; make sure the macro fname is not shadowed in the current environment. (sloop::sloop for v in *funs* when (and (consp v) (eq (car v) fname)) do (return t)) (pushnew fname (fn-macros (current-fn))))) (defun clear-call-table () (setf *current-fn* nil) (setq *all-fns* nil) (setq *other-form* (make-fn :name 'other-form)) (clrhash *call-table*) (setf (gethash 'other-form *call-table*) *other-form*) ) (defun emit-fn (flag) (setq *record-call-info* flag)) (defun type-or (a b) (if (eq b '*) '* (case a ((nil) b) ((t inline) t) ((fixnum inline-fixnum fixnum-value) (if (eq b 'fixnum) 'fixnum (type-or t b))) (otherwise '*) ))) (defun current-fn () (cond ((and (consp *current-form*) (member (car *current-form*) '(defun defmacro)) (symbolp (second *current-form*)) (symbol-package (second *current-form*));;don't record gensym'd ) (cond ((and *current-fn* (equal (second *current-form*) (fn-name *current-fn*))) *current-fn*) (t (unless (setq *current-fn* (gethash (second *current-form*) *call-table*)) (setq *current-fn* (make-fn :name (second *current-form*) :def (car *current-form*))) (setf (gethash (second *current-form*) *call-table*) *current-fn*) (setq *all-fns* (cons *current-fn* *all-fns*))) *current-fn*))) ;; catch all for other top level forms (t *other-form*))) (defun who-calls (f) (sloop for (ke val) in-table *call-table* when (or (member f (fn-callees val)) (member f (fn-macros val))) collect ke)) (defun add-value-type (x fn &aux (current-fn (current-fn))) (cond (fn (pushnew fn (fn-fun-values current-fn) :test 'equal)) (t (setf (fn-value-type current-fn) (type-or (fn-value-type current-fn) x))))) (defun get-var-types (lis) (sloop::sloop for v in lis collect (var-type v))) (defun record-arg-info( lambda-list &aux (cf (current-fn))) (setf (fn-arg-types cf) (get-var-types (car lambda-list))) (when (sloop::sloop for v in (cdr lambda-list) for w in '(&optional &rest &key nil &allow-other-keys ) when (and v w) do (return '*)) (setf (fn-arg-types cf) (nconc(fn-arg-types cf) (list '*))) )) (defvar *depth* 0) (defvar *called-from* nil) (defun get-value-type (fname) (cond ((member fname *called-from* :test 'eq) nil) (t (let ((tem (cons fname *called-from*))) (declare (:dynamic-extent tem)) (let ((*called-from* tem)) (get-value-type1 fname)))))) (defun get-value-type1 (fname &aux tem (*depth* (the fixnum (+ 1 (the fixnum *depth* ))))) (cond ((> (the fixnum *depth*) 100) '*) ((setq tem (gethash fname *call-table*)) (or (fn-return-type tem) (sloop::sloop with typ = (fn-value-type tem) for v in (fn-fun-values tem) when (symbolp v) do (setq typ (type-or typ (get-value-type v))) else when (and (consp v) (eq (car v) 'values)) do (setq typ (type-or typ (if (eql (cdr v) 1) t '*))) else do (error "unknown fun value ~a" v) finally ;; if there is no visible return, then we can assume ;; one value. (or typ (fn-value-type tem) (fn-fun-values tem) (setf typ t)) (setf (fn-return-type tem) typ) (return typ) ))) ((get fname 'return-type)) ((get fname 'proclaimed-return-type)) (t '*))) (defun result-type-from-loc (x) (cond ((consp x) (case (car x) ((fixnum-value inline-fixnum) 'fixnum) (var (var-type (second x))) ;; eventually separate out other inlines (t (cond ((and (symbolp (car x)) (get (car x) 'wt-loc)) t) (t (print (list 'type '* x)) '*))))) ((or (eq x t) (null x)) t) (t (print (list 'type '*2 x)) '*))) (defun small-all-t-p (args ret) (and (eq ret t) (< (length args) 10) (sloop::sloop for v in args always (eq v t)))) ;; Don't change return type but pretend all these are optional args. (defun no-make-proclaims-hack () (sloop::sloop for (ke val) in-table *call-table* do (progn ke) (setf (fn-no-emit val) 1))) (defun set-closure () (setf (fn-def (current-fn)) 'closure)) (defun make-proclaims ( &optional (st *standard-output*) &aux (ht (make-hash-table :test 'equal)) *print-length* *print-level* (si::*print-package* t) ) ; (require "VLFUN" ; (concatenate 'string si::*system-directory* ; "../cmpnew/lfun_list.lsp")) (print `(in-package ,(package-name *package*)) st) (sloop::sloop with ret with at for (ke val) in-table *call-table* do (cond ((eq (fn-def val) 'closure) (push ke (gethash 'proclaimed-closure ht))) ((or (eql 1 (fn-no-emit val)) (not (eq (fn-def val) 'defun)))) (t (setq ret (get-value-type ke)) (setq at (fn-arg-types val)) (push ke (gethash (list at ret) ht))))) (sloop::sloop for (at fns) in-table ht do (print (if (symbolp at) `(mapc (lambda (x) (setf (get x 'compiler::proclaimed-closure) t)) '(,@fns)) `(proclaim '(ftype (function ,@ at) ,@ fns))) st))) (defun setup-sys-proclaims() (or (gethash 'si::call-test *call-table*) (get 'si::call-test 'proclaimed-function) (load (concatenate 'string si::*system-directory* "../lsp/sys-proclaim.lisp")) (no-make-proclaims-hack) )) (defun make-all-proclaims (&rest files) (setup-sys-proclaims) (dolist (v files) (mapcar 'load (directory v))) (write-sys-proclaims)) (defun write-sys-proclaims () (with-open-file (st "sys-proclaim.lisp" :direction :output) (make-proclaims st))) (defvar *file-table* (make-hash-table :test 'eq)) (defvar *warn-on-multiple-fn-definitions* t) (defun add-fn-data (lis &aux tem file) (let ((file (and (setq file (si::fp-input-stream *standard-input*)) (truename file)))) (dolist (v lis) (cond ((eql (fn-name v) 'other-form) (setf (fn-name v) (intern (concatenate 'string "OTHER-FORM-" (namestring file)))) (setf (get (fn-name v) 'other-form) t))) (setf (gethash (fn-name v) *call-table*) v) (when *warn-on-multiple-fn-definitions* (when (setq tem (gethash (fn-name v) *file-table*)) (unless (equal tem file) (warn 'simple-warning :format-control "~% ~a redefined in ~a. Originally in ~a." :format-arguments (list (fn-name v) file tem))))) (setf (gethash (fn-name v) *file-table*) file)))) (defun dump-fn-data (&optional (file "fn-data.lsp") &aux (*package* (find-package "COMPILER")) (*print-length* nil) (*print-level* nil) ) (with-open-file (st file :direction :output) (format st "(in-package 'compiler)(init-fn)~%(~s '(" 'add-fn-data) (sloop::sloop for (ke val) in-table *call-table* do (progn ke) (print val st)) (princ "))" st) (truename st))) (defun record-call-info (loc fname) (cond ((and fname (symbolp fname)) (add-callee fname))) (cond ((eq loc 'record-call-info) (return-from record-call-info nil))) (case *value-to-go* (return (if (eq loc 'fun-val) (add-value-type nil (or fname 'unknown-values)) (add-value-type (result-type-from-loc loc) nil))) (return-fixnum (add-value-type 'fixnum nil)) (return-object (add-value-type t nil)) (top (setq *top-data* (cons fname nil)) )) ) (defun list-undefined-functions (&aux undefs) (sloop::sloop for (name fn) in-table *call-table* declare (ignore name) do (sloop for w in (fn-callees fn) when (not (or (fboundp w) (gethash w *call-table*) (get w 'inline-always) (get w 'inline-unsafe) (get w 'other-form) )) do (pushnew w undefs))) undefs) (dolist (v '(throw coerce single-value sort delete remove char-upcase si::fset typep)) (si::putprop v t 'return-type)) (defun init-fn () nil) (defun list-uncalled-functions ( ) (let* ((size (sloop::sloop for (ke v) in-table *call-table* count t do (progn ke v nil))) (called (make-hash-table :test 'eq :size (+ 3 size)))) (sloop::sloop for (ke fn) in-table *call-table* declare (ignore ke) do (sloop::sloop for w in (fn-callees fn) do (setf (gethash w called) t)) (sloop::sloop for w in (fn-macros fn) do (setf (gethash w called) t)) ) (sloop::sloop for (ke fn) in-table *call-table* when(and (not (gethash ke called)) (member (fn-def fn) '(defun defmacro) :test 'eq)) collect ke))) ;; redefine the stub in defstruct.lsp (defun si::record-fn (name def arg-types return-type) (if (null return-type) (setq return-type t)) (and *record-call-info* *compiler-in-use* (let ((fn (make-fn :name name :def def :return-type return-type :arg-types arg-types))) (push fn *all-fns*) (setf (gethash name *call-table*) fn)))) (defun get-packages (&optional (st "sys-package.lisp") pass &aux (si::*print-package* t)) (flet ((pr (x) (format st "~%~s" x))) (cond ((null pass) (with-open-file (st st :direction :output) (get-packages st 'establish) (get-packages st 'export) (get-packages st 'shadow) (format st "~2%") (return-from get-packages nil)))) (dolist (p (list-all-packages)) (unless (member (package-name p) '("SLOOP" "COMPILER" "SYSTEM" "KEYWORD" "LISP" "USER") :test 'equal ) (format st "~2%;;; Definitions for package ~a of type ~a" (package-name p) pass) (ecase pass (establish (let ((SYSTEM::*PRINT-PACKAGE* t)) (pr `(in-package ,(package-name p) :use nil ,@ (if (package-nicknames p) `(:nicknames ',(package-nicknames p))))))) (export (let ((SYSTEM::*PRINT-PACKAGE* t)) (pr `(in-package ,(package-name p) :use '(,@ (mapcar 'package-name (package-use-list p))) ,@(if (package-nicknames p) `(:nicknames ',(package-nicknames p)))))) (let (ext (*package* p) imps) (do-external-symbols (sym p) (push sym ext) (or (eq (symbol-package sym) p) (push sym imps))) (pr `(import ',imps)) (pr `(export ',ext)))) (shadow (let ((SYSTEM::*PRINT-PACKAGE* t)) (pr `(in-package ,(package-name p)))) (let (in out (*package* (find-package "LISP"))) (dolist (v (package-shadowing-symbols p)) (cond ((eq (symbol-package v) p) (push v in)) (t (push v out)))) (pr `(shadow ',in)) (pr `(shadowing-import ',out)) (let (imp) (do-symbols (v p) (cond ((not (eq (symbol-package v) p)) (push v imp)))) (pr `(import ',imp)))))))))) gcl/cmpnew/gcl_fasdmacros.lsp000077500000000000000000000036541242227143400166170ustar00rootroot00000000000000 (defstruct (fasd (:type vector)) stream table eof direction package index filepos table_length evald_forms ; list of forms eval'd. (load-time-eval) ) (defvar *fasd-ops* '( d_nil ;/* dnil: nil */ d_eval_skip ; /* deval o1: evaluate o1 after reading it */ d_delimiter ;/* occurs after d_listd_general and d_new_indexed_items */ d_enter_vector ; /* d_enter_vector o1 o2 .. on d_delimiter make a cf_data with ; this length. Used internally by gcl. Just make ; an array in other lisps */ d_cons ; /* d_cons o1 o2: (o1 . o2) */ d_dot ; d_list ;/* list* delimited by d_delimiter d_list,o1,o2, ... ,d_dot,on ;for (o1 o2 . on) ;or d_list,o1,o2, ... ,on,d_delimiter for (o1 o2 ... on) ;*/ d_list1 ;/* nil terminated length 1 d_list1o1 */ d_list2 ; /* nil terminated length 2 */ d_list3 d_list4 d_eval d_short_symbol d_short_string d_short_fixnum d_short_symbol_and_package d_bignum d_fixnum d_string d_objnull d_structure d_package d_symbol d_symbol_and_package d_end_of_file d_standard_character d_vector d_array d_begin_dump d_general_type d_sharp_equals ; /* define a sharp */ d_sharp_value d_sharp_value2 d_new_indexed_item d_new_indexed_items d_reset_index d_macro d_reserve1 d_reserve2 d_reserve3 d_reserve4 d_indexed_item3 ; /* d_indexed_item3 followed by 3bytes to give index */ d_indexed_item2 ; /* d_indexed_item2 followed by 2bytes to give index */ d_indexed_item1 d_indexed_item0 ; /* This must occur last ! */ )) (defmacro put-op (op str) `(write-byte ,(or (position op *fasd-ops*) (error "illegal op")) ,str)) (defmacro put2 (n str) `(progn (write-bytei ,n 0 ,str) (write-bytei ,n 1 ,str))) (defmacro write-bytei (n i str) `(write-byte (the fixnum (ash (the fixnum ,n) >> ,(* i 8))) ,str)) (provide 'FASDMACROS) gcl/cmpnew/gcl_init.lsp000077500000000000000000000002211242227143400154230ustar00rootroot00000000000000(defun lcs1 (file) (compile-file file :c-file t :h-file t :data-file t :ob-file t :system-p t)) gcl/cmpnew/gcl_lfun_list.lsp000077500000000000000000000563661242227143400165040ustar00rootroot00000000000000 ;; Modified data base including return values types ;; and making the arglists correct if they have optional args. ;; (in-package 'compiler) (DEFSYSFUN 'GENSYM "Lgensym" '(*) 'T NIL NIL) (DEFSYSFUN 'SUBSEQ "Lsubseq" '(T T *) 'T NIL NIL) (DEFSYSFUN 'MINUSP "Lminusp" '(T) 'T NIL T) (DEFSYSFUN 'INTEGER-DECODE-FLOAT "Linteger_decode_float" '(T) '(VALUES T T T) NIL NIL) (DEFSYSFUN '- "Lminus" '(T *) 'T NIL NIL) (DEFSYSFUN 'INT-CHAR "Lint_char" '(T) 'CHARACTER NIL NIL) (DEFSYSFUN 'CHAR-INT "Lchar_int" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN '/= "Lall_different" '(T *) 'T NIL T) (DEFSYSFUN 'COPY-SEQ "Lcopy_seq" '(T) 'T NIL NIL) (DEFSYSFUN 'KEYWORDP "Lkeywordp" '(T) 'T NIL T) (DEFSYSFUN 'NAME-CHAR "Lname_char" '(T) 'CHARACTER NIL NIL) (DEFSYSFUN 'CHAR-NAME "Lchar_name" '(T) 'T NIL NIL) (DEFSYSFUN 'RASSOC-IF "Lrassoc_if" '(T T) 'T NIL NIL) (DEFSYSFUN 'MAKE-LIST "Lmake_list" '(T *) 'T NIL NIL) (DEFSYSFUN 'HOST-NAMESTRING "Lhost_namestring" '(T) 'STRING NIL NIL) (DEFSYSFUN 'MAKE-ECHO-STREAM "Lmake_echo_stream" '(T T) 'T NIL NIL) ;(DEFSYSFUN 'NTH "Lnth" '(T T) 'T NIL NIL) (DEFSYSFUN 'SIN "Lsin" '(T) 'T NIL NIL) (DEFSYSFUN 'NUMERATOR "Lnumerator" '(T) 'T NIL NIL) (DEFSYSFUN 'ARRAY-RANK "Larray_rank" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'CAAR "Lcaar" '(T) 'T NIL NIL) ;#-clcs (DEFSYSFUN 'LOAD "Lload" '(T *) 'T NIL NIL) ;#-clcs (DEFSYSFUN 'OPEN "Lopen" '(T *) 'T NIL NIL) (DEFSYSFUN 'BOTH-CASE-P "Lboth_case_p" '(T) 'T NIL T) (DEFSYSFUN 'NULL "Lnull" '(T) 'T NIL T) (DEFSYSFUN 'RENAME-FILE "Lrename_file" '(T T) 'T NIL NIL) (DEFSYSFUN 'FILE-AUTHOR "Lfile_author" '(T) 'T NIL NIL) (DEFSYSFUN 'STRING-CAPITALIZE "Lstring_capitalize" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'MACROEXPAND "Lmacroexpand" '(T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'NCONC "Lnconc" '(*) 'T NIL NIL) (DEFSYSFUN 'BOOLE "Lboole" '(T T T) 'T NIL NIL) (DEFSYSFUN 'TAILP "Ltailp" '(T T) 'T NIL T) (DEFSYSFUN 'CONSP "Lconsp" '(T) 'T NIL T) (DEFSYSFUN 'LISTP "Llistp" '(T) 'T NIL T) (DEFSYSFUN 'MAPCAN "Lmapcan" '(T T *) 'T NIL NIL) (DEFSYSFUN 'LENGTH "Llength" '(T) 'FIXNUM T NIL) (DEFSYSFUN 'RASSOC "Lrassoc" '(T T *) 'T NIL NIL) (DEFSYSFUN 'PPRINT "Lpprint" '(T *) 'T NIL NIL) (DEFSYSFUN 'PATHNAME-HOST "Lpathname_host" '(T) 'T NIL NIL) (DEFSYSFUN 'NSUBST-IF-NOT "Lnsubst_if_not" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'FILE-POSITION "Lfile_position" '(T *) 'T NIL NIL) (DEFSYSFUN 'STRING< "Lstring_l" '(T T *) 'T NIL NIL) (DEFSYSFUN 'REVERSE "Lreverse" '(T) 'T NIL NIL) (DEFSYSFUN 'STREAMP "Lstreamp" '(T) 'T NIL T) (DEFSYSFUN 'SYSTEM::PUTPROP "siLputprop" '(T T T) 'T NIL NIL) (DEFSYSFUN 'REMPROP "Lremprop" '(T T) 'T NIL NIL) (DEFSYSFUN 'SYMBOL-PACKAGE "Lsymbol_package" '(T) 'T NIL NIL) (DEFSYSFUN 'NSTRING-UPCASE "Lnstring_upcase" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'STRING>= "Lstring_ge" '(T T *) 'T NIL NIL) (DEFSYSFUN 'REALPART "Lrealpart" '(T) 'T NIL NIL) ;;broken on suns.. ;(DEFSYSFUN 'USER-HOMEDIR-PATHNAME "Luser_homedir_pathname" '(*) 'T NIL ; NIL) (DEFSYSFUN 'NBUTLAST "Lnbutlast" '(T *) 'T NIL NIL) (DEFSYSFUN 'ARRAY-DIMENSION "Larray_dimension" '(T T) 'FIXNUM NIL NIL) (DEFSYSFUN 'CDR "Lcdr" '(T) 'T NIL NIL) ;(DEFSYSFUN 'EQL "Leql" '(T T) 'T NIL T) (DEFSYSFUN 'LOG "Llog" '(T *) 'T NIL NIL) (DEFSYSFUN 'DIRECTORY "Ldirectory" '(T) 'T NIL NIL) (DEFSYSFUN 'STRING-NOT-EQUAL "Lstring_not_equal" '(T T *) 'T NIL NIL) (DEFSYSFUN 'SHADOWING-IMPORT "Lshadowing_import" '(T *) 'T NIL NIL) (DEFSYSFUN 'MAPC "Lmapc" '(T T *) 'T NIL NIL) (DEFSYSFUN 'MAPL "Lmapl" '(T T *) 'T NIL NIL) (DEFSYSFUN 'MAKUNBOUND "Lmakunbound" '(T) 'T NIL NIL) (DEFSYSFUN 'CONS "Lcons" '(T T) 'T NIL NIL) (DEFSYSFUN 'LIST "Llist" '(*) 'T NIL NIL) (DEFSYSFUN 'USE-PACKAGE "Luse_package" '(T *) 'T NIL NIL) (DEFSYSFUN 'FILE-LENGTH "Lfile_length" '(T) 'T NIL NIL) (DEFSYSFUN 'MAKE-SYMBOL "Lmake_symbol" '(T) 'T NIL NIL) (DEFSYSFUN 'STRING-RIGHT-TRIM "Lstring_right_trim" '(T T) 'STRING NIL NIL) (DEFSYSFUN 'ENOUGH-NAMESTRING "Lenough_namestring" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'PRINT "Lprint" '(T *) 'T NIL NIL) (DEFSYSFUN 'CDDAAR "Lcddaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CDADAR "Lcdadar" '(T) 'T NIL NIL) (DEFSYSFUN 'CDAADR "Lcdaadr" '(T) 'T NIL NIL) (DEFSYSFUN 'CADDAR "Lcaddar" '(T) 'T NIL NIL) (DEFSYSFUN 'CADADR "Lcadadr" '(T) 'T NIL NIL) (DEFSYSFUN 'CAADDR "Lcaaddr" '(T) 'T NIL NIL) (DEFSYSFUN 'SET-MACRO-CHARACTER "Lset_macro_character" '(T T *) 'T NIL NIL) (DEFSYSFUN 'FORCE-OUTPUT "Lforce_output" '(*) 'T NIL NIL) ;(DEFSYSFUN 'NTHCDR "Lnthcdr" '(T T) 'T NIL NIL) (DEFSYSFUN 'LOGIOR "Llogior" '(*) 'T NIL NIL) (DEFSYSFUN 'CHAR-DOWNCASE "Lchar_downcase" '(T) 'CHARACTER NIL NIL) (DEFSYSFUN 'STRING-CHAR-P "Lstring_char_p" '(T) 'T NIL T) (DEFSYSFUN 'STREAM-ELEMENT-TYPE "Lstream_element_type" '(T) 'T NIL NIL) (DEFSYSFUN 'PACKAGE-USED-BY-LIST "Lpackage_used_by_list" '(T) 'T NIL NIL) (DEFSYSFUN '/ "Ldivide" '(T *) 'T NIL NIL) (DEFSYSFUN 'MAPHASH "Lmaphash" '(T T) 'T NIL NIL) (DEFSYSFUN 'STRING= "Lstring_eq" '(T T *) 'T NIL T) (DEFSYSFUN 'PAIRLIS "Lpairlis" '(T T *) 'T NIL NIL) (DEFSYSFUN 'SYMBOLP "Lsymbolp" '(T) 'T NIL T) (DEFSYSFUN 'CHAR-NOT-LESSP "Lchar_not_lessp" '(T *) 'T NIL T) (DEFSYSFUN '1+ "Lone_plus" '(T) 'T NIL NIL) (DEFSYSFUN 'BY "Lby" 'NIL 'T NIL NIL) (DEFSYSFUN 'NSUBST-IF "Lnsubst_if" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'COPY-LIST "Lcopy_list" '(T) 'T NIL NIL) (DEFSYSFUN 'TAN "Ltan" '(T) 'T NIL NIL) (DEFSYSFUN 'SET "Lset" '(T T) 'T NIL NIL) (DEFSYSFUN 'FUNCTIONP "Lfunctionp" '(T) 'T NIL T) (DEFSYSFUN 'WRITE-BYTE "Lwrite_byte" '(T T) 'T NIL NIL) (DEFSYSFUN 'LAST "Llast" '(T *) 'T NIL NIL) (DEFSYSFUN 'MAKE-STRING "Lmake_string" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'CAAAR "Lcaaar" '(T) 'T NIL NIL) (DEFSYSFUN 'LIST-LENGTH "Llist_length" '(T) 'T NIL NIL) (DEFSYSFUN 'CDDDR "Lcdddr" '(T) 'T NIL NIL) (DEFSYSFUN 'PRIN1 "Lprin1" '(T *) 'T NIL NIL) (DEFSYSFUN 'PRINC "Lprinc" '(T *) 'T NIL NIL) (DEFSYSFUN 'LOWER-CASE-P "Llower_case_p" '(T) 'T NIL T) (DEFSYSFUN 'CHAR<= "Lchar_le" '(T *) 'T NIL T) (DEFSYSFUN 'STRING-EQUAL "Lstring_equal" '(T T *) 'T NIL T) (DEFSYSFUN 'CLEAR-OUTPUT "Lclear_output" '(*) 'T NIL NIL) #-clcs (DEFSYSFUN 'CERROR "Lcerror" '(T T *) 'T NIL NIL) (DEFSYSFUN 'TERPRI "Lterpri" '(*) 'T NIL NIL) (DEFSYSFUN 'NSUBST "Lnsubst" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'UNUSE-PACKAGE "Lunuse_package" '(T *) 'T NIL NIL) (DEFSYSFUN 'STRING-NOT-GREATERP "Lstring_not_greaterp" '(T T *) 'T NIL NIL) (DEFSYSFUN 'STRING> "Lstring_g" '(T T *) 'T NIL NIL) (DEFSYSFUN 'FINISH-OUTPUT "Lfinish_output" '(*) 'T NIL NIL) (DEFSYSFUN 'SPECIAL-FORM-P "Lspecial_form_p" '(T) 'T NIL T) (DEFSYSFUN 'STRINGP "Lstringp" '(T) 'T NIL T) (DEFSYSFUN 'GET-INTERNAL-RUN-TIME "Lget_internal_run_time" 'NIL 'T NIL NIL) (DEFSYSFUN 'TRUNCATE "Ltruncate" '(T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'CODE-CHAR "Lcode_char" '(T *) 'CHARACTER NIL NIL) (DEFSYSFUN 'CHAR-CODE "Lchar_code" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'SIMPLE-STRING-P "Lsimple_string_p" '(T) 'T NIL T) (DEFSYSFUN 'REVAPPEND "Lrevappend" '(T T) 'T NIL NIL) (DEFSYSFUN 'HASH-TABLE-COUNT "Lhash_table_count" '(T) 'T NIL NIL) (DEFSYSFUN 'PACKAGE-USE-LIST "Lpackage_use_list" '(T) 'T NIL NIL) (DEFSYSFUN 'REM "Lrem" '(T T) 'T NIL NIL) (DEFSYSFUN 'MIN "Lmin" '(T *) 'T NIL NIL) (DEFSYSFUN 'APPLYHOOK "Lapplyhook" '(T T T T *) 'T NIL NIL) (DEFSYSFUN 'EXP "Lexp" '(T) 'T NIL NIL) (DEFSYSFUN 'CHAR-LESSP "Lchar_lessp" '(T *) 'T NIL T) (DEFSYSFUN 'CDAR "Lcdar" '(T) 'T NIL NIL) (DEFSYSFUN 'CADR "Lcadr" '(T) 'T NIL NIL) (DEFSYSFUN 'LIST-ALL-PACKAGES "Llist_all_packages" 'NIL 'T NIL NIL) (DEFSYSFUN 'REST "Lcdr" '(T) 'T NIL NIL) (DEFSYSFUN 'COPY-SYMBOL "Lcopy_symbol" '(T *) 'T NIL NIL) (DEFSYSFUN 'ACONS "Lacons" '(T T T) 'T NIL NIL) (DEFSYSFUN 'ADJUSTABLE-ARRAY-P "Ladjustable_array_p" '(T) 'T NIL T) (DEFSYSFUN 'SVREF "Lsvref" '(T T) 'T NIL NIL) (DEFSYSFUN 'APPLY "Lapply" '(T T *) 'T NIL NIL) (DEFSYSFUN 'DECODE-FLOAT "Ldecode_float" '(T) '(VALUES T T T) NIL NIL) (DEFSYSFUN 'SUBST-IF-NOT "Lsubst_if_not" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'RPLACA "Lrplaca" '(T T) 'T NIL NIL) (DEFSYSFUN 'SYMBOL-PLIST "Lsymbol_plist" '(T) 'T NIL NIL) (DEFSYSFUN 'WRITE-STRING "Lwrite_string" '(T *) 'T NIL NIL) (DEFSYSFUN 'LOGEQV "Llogeqv" '(*) 'T NIL NIL) (DEFSYSFUN 'STRING "Lstring" '(T) 'STRING NIL NIL) (DEFSYSFUN 'STRING-UPCASE "Lstring_upcase" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'CEILING "Lceiling" '(T *) '(VALUES T T) NIL NIL) ;(DEFSYSFUN 'GETHASH "Lgethash" '(T T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'TYPE-OF "Ltype_of" '(T) 'T NIL NIL) (DEFSYSFUN 'BUTLAST "Lbutlast" '(T *) 'T NIL NIL) (DEFSYSFUN '1- "Lone_minus" '(T) 'T NIL NIL) (DEFSYSFUN 'MAKE-HASH-TABLE "Lmake_hash_table" '(*) 'T NIL NIL) (DEFSYSFUN 'STRING/= "Lstring_neq" '(T T *) 'T NIL NIL) (DEFSYSFUN '<= "Lmonotonically_nondecreasing" '(T *) 'T NIL T) (DEFSYSFUN 'MAKE-BROADCAST-STREAM "Lmake_broadcast_stream" '(*) 'T NIL NIL) (DEFSYSFUN 'IMAGPART "Limagpart" '(T) 'T NIL NIL) (DEFSYSFUN 'INTEGERP "Lintegerp" '(T) 'T NIL T) (DEFSYSFUN 'READ-CHAR "Lread_char" '(*) 'T NIL NIL) (DEFSYSFUN 'PEEK-CHAR "Lpeek_char" '(*) 'T NIL NIL) (DEFSYSFUN 'CHAR-FONT "Lchar_font" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'STRING-GREATERP "Lstring_greaterp" '(T T *) 'T NIL NIL) (DEFSYSFUN 'OUTPUT-STREAM-P "Loutput_stream_p" '(T) 'T NIL T) (DEFSYSFUN 'ASH "Lash" '(T T) 'T NIL NIL) (DEFSYSFUN 'LCM "Llcm" '(T *) 'T NIL NIL) (DEFSYSFUN 'ELT "Lelt" '(T T) 'T NIL NIL) (DEFSYSFUN 'COS "Lcos" '(T) 'T NIL NIL) (DEFSYSFUN 'NSTRING-DOWNCASE "Lnstring_downcase" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'COPY-ALIST "Lcopy_alist" '(T) 'T NIL NIL) (DEFSYSFUN 'ATAN "Latan" '(T *) 'T NIL NIL) (DEFSYSFUN 'DELETE-FILE "Ldelete_file" '(T) 'T NIL NIL) (DEFSYSFUN 'FLOAT-RADIX "Lfloat_radix" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'SYMBOL-NAME "Lsymbol_name" '(T) 'STRING NIL NIL) (DEFSYSFUN 'CLEAR-INPUT "Lclear_input" '(*) 'T NIL NIL) (DEFSYSFUN 'FIND-SYMBOL "Lfind_symbol" '(T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'CHAR< "Lchar_l" '(T *) 'T NIL T) (DEFSYSFUN 'HASH-TABLE-P "Lhash_table_p" '(T) 'T NIL T) (DEFSYSFUN 'EVENP "Levenp" '(T) 'T NIL T) (DEFSYSFUN 'SYSTEM::CMOD "siLcmod" '(T) 'T NIL T) (DEFSYSFUN 'SYSTEM::CPLUS "siLcplus" '(T T) 'T NIL T) (DEFSYSFUN 'SYSTEM::CTIMES "siLctimes" '(T T) 'T NIL T) (DEFSYSFUN 'SYSTEM::CDIFFERENCE "siLcdifference" '(T T) 'T NIL T) (DEFSYSFUN 'ZEROP "Lzerop" '(T) 'T NIL T) (DEFSYSFUN 'CAAAAR "Lcaaaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CHAR>= "Lchar_ge" '(T *) 'T NIL T) (DEFSYSFUN 'CDDDAR "Lcdddar" '(T) 'T NIL NIL) (DEFSYSFUN 'CDDADR "Lcddadr" '(T) 'T NIL NIL) (DEFSYSFUN 'CDADDR "Lcdaddr" '(T) 'T NIL NIL) (DEFSYSFUN 'CADDDR "Lcadddr" '(T) 'T NIL NIL) (DEFSYSFUN 'FILL-POINTER "Lfill_pointer" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'MAPCAR "Lmapcar" '(T T *) 'T NIL NIL) (DEFSYSFUN 'FLOATP "Lfloatp" '(T) 'T NIL T) (DEFSYSFUN 'SHADOW "Lshadow" '(T *) 'T NIL NIL) (DEFSYSFUN 'MACROEXPAND-1 "Lmacroexpand_1" '(T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'SXHASH "Lsxhash" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'LISTEN "Llisten" '(*) 'T NIL NIL) (DEFSYSFUN 'ARRAYP "Larrayp" '(T) 'T NIL T) (DEFSYSFUN 'MAKE-PATHNAME "Lmake_pathname" '(*) 'T NIL NIL) (DEFSYSFUN 'PATHNAME-TYPE "Lpathname_type" '(T) 'T NIL NIL) (DEFSYSFUN 'FUNCALL "Lfuncall" '(T *) 'T NIL NIL) (DEFSYSFUN 'CLRHASH "Lclrhash" '(T) 'T NIL NIL) (DEFSYSFUN 'GRAPHIC-CHAR-P "Lgraphic_char_p" '(T) 'T NIL T) (DEFSYSFUN 'FBOUNDP "Lfboundp" '(T) 'T NIL T) (DEFSYSFUN 'NSUBLIS "Lnsublis" '(T T *) 'T NIL NIL) (DEFSYSFUN 'CHAR-NOT-EQUAL "Lchar_not_equal" '(T *) 'T NIL T) (DEFSYSFUN 'MACRO-FUNCTION "Lmacro_function" '(T) 'T NIL NIL) (DEFSYSFUN 'SUBST-IF "Lsubst_if" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'COMPLEXP "Lcomplexp" '(T) 'T NIL T) (DEFSYSFUN 'READ-LINE "Lread_line" '(*) '(VALUES T T) NIL NIL) (DEFSYSFUN 'PATHNAMEP "Lpathnamep" '(T) 'T NIL T) (DEFSYSFUN 'MAX "Lmax" '(T *) 'T NIL NIL) (DEFSYSFUN 'IN-PACKAGE "Lin_package" '(T *) 'T NIL NIL) (DEFSYSFUN 'READTABLEP "Lreadtablep" '(T) 'T NIL T) (DEFSYSFUN 'FLOAT-SIGN "Lfloat_sign" '(T *) 'T NIL NIL) (DEFSYSFUN 'CHARACTERP "Lcharacterp" '(T) 'T NIL T) (DEFSYSFUN 'READ "Lread" '(*) 'T NIL NIL) (DEFSYSFUN 'NAMESTRING "Lnamestring" '(T) 'T NIL NIL) (DEFSYSFUN 'UNREAD-CHAR "Lunread_char" '(T *) 'T NIL NIL) (DEFSYSFUN 'CDAAR "Lcdaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CADAR "Lcadar" '(T) 'T NIL NIL) (DEFSYSFUN 'CAADR "Lcaadr" '(T) 'T NIL NIL) (DEFSYSFUN 'CHAR= "Lchar_eq" '(T *) 'T NIL T) (DEFSYSFUN 'ALPHA-CHAR-P "Lalpha_char_p" '(T) 'T NIL T) (DEFSYSFUN 'STRING-TRIM "Lstring_trim" '(T T) 'STRING NIL NIL) (DEFSYSFUN 'MAKE-PACKAGE "Lmake_package" '(T *) 'T NIL NIL) (DEFSYSFUN 'CLOSE "Lclose" '(T *) 'T NIL NIL) (DEFSYSFUN 'DENOMINATOR "Ldenominator" '(T) 'T NIL NIL) (DEFSYSFUN 'FLOAT "Lfloat" '(T *) 'T NIL NIL) ;(DEFSYSFUN 'FIRST "Lcar" '(T) 'T NIL NIL) (DEFSYSFUN 'ROUND "Lround" '(T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'SUBST "Lsubst" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'UPPER-CASE-P "Lupper_case_p" '(T) 'T NIL T) (DEFSYSFUN 'ARRAY-ELEMENT-TYPE "Larray_element_type" '(T) 'T NIL NIL) (DEFSYSFUN 'ADJOIN "Ladjoin" '(T T *) 'T NIL NIL) (DEFSYSFUN 'LOGAND "Llogand" '(*) 'T NIL NIL) (DEFSYSFUN 'MAPCON "Lmapcon" '(T T *) 'T NIL NIL) (DEFSYSFUN 'INTERN "Lintern" '(T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'VALUES "Lvalues" '(*) '* NIL NIL) (DEFSYSFUN 'EXPORT "Lexport" '(T *) 'T NIL NIL) (DEFSYSFUN '* "Ltimes" '(*) 'T NIL NIL) (DEFSYSFUN '< "Lmonotonically_increasing" '(T *) 'T NIL T) (DEFSYSFUN 'COMPLEX "Lcomplex" '(T *) 'T NIL NIL) (DEFSYSFUN 'SET-SYNTAX-FROM-CHAR "Lset_syntax_from_char" '(T T *) 'T NIL NIL) (DEFSYSFUN 'CHAR-BIT "Lchar_bit" '(T T) 'FIXNUM NIL NIL) (DEFSYSFUN 'INTEGER-LENGTH "Linteger_length" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'PACKAGEP "Lpackagep" '(T) 'T NIL T) (DEFSYSFUN 'INPUT-STREAM-P "Linput_stream_p" '(T) 'T NIL T) (DEFSYSFUN '>= "Lmonotonically_nonincreasing" '(T *) 'T NIL T) (DEFSYSFUN 'PATHNAME "Lpathname" '(T) 'T NIL NIL) ;(DEFSYSFUN 'EQ "Leq" '(T T) 'T NIL T) (DEFSYSFUN 'MAKE-CHAR "Lmake_char" '(T *) 'CHARACTER NIL NIL) (DEFSYSFUN 'FILE-NAMESTRING "Lfile_namestring" '(T) 'STRING NIL NIL) (DEFSYSFUN 'CHARACTER "Lcharacter" '(T) 'CHARACTER NIL NIL) (DEFSYSFUN 'SYMBOL-FUNCTION "Lsymbol_function" '(T) 'T NIL NIL) (DEFSYSFUN 'CONSTANTP "Lconstantp" '(T) 'T NIL T) (DEFSYSFUN 'CHAR-EQUAL "Lchar_equal" '(T *) 'T NIL T) (DEFSYSFUN 'TREE-EQUAL "Ltree_equal" '(T T *) 'T NIL T) (DEFSYSFUN 'CDDR "Lcddr" '(T) 'T NIL NIL) (DEFSYSFUN 'GETF "Lgetf" '(T T *) 'T NIL NIL) (DEFSYSFUN 'SAVE "Lsave" '(T) 'T NIL NIL) (DEFSYSFUN 'MAKE-RANDOM-STATE "Lmake_random_state" '(*) 'T NIL NIL) (DEFSYSFUN 'CHAR-NOT-GREATERP "Lchar_not_greaterp" '(T *) 'T NIL T) (DEFSYSFUN 'EXPT "Lexpt" '(T T) 'T NIL NIL) (DEFSYSFUN 'SQRT "Lsqrt" '(T) 'T NIL NIL) (DEFSYSFUN 'SCALE-FLOAT "Lscale_float" '(T T) 'T NIL NIL) (DEFSYSFUN 'CHAR> "Lchar_g" '(T *) 'T NIL T) (DEFSYSFUN 'LDIFF "Lldiff" '(T T) 'T NIL NIL) (DEFSYSFUN 'ASSOC-IF-NOT "Lassoc_if_not" '(T T) 'T NIL NIL) (DEFSYSFUN 'BIT-VECTOR-P "Lbit_vector_p" '(T) 'T NIL T) (DEFSYSFUN 'NSTRING-CAPITALIZE "Lnstring_capitalize" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'SYMBOL-VALUE "Lsymbol_value" '(T) 'T NIL NIL) (DEFSYSFUN 'RPLACD "Lrplacd" '(T T) 'T NIL NIL) (DEFSYSFUN 'BOUNDP "Lboundp" '(T) 'T NIL T) ;(DEFSYSFUN 'EQUALP "Lequalp" '(T T) 'T NIL T) (DEFSYSFUN 'SIMPLE-BIT-VECTOR-P "Lsimple_bit_vector_p" '(T) 'T NIL T) (DEFSYSFUN 'MEMBER-IF-NOT "Lmember_if_not" '(T T *) 'T NIL NIL) (DEFSYSFUN 'MAKE-TWO-WAY-STREAM "Lmake_two_way_stream" '(T T) 'T NIL NIL) (DEFSYSFUN 'PARSE-INTEGER "Lparse_integer" '(T *) 'T NIL NIL) (DEFSYSFUN '+ "Lplus" '(*) 'T NIL NIL) (DEFSYSFUN '= "Lall_the_same" '(T *) 'T NIL T) (DEFSYSFUN 'GENTEMP "Lgentemp" '(*) 'T NIL NIL) (DEFSYSFUN 'RENAME-PACKAGE "Lrename_package" '(T T *) 'T NIL NIL) (DEFSYSFUN 'COMMONP "Lcommonp" '(T) 'T NIL T) (DEFSYSFUN 'NUMBERP "Lnumberp" '(T) 'T NIL T) (DEFSYSFUN 'COPY-READTABLE "Lcopy_readtable" '(*) 'T NIL NIL) (DEFSYSFUN 'RANDOM-STATE-P "Lrandom_state_p" '(T) 'T NIL T) (DEFSYSFUN 'DIRECTORY-NAMESTRING "Ldirectory_namestring" '(T) 'STRING NIL NIL) (DEFSYSFUN 'STANDARD-CHAR-P "Lstandard_char_p" '(T) 'T NIL T) (DEFSYSFUN 'TRUENAME "Ltruename" '(T) 'T NIL NIL) (DEFSYSFUN 'IDENTITY "Lidentity" '(T) 'T NIL NIL) (DEFSYSFUN 'NREVERSE "Lnreverse" '(T) 'T NIL NIL) (DEFSYSFUN 'PATHNAME-DEVICE "Lpathname_device" '(T) 'T NIL NIL) (DEFSYSFUN 'UNINTERN "Lunintern" '(T *) 'T NIL NIL) (DEFSYSFUN 'UNEXPORT "Lunexport" '(T *) 'T NIL NIL) (DEFSYSFUN 'FLOAT-PRECISION "Lfloat_precision" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'STRING-DOWNCASE "Lstring_downcase" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'CAR "Lcar" '(T) 'T NIL NIL) (DEFSYSFUN 'CONJUGATE "Lconjugate" '(T) 'T NIL NIL) (DEFSYSFUN 'NOT "Lnull" '(T) 'T NIL T) (DEFSYSFUN 'READ-CHAR-NO-HANG "Lread_char_no_hang" '(*) 'T NIL NIL) (DEFSYSFUN 'FRESH-LINE "Lfresh_line" '(*) 'T NIL NIL) (DEFSYSFUN 'WRITE-CHAR "Lwrite_char" '(T *) 'T NIL NIL) (DEFSYSFUN 'PARSE-NAMESTRING "Lparse_namestring" '(T *) 'T NIL NIL) (DEFSYSFUN 'STRING-NOT-LESSP "Lstring_not_lessp" '(T T *) 'T NIL NIL) (DEFSYSFUN 'CHAR "Lchar" '(T T) 'CHARACTER NIL NIL) (DEFSYSFUN 'AREF "Laref" '(T *) 'T NIL NIL) (DEFSYSFUN 'PACKAGE-NICKNAMES "Lpackage_nicknames" '(T) 'T NIL NIL) (DEFSYSFUN 'ENDP "Lendp" '(T) 'T NIL T) (DEFSYSFUN 'ODDP "Loddp" '(T) 'T NIL T) (DEFSYSFUN 'CHAR-UPCASE "Lchar_upcase" '(T) 'CHARACTER NIL NIL) (DEFSYSFUN 'LIST* "LlistA" '(T *) 'T NIL NIL) (DEFSYSFUN 'VALUES-LIST "Lvalues_list" '(T) '* NIL NIL) ;(DEFSYSFUN 'EQUAL "Lequal" '(T T) 'T NIL T) (DEFSYSFUN 'DIGIT-CHAR-P "Ldigit_char_p" '(T *) 'T NIL NIL) ;; #-clcs (DEFSYSFUN 'ERROR "Lerror" '(T *) 'T NIL NIL) (DEFSYSFUN 'CHAR/= "Lchar_neq" '(T *) 'T NIL T) (DEFSYSFUN 'PATHNAME-DIRECTORY "Lpathname_directory" '(T) 'T NIL NIL) (DEFSYSFUN 'CDAAAR "Lcdaaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CADAAR "Lcadaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CAADAR "Lcaadar" '(T) 'T NIL NIL) (DEFSYSFUN 'CAAADR "Lcaaadr" '(T) 'T NIL NIL) (DEFSYSFUN 'CDDDDR "Lcddddr" '(T) 'T NIL NIL) (DEFSYSFUN 'GET-MACRO-CHARACTER "Lget_macro_character" '(T *) 'T NIL NIL) (DEFSYSFUN 'FORMAT "Lformat" '(T T *) 'T NIL NIL) (DEFSYSFUN 'COMPILED-FUNCTION-P "Lcompiled_function_p" '(T) 'T NIL T) (DEFSYSFUN 'SUBLIS "Lsublis" '(T T *) 'T NIL NIL) (DEFSYSFUN 'PATHNAME-NAME "Lpathname_name" '(T) 'T NIL NIL) (DEFSYSFUN 'IMPORT "Limport" '(T *) 'T NIL NIL) (DEFSYSFUN 'LOGXOR "Llogxor" '(*) 'T NIL NIL) (DEFSYSFUN 'RASSOC-IF-NOT "Lrassoc_if_not" '(T T) 'T NIL NIL) (DEFSYSFUN 'CHAR-GREATERP "Lchar_greaterp" '(T *) 'T NIL T) (DEFSYSFUN 'MAKE-SYNONYM-STREAM "Lmake_synonym_stream" '(T) 'T NIL NIL) (DEFSYSFUN 'ALPHANUMERICP "Lalphanumericp" '(T) 'T NIL T) (DEFSYSFUN 'REMHASH "Lremhash" '(T T) 'T NIL NIL) (DEFSYSFUN 'NRECONC "Lreconc" '(T T) 'T NIL NIL) (DEFSYSFUN '> "Lmonotonically_decreasing" '(T *) 'T NIL T) (DEFSYSFUN 'LOGBITP "Llogbitp" '(T T) 'T NIL T) (DEFSYSFUN 'MAPLIST "Lmaplist" '(T T *) 'T NIL NIL) (DEFSYSFUN 'VECTORP "Lvectorp" '(T) 'T NIL T) (DEFSYSFUN 'ASSOC-IF "Lassoc_if" '(T T) 'T NIL NIL) (DEFSYSFUN 'GET-PROPERTIES "Lget_properties" '(T T) '* NIL NIL) (DEFSYSFUN 'STRING<= "Lstring_le" '(T T *) 'T NIL NIL) (DEFSYSFUN 'EVALHOOK "Levalhook" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'FILE-WRITE-DATE "Lfile_write_date" '(T) 'T NIL NIL) (DEFSYSFUN 'LOGCOUNT "Llogcount" '(T) 'T NIL NIL) (DEFSYSFUN 'MERGE-PATHNAMES "Lmerge_pathnames" '(T *) 'T NIL NIL) (DEFSYSFUN 'MEMBER-IF "Lmember_if" '(T T *) 'T NIL NIL) (DEFSYSFUN 'READ-BYTE "Lread_byte" '(T *) 'T NIL NIL) (DEFSYSFUN 'SIMPLE-VECTOR-P "Lsimple_vector_p" '(T) 'T NIL T) (DEFSYSFUN 'CHAR-BITS "Lchar_bits" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'COPY-TREE "Lcopy_tree" '(T) 'T NIL NIL) (DEFSYSFUN 'GCD "Lgcd" '(*) 'T NIL NIL) (DEFSYSFUN 'BYE "Lby" 'NIL 'T NIL NIL) ;(DEFSYSFUN 'QUIT "Lquit" 'NIL 'T NIL NIL) ;(DEFSYSFUN 'EXIT "Lexit" 'NIL 'T NIL NIL) (DEFSYSFUN 'GET "Lget" '(T T *) 'T NIL NIL) (DEFSYSFUN 'MOD "Lmod" '(T T) 'T NIL NIL) (DEFSYSFUN 'DIGIT-CHAR "Ldigit_char" '(T *) 'CHARACTER NIL NIL) (DEFSYSFUN 'PROBE-FILE "Lprobe_file" '(T) 'T NIL NIL) (DEFSYSFUN 'STRING-LEFT-TRIM "Lstring_left_trim" '(T T) 'STRING NIL NIL) (DEFSYSFUN 'PATHNAME-VERSION "Lpathname_version" '(T) 'T NIL NIL) (DEFSYSFUN 'WRITE-LINE "Lwrite_line" '(T *) 'T NIL NIL) (DEFSYSFUN 'EVAL "Leval" '(T) 'T NIL NIL) (DEFSYSFUN 'ATOM "Latom" '(T) 'T NIL T) (DEFSYSFUN 'CDDAR "Lcddar" '(T) 'T NIL NIL) (DEFSYSFUN 'CDADR "Lcdadr" '(T) 'T NIL NIL) (DEFSYSFUN 'CADDR "Lcaddr" '(T) 'T NIL NIL) (DEFSYSFUN 'FMAKUNBOUND "Lfmakunbound" '(T) 'T NIL NIL) (DEFSYSFUN 'SLEEP "Lsleep" '(T) 'T NIL NIL) (DEFSYSFUN 'PACKAGE-NAME "Lpackage_name" '(T) 'T NIL NIL) (DEFSYSFUN 'FIND-PACKAGE "Lfind_package" '(T) 'T NIL NIL) (DEFSYSFUN 'ASSOC "Lassoc" '(T T *) 'T NIL NIL) (DEFSYSFUN 'SET-CHAR-BIT "Lset_char_bit" '(T T T) 'CHARACTER NIL NIL) (DEFSYSFUN 'FLOOR "Lfloor" '(T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'WRITE "Lwrite" '(T *) 'T NIL NIL) (DEFSYSFUN 'PLUSP "Lplusp" '(T) 'T NIL T) (DEFSYSFUN 'FLOAT-DIGITS "Lfloat_digits" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'READ-DELIMITED-LIST "Lread_delimited_list" '(T *) 'T NIL NIL) (DEFSYSFUN 'APPEND "Lappend" '(*) 'T NIL NIL) (DEFSYSFUN 'MEMBER "Lmember" '(T T *) 'T NIL NIL) (DEFSYSFUN 'STRING-LESSP "Lstring_lessp" '(T T *) 'T NIL NIL) (DEFSYSFUN 'RANDOM "Lrandom" '(T *) 'T NIL NIL) (DEFSYSFUN 'SYSTEM::SPECIALP "siLspecialp" '(T) 'T NIL T) (DEFSYSFUN 'SYSTEM::OUTPUT-STREAM-STRING "siLoutput_stream_string" '(T) 'T NIL NIL) ;#-clcs (DEFSYSFUN 'SYSTEM::ERROR-SET "siLerror_set" '(T) '* NIL NIL) (DEFSYSFUN 'SYSTEM::STRUCTUREP "siLstructurep" '(T) 'T NIL T) (DEFSYSFUN 'SYSTEM::COPY-STREAM "siLcopy_stream" '(T T) 'T NIL NIL) (DEFSYSFUN 'SYSTEM::INIT-SYSTEM "siLinit_system" 'NIL 'T NIL NIL) (DEFSYSFUN 'SYSTEM::STRING-TO-OBJECT "siLstring_to_object" '(T) 'T NIL NIL) (DEFSYSFUN 'SYSTEM::RESET-STACK-LIMITS "siLreset_stack_limits" 'NIL 'T NIL NIL) (DEFSYSFUN 'SYSTEM::DISPLACED-ARRAY-P "siLdisplaced_array_p" '(T) 'T NIL T) (DEFSYSFUN 'SYSTEM::RPLACA-NTHCDR "siLrplaca_nthcdr" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::LIST-NTH "siLlist_nth" NIL T NIL NIL) ;(DEFSYSFUN 'SYSTEM::MAKE-PURE-ARRAY "siLmake_pure_array" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::MAKE-VECTOR "siLmake_vector" NIL 'VECTOR NIL NIL) ;(DEFSYSFUN 'SYSTEM::ARRAY-DISPLACEMENT "siLarray_displacement" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::ASET "siLaset" '(ARRAY *) NIL NIL NIL) (DEFSYSFUN 'SYSTEM::SVSET "siLsvset" '(SIMPLE-VECTOR FIXNUM T) T NIL NIL) (DEFSYSFUN 'SYSTEM::FILL-POINTER-SET "siLfill_pointer_set" '(VECTOR FIXNUM) 'FIXNUM NIL NIL) (DEFSYSFUN 'SYSTEM::REPLACE-ARRAY "siLreplace_array" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::FSET "siLfset" '(SYMBOL T) NIL NIL NIL) ;(DEFSYSFUN 'SYSTEM::HASH-SET "siLhash_set" NIL T NIL NIL) (DEFSYSFUN 'BOOLE3 "Lboole" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::PACKAGE-INTERNAL "siLpackage_internal" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::PACKAGE-EXTERNAL "siLpackage_external" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::ELT-SET "siLelt_set" '(SEQUENCE FIXNUM T) T NIL NIL) (DEFSYSFUN 'SYSTEM::CHAR-SET "siLchar_set" '(STRING FIXNUM CHARACTER) 'CHARACTER NIL NIL) (DEFSYSFUN 'SYSTEM::MAKE-STRUCTURE "siLmake_structure" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::STRUCTURE-NAME "siLstructure_name" '(T) 'SYMBOL NIL NIL) ;; (DEFSYSFUN 'SYSTEM::STRUCTURE-REF "siLstructure_ref" '(T T FIXNUM) T NIL ;; NIL) ;; (DEFSYSFUN 'SYSTEM::STRUCTURE-SET "siLstructure_set" '(T T FIXNUM T) T ;; NIL NIL) (DEFSYSFUN 'SYSTEM::PUT-F "siLput_f" NIL '(T T) NIL NIL) (DEFSYSFUN 'SYSTEM::REM-F "siLrem_f" NIL '(T T) NIL NIL) (DEFSYSFUN 'SYSTEM::SET-SYMBOL-PLIST "siLset_symbol_plist" '(SYMBOL T) T NIL NIL) (DEFSYSFUN 'SI::BIT-ARRAY-OP "siLbit_array_op" NIL T NIL NIL) (dolist (l '(eq eql equal equalp ldb-test logtest)) (setf (get l 'predicate) t)) gcl/cmpnew/gcl_make-fn.lsp000077500000000000000000000001541242227143400160030ustar00rootroot00000000000000(load (concatenate 'string si::*system-directory* "../cmpnew/gcl_collectfn")) (compiler::emit-fn t) gcl/cmpnew/gcl_make_ufun.lsp000077500000000000000000000062671242227143400164520ustar00rootroot00000000000000;;; MAKE_UFUN Makes Ufun list for user-defined functions. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (defvar gazonk (make-package 'symbol-table :use nil)) (defvar eof (cons nil nil)) (defvar *Ufun-out*) (defvar *str* (make-array 128 :element-type 'string-char :fill-pointer 0)) (defun make-Ufun (in-files &key (out-file "Ufun_list.lsp")) (with-open-file (*Ufun-out* out-file :direction :output) (print '(in-package "COMPILER") *Ufun-out*) (dolist (file in-files) (with-open-file (in (merge-pathnames file #".lsp")) (loop (when (eq (setq form (read in nil eof)) eof) (return)) (do-form form)))))) (defun do-form (form) (when (consp form) (case (car form) (defun (let ((*package* (find-package 'compiler))) (print `(si:putprop ',(cadr form) ,(get-cname (cadr form)) 'Ufun) *Ufun-out*)) (eval form)) (progn (mapc #'do-form (cdr form))) (eval-when (if (member 'load (cadr form)) (mapc #'do-form (cddr form)) (if (member 'compile (cadr form)) (mapc #'eval (cddr form))))) (t (if (macro-function (car form)) (do-form (macroexpand-1 form)) (eval form)))))) (defun get-cname (symbol &aux (name (symbol-name symbol))) (setf (fill-pointer *str*) 0) (vector-push #\U *str*) (dotimes (n (length name)) (let ((char (schar name n))) (cond ((alphanumericp char) (vector-push (char-downcase char) *str*)) ((char= char #\-) (vector-push #\_ *str*)) ((char= char #\*) (vector-push #\A *str*)) ))) (multiple-value-bind (foo flag) (find-symbol *str* 'symbol-table) (unless flag ;(setq foo (intern (copy-seq *str*) 'symbol-table)) (setq foo (intern *str* 'symbol-table)) ;(set foo nil) (return-from get-cname *str*)) (gensym *str*) (gensym 0) (loop (setq name (symbol-name (gensym))) (multiple-value-bind (foo flag1) (intern name 'symbol-table) (unless flag1 ;(set foo nil) (return-from get-cname name))))) ) gcl/cmpnew/gcl_nocmpinc.lsp000077500000000000000000000007071242227143400162770ustar00rootroot00000000000000 (in-package 'compiler) (defvar *cmpinclude-string* nil) (defun write-out-cmpinclude (stream string) (do ((i 0 (setq i (the fixnum (+ i 1)))) (l (length *cmpinclude-string*))) ((>= i l)) (declare (fixnum i l)) (or string (setq string *cmpinclude-string*)) (or string (error "need a string")) (let ((tem (aref (the string string i)))) (declare (character tem)) (write-char tem stream)))) gcl/cmpnew/makefile000066400000000000000000000033331242227143400146170ustar00rootroot00000000000000 .SUFFIXES: .SUFFIXES: .o .c .lsp .lisp .fn -include ../makedefs PORTDIR = ../unixport CAT=cat APPEND=../xbin/append OBJS = gcl_cmpbind.o gcl_cmpblock.o gcl_cmpcall.o gcl_cmpcatch.o gcl_cmpenv.o gcl_cmpeval.o \ gcl_cmpflet.o gcl_cmpfun.o gcl_cmpif.o gcl_cmpinline.o gcl_cmplabel.o gcl_cmplam.o gcl_cmplet.o \ gcl_cmploc.o gcl_cmpmap.o gcl_cmpmulti.o gcl_cmpspecial.o gcl_cmptag.o gcl_cmptop.o \ gcl_cmptype.o gcl_cmputil.o gcl_cmpvar.o gcl_cmpvs.o gcl_cmpwt.o gcl_cmpmain.o #gcl_cmpopt.o gcl_lfun_list.o FNS:= $(OBJS:.o=.fn) LISP=$(PORTDIR)/saved_pre_gcl$(EXE) COMPILE_FILE=$(LISP) $(PORTDIR) -system-p -c-file -data-file -h-file -compile %.o: $(PORTDIR)/saved_pre_gcl$(EXE) %.lsp $(COMPILE_FILE) $* all: $(OBJS) .lsp.fn: ../cmpnew/gcl_collectfn.o ../xbin/make-fn $*.lsp $(LISP) fns1: $(FNS) fns: ../cmpnew/gcl_collectfn.o $(MAKE) fns1 -e "FNS=`echo ${OBJS} | sed -e 's:\.o:\.fn:g'`" gcl_collectfn.o: $(PORTDIR)/saved_pre_gcl$(EXE) $(PORTDIR)/ -compile $*.lsp .lisp.o: @ ../xbin/if-exists $(PORTDIR)/saved_pre_gcl$(EXE) \ "$(PORTDIR)/saved_pre_gcl$(EXE) $(PORTDIR)/ -compile $*.lisp " sys-proclaim.lisp: fns echo '(in-package "COMPILER")' \ '(load "../cmpnew/gcl_collectfn")(load "../lsp/sys-proclaim.lisp")'\ '(compiler::make-all-proclaims "*.fn")' | ../xbin/gcl newfn: $(MAKE) `echo $(OBJS) | sed -e 's:\.o:.fn:g'` remake: for v in `"ls" *.lsp.V | sed -e "s:\.lsp\.V::g"` ; \ do rm -f $$v.c $$v.h $$v.data $$v.lsp $$v.o ; \ ln -s $(MAINDIR)/cmpnew/$$v.c . ; ln -s $(MAINDIR)/cmpnew/$$v.h . ; \ ln -s $(MAINDIR)/cmpnew/$$v.data . ; \ done rm -f ../unixport/$(FLISP) (cd .. ; $(MAKE) sources) (cd .. ; $(MAKE)) (cd .. ; $(MAKE)) clean: rm -f *.o core a.out *.fn *.c *.data *.h allclean: rm -f *.h *.data *.c gcl/cmpnew/so_locations000077500000000000000000000001751242227143400155420ustar00rootroot00000000000000collectfn.o \ :st = .text 0x000000005ffe0000, 0x0000000000010000:\ :st = .data 0x000000005fff0000, 0x0000000000010000:\ gcl/cmpnew/sys-proclaim.lisp000077500000000000000000000222371242227143400164410ustar00rootroot00000000000000 (IN-PACKAGE "COMPILER") (MAPC (LAMBDA (X) (SETF (GET X 'PROCLAIMED-CLOSURE) T)) '(CMP-TMP-MACRO COMPILE DISASSEMBLE CMP-ANON)) (PROCLAIM '(FTYPE (FUNCTION (STRING *) T) TS)) (PROCLAIM '(FTYPE (FUNCTION (T) T) VAR-REP-LOC C1FUNOB C1STRUCTURE-REF T1PROGN GET-RETURN-TYPE ADD-REG1 C1VAR C1ECASE C1SHARP-COMMA C1ASH LTVP CTOP-WRITE C2FUNCTION DECLARATION-TYPE C1TERPRI C1FUNCALL VAR-REGISTER C1ASSOC CONS-TO-LISTA WT-LIST C1NTHCDR-CONDITION C1MULTIPLE-VALUE-CALL CHECK-DOWNWARD TYPE-FILTER C2TAGBODY-LOCAL BLK-NAME C1FSET T1DEFENTRY C1MEMBER C1GETHASH C2GO-CCB SCH-LOCAL-FUN C1RPLACD C1RPLACA-NTHCDR INLINE-POSSIBLE C1MAPC C2VAR WT-FUNCALL-C C1ADD-GLOBALS FUN-NAME SAVE-FUNOB FUN-CFUN PROCLAIM TAG-REF-CCB FIXNUM-LOC-P UNWIND-NO-EXIT WT-H1 MAXARGS C1GO INFO-P TAG-P C1AND INLINE-TYPE VAR-REF-CCB C1MULTIPLE-VALUE-BIND C1THE C2DM-RESERVE-VL WT-DOWNWARD-CLOSURE-MACRO VAR-NAME C1THROW INFO-TYPE C1ASH-CONDITION LTVP-EVAL CHARACTER-LOC-P C2DOWNWARD-FUNCTION C1EXPR C1TAGBODY BLK-REF INFO-VOLATILE VAR-REF CONSTANT-FOLD-P WT-DATA-PACKAGE-OPERATION FUN-P VAR-LOC C1PROGN C1NTHCDR VOLATILE TAG-UNWIND-EXIT REPLACE-CONSTANT NAME-TO-SD SET-TOP C1GET PUSH-ARGS FUN-REF-CCB INLINE-BOOLE3-STRING C1SETQ C1LOCAL-CLOSURE CLINK GET-INCLUDED SET-PUSH-CATCH-FRAME FUNCTION-ARG-TYPES T2DECLARE OBJECT-TYPE CHECK-VREF COPY-INFO T1DEFINE-STRUCTURE C1BOOLE3 FUN-LEVEL C1NTH C2GET FIX-OPT C1OR FUNCTION-RETURN-TYPE T1DEFUN T1CLINES FLAGS-POS SAVE-AVMA WT-DOWN C2GO-CLB C1SWITCH WT-SWITCH-CASE C1FUNCTION C2RPLACD C1LABELS C1MULTIPLE-VALUE-SETQ WT-VV C2TAGBODY-CLB WT-CADR C1MAPCAR MACRO-DEF-P T1DEFMACRO SET-RETURN THE-PARAMETER BLK-REF-CCB AET-C-TYPE PUSH-ARGS-LISPCALL WRITE-BLOCK-OPEN SET-UP-VAR-CVS TAG-VAR INFO-SP-CHANGE ADD-LOOP-REGISTERS C1MULTIPLE-VALUE-PROG1 WT-VS C2LOCATION C1COMPILER-LET T3CLINES RESULT-TYPE PROCLAMATION C1MAPL C1PRINC TAG-LABEL C2FUNCALL-AUX BLK-VAR TAG-REF-CLB C2TAGBODY-CCB VERIFY-DATA-VECTOR C1MAPCAN BLK-EXIT WT-VS-BASE REGISTER UNDEFINED-VARIABLE SYSTEM:UNDEF-COMPILER-MACRO C1BLOCK C1MAPLIST ARGS-CAUSE-SIDE-EFFECT C2BIND C1LET WT-SYMBOL-FUNCTION CMP-MACRO-FUNCTION WT1 C1MEMQ BLK-REF-CLB ADD-ADDRESS GET-LOCAL-ARG-TYPES C1UNWIND-PROTECT REP-TYPE ADD-CONSTANT C1IF C1QUOTE C1FMLA-CONSTANT WT-DATA1 NAME-SD1 BLK-P C1CATCH CMP-MACROEXPAND SHORT-FLOAT-LOC-P T3ORDINARY C1LENGTH NEED-TO-SET-VS-POINTERS C1DOWNWARD-FUNCTION C1FLET TAG-SWITCH TAG-REF PARSE-CVSPECS TAG-NAME VAR-P VAR-KIND C1VREF C2GETHASH LONG-FLOAT-LOC-P C1MAPCON C1NTH-CONDITION WT-FUNCTION-LINK WT-VAR-DECL C1STACK-LET ADD-SYMBOL T1DEFLA C2EXPR* C1LOAD-TIME-VALUE C1DM-BAD-KEY C1PROGV FSET-FN-NAME C2VALUES FUN-REF C2VAR-KIND C1PSETQ VARARG-P T1ORDINARY C2GO-LOCAL C1LET* C2DM-RESERVE-V PUSH-DATA-INCF C1DEFINE-STRUCTURE DEFAULT-INIT MDELETE-FILE C1BOOLE-CONDITION C2RPLACA C1VALUES GET-ARG-TYPES WT-CAR FUN-INFO C1DECLARE C1STRUCTURE-SET WT-VS* CMP-MACROEXPAND-1 SCH-GLOBAL GET-LOCAL-RETURN-TYPE C1EVAL-WHEN C2TAGBODY-BODY C1APPLY C1LOCAL-FUN C1MACROLET ADD-OBJECT C1RETURN-FROM SAFE-SYSTEM RESET-INFO-TYPE T1DEFCFUN C1RPLACA WT-CDR VAR-TYPE T1MACROLET C1LIST-NTH INFO-CHANGED-ARRAY INFO-REFERRED-ARRAY BLK-VALUE-TO-GO ADD-OBJECT2 WT-CCB-VS)) (PROCLAIM '(FTYPE (FUNCTION (*) *) INLINE-BOOLE3)) (PROCLAIM '(FTYPE (FUNCTION (T) FIXNUM) F-TYPE)) (PROCLAIM '(FTYPE (FUNCTION (T (VECTOR T) FIXNUM T) FIXNUM) PUSH-ARRAY)) (PROCLAIM '(FTYPE (FUNCTION (T (VECTOR T) FIXNUM FIXNUM T) FIXNUM) BSEARCHLEQ)) (PROCLAIM '(FTYPE (FUNCTION (T) *) C2EXPR WT-FIXNUM-LOC WT-LONG-FLOAT-LOC C2OR WT-SHORT-FLOAT-LOC CMP-EVAL C2PROGN WT-TO-STRING SET-LOC CMP-TOPLEVEL-EVAL VV-STR T1EXPR T1EVAL-WHEN WT-LOC C2AND WT-CHARACTER-LOC)) (PROCLAIM '(FTYPE (FUNCTION (*) T) FCALLN-INLINE MAKE-BLK MAKE-FUN LIST*-INLINE WT-CLINK COMPILE-FILE C2FSET MAKE-TAG CS-PUSH LIST-INLINE MAKE-VAR COMPILER-COMMAND MAKE-INFO)) (PROCLAIM '(FTYPE (FUNCTION (STRING FIXNUM FIXNUM) T) DASH-TO-UNDERSCORE-INT)) (PROCLAIM '(FTYPE (FUNCTION (T T T) *) C2COMPILER-LET C2FLET C2LABELS C2IF WT-INLINE)) (PROCLAIM '(FTYPE (FUNCTION (T T *) *) T3DEFUN-AUX)) (PROCLAIM '(FTYPE (FUNCTION (T T T T) *) C1DM-V C2RETURN-FROM C2DM C1DM-VL C2APPLY-OPTIMIZE)) (PROCLAIM '(FTYPE (FUNCTION (T T) T) C2APPLY C2RETURN-CCB C2BIND-INIT PROCLAIM-VAR PRIN1-CMP C2LAMBDA-EXPR-WITH-KEY SYSTEM::ADD-DEBUG C2LAMBDA-EXPR-WITHOUT-KEY C2STACK-LET MULTIPLE-VALUE-CHECK C1DECL-BODY COMPILER-CC C1EXPR* C2MULTIPLE-VALUE-PROG1 CO1VECTOR-PUSH ARGS-INFO-CHANGED-VARS C2DM-BIND-INIT C1PROGN* CO1WRITE-CHAR COERCE-LOC WT-FIXNUM-VALUE IS-REP-REFERRED C2MULTIPLE-VALUE-CALL CO1SPECIAL-FIX-DECL INLINE-PROC WT-CHARACTER-VALUE SET-VS C2PSETQ T3SHARP-COMMA STRUCT-TYPE-OPT WT-MAKE-DCLOSURE C2DM-BIND-VL SET-JUMP-TRUE DO-MACRO-EXPANSION CO1SCHAR C2BLOCK-CLB C2LIST-NTH-IMMEDIATE C2DM-BIND-LOC WT-LONG-FLOAT-VALUE CO1CONS COMPILER-CLEAR-COMPILER-PROPERTIES C2EXPR-TOP ARGS-INFO-REFERRED-VARS C2MEMBER!2 C2MULTIPLE-VALUE-SETQ C2SETQ ADD-DEBUG-INFO GET-INLINE-LOC RESULT-TYPE-FROM-ARGS C2BIND-LOC CO1STRUCTURE-PREDICATE C1ARGS SHIFT<< UNWIND-BDS MAYBE-EVAL C2UNWIND-PROTECT TYPE-AND C2CALL-LOCAL C2THROW CO1TYPEP SET-BDS-BIND C1SETQ1 C2CATCH TYPE>= C1LAMBDA-FUN NEED-TO-PROTECT C2ASSOC!2 CO1READ-BYTE CO1LDB CONVERT-CASE-TO-SWITCH FAST-READ MAKE-USER-INIT CO1CONSTANT-FOLD C1FMLA CHECK-FNAME-ARGS COERCE-LOC-STRUCTURE-REF WT-SHORT-FLOAT-VALUE C2BLOCK-CCB ADD-INFO CAN-BE-REPLACED CO1READ-CHAR C2CALL-LAMBDA CFAST-WRITE PUSH-CHANGED-VARS SHIFT>> JUMPS-TO-P CO1SUBLIS C1CONSTANT-VALUE C2RETURN-CLB WT-VAR CHECK-END C2EXPR-TOP* WT-V*-MACROS SET-JUMP-FALSE CMPFIX-ARGS SET-DBIND CO1WRITE-BYTE CO1EQL COMPILER-DEF-HOOK WT-REQUIREDS)) (PROCLAIM '(FTYPE (FUNCTION (T *) *) COMPILE-FILE1)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM FIXNUM) T) MLIN)) (PROCLAIM '(FTYPE (FUNCTION (STRING) T) DASH-TO-UNDERSCORE)) (PROCLAIM '(FTYPE (FUNCTION (T T) FIXNUM) PROCLAIMED-ARGD ANALYZE-REGS1 ANALYZE-REGS)) (PROCLAIM '(FTYPE (FUNCTION (T FIXNUM) T) MEMOIZED-HASH-EQUAL)) (PROCLAIM '(FTYPE (FUNCTION ((VECTOR T)) T) COPY-ARRAY)) (PROCLAIM '(FTYPE (FUNCTION (T T) *) C2BLOCK-LOCAL C1SYMBOL-FUN C1BODY C2BLOCK C2DECL-BODY C2RETURN-LOCAL NCONC-FILES WT-INLINE-LOC COMPILER-BUILD)) (PROCLAIM '(FTYPE (FUNCTION (T *) T) WT-CVAR C1LAMBDA-EXPR UNWIND-EXIT CMPWARN WT-COMMENT WT-INTEGER-LOC CMPERR ADD-INIT FAST-LINK-PROCLAIMED-TYPE-P CMPNOTE C1CASE INIT-NAME)) (PROCLAIM '(FTYPE (FUNCTION (T T T T) T) T3DEFUN-VARARG C2STRUCTURE-REF C2CALL-UNKNOWN-GLOBAL C1MAKE-VAR C2SWITCH WT-GLOBAL-ENTRY C2CALL-GLOBAL T3INIT-FUN MY-CALL T3DEFUN-NORMAL)) (PROCLAIM '(FTYPE (FUNCTION (T T T) T) CJT WT-INLINE-INTEGER CMP-EXPAND-MACRO CHECK-FORM-TYPE SET-VAR C2CASE ADD-FUNCTION-PROCLAMATION INLINE-TYPE-MATCHES T3DEFCFUN C2MAPCAN AND-FORM-TYPE C2PROGV C1DM WT-INLINE-CHARACTER C2MULTIPLE-VALUE-BIND C2FUNCALL-SFUN C2LET MYSUB C-FUNCTION-NAME WT-MAKE-CCLOSURE C2GO WT-INLINE-COND ADD-FAST-LINK C1STRUCTURE-REF1 C2MAPCAR BOOLE3 TOO-FEW-ARGS FIX-DOWN-ARGS COMPILER-PASS2 GET-INLINE-INFO C2LET* WT-INLINE-SHORT-FLOAT WT-IF-PROCLAIMED C2PRINC ASSIGN-DOWN-VARS WT-INLINE-LONG-FLOAT C2TAGBODY C1MAP-FUNCTIONS CHECK-VDECL MAKE-INLINE-STRING WT-INLINE-FIXNUM C2MAPC CAN-BE-REPLACED* SUBLIS1-INLINE TOO-MANY-ARGS ADD-FUNCTION-DECLARATION CJF)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T *) T) T3LOCAL-DCFUN T3LOCAL-FUN)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T) T) T2DEFUN T3DEFUN C2STRUCTURE-SET C1APPLY-OPTIMIZE T3DEFUN-LOCAL-ENTRY)) (PROCLAIM '(FTYPE (FUNCTION (T T T *) T) WT-SIMPLE-CALL GET-OUTPUT-PATHNAME)) (PROCLAIM '(FTYPE (FUNCTION (T T *) T) INLINE-ARGS C2FUNCALL C2LAMBDA-EXPR LINK)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T) T) T3DEFMACRO DEFSYSFUN T2DEFENTRY T2DEFMACRO T3DEFENTRY)) (PROCLAIM '(FTYPE (FUNCTION NIL T) WT-DATA-BEGIN PRINT-COMPILER-INFO GAZONK-NAME CCB-VS-PUSH INC-INLINE-BLOCKS PRINT-CURRENT-FORM C1NIL WT-DATA-FILE ADD-LOAD-TIME-SHARP-COMMA CVS-PUSH RESET-TOP WT-CVARS BABOON WT-FASD-DATA-FILE WT-DATA-END INIT-ENV TAIL-RECURSION-POSSIBLE WFS-ERROR C1T VS-PUSH WT-NEXT-VAR-ARG WT-FIRST-VAR-ARG WT-C-PUSH CLOSE-INLINE-BLOCKS)) gcl/comp/000077500000000000000000000000001242227143400125625ustar00rootroot00000000000000gcl/comp/bo1.lsp000077500000000000000000000104461242227143400137730ustar00rootroot00000000000000(in-package "BCOMP") (defvar *space* 0) (defmacro once-only (((v val) . res) &body body) (cond (res `(once-only ((,v,val)) (once-only ,res ,@ body))) ((and (consp val) (or (eq (car val) 'function)(eq (car val) 'quote))) `(symbol-macrolet ((,v ,val)) ,@ body)) (t (let ((w (gensym))) `(let ((,w ,val)) (symbol-macrolet ((,v ,w)) ,@ body)))))) (defun get-test (x &aux item lis res key fn) (when (<= *space* 0) (desetq (item lis . res) (cdr x)) (cond (res (desetq (key fn . res) res) (cond ((or res (not (eq key :test)) (not (and (consp fn) (member (car fn) '(quote function))))) nil) (t (cadr fn)))) (t 'eql)))) (setf (get 'assoc 'bo1) 'bo1-assoc) (defun bo1-assoc (x where &aux fn ) where (when (setq fn (get-test x)) `(funcall #'(lambda (item lis) (sloop for v in lis when (funcall #',fn (car v) item) do (return v))) ,@ (cdr x)))) (setf (get 'member 'bo1) 'bo1-member) (defun bo1-member (x where &aux fn ) where (when (setq fn (get-test x)) `(funcall #'(lambda (item lis) (sloop for v on lis when (funcall #',fn (car v) item) do (return v))) ,@ (cdr x)))) (setf (get 'get 'bo1) 'bo1-get) (defun bo1-get (x where) where (when (and (= *safety* 0) (< *space* 2)) `(funcall #'(lambda (plis key &optional dflt) (setq plis (symbol-plist plis)) (loop (cond ((null plis) (return dflt)) ((eq (car plis) key)(return (cadr plis))) (t (setq plis (cddr plis)))))) ,@ (cdr x)))) (setf (get 'mapcar 'bo1) 'bo1-mapcar) (setf (get 'mapc 'bo1) 'bo1-mapcar) (setf (get 'mapcan 'bo1) 'bo1-mapcar) (defun bo1-mapcar (x where &aux fn l coll) where (when (and (= *safety* 0) (< *space* 2)) (desetq (fn l) (cdr x)) (setq coll (cdr (assoc (car x) '((mapcar . collect) (mapc . do) (mapcan . nconc))))) (cond ((cdddr x) nil) ((and (consp fn) (member (car fn) '(quote function))) `(funcall #'(lambda (lis) (sloop for v in lis ,coll (funcall ,fn v))) ,@ (cddr x))) (t `(funcall #'(lambda (fn lis) (if (symbolp fn) (setq fn (symbol-function fn))) (sloop for v in lis ,coll (funcall fn v))) ,@ (cdr x)))))) (setf (get 'funcall 'bo1) 'bo1-funcall) (defun bo1-funcall (x where &aux fn tem args ll w binds) where (desetq (fn . args) (cdr x)) (cond ((and (consp fn) (or (eq (car fn) 'quote) (eq (car fn) 'function)) (consp (cdr fn)) (setq tem (cadr fn)) (symbolp tem)) `(,(cadr fn) ,@ args)) (tem (cond ((and (consp tem) (eq (car tem) 'lambda)) (desetq (ll) (cdr tem)) (setq ll (decode-ll ll)) (cond ((and (null (ll &key ll)) (null (ll &rest ll)) (null (ll &aux ll))) (sloop for v in (ll &required ll) do (desetq (w) args) (setq args (cdr args)) (push (list v w) binds)) (sloop for v in (ll &optional ll) do (cond (args (or (consp args) (comp-error "bad arglist in ~a " x)) (push (list (car v) (pop args)) binds)) (t (push (list (car v) (cadr v)) binds))) (cond ((caddr v) (push (list (caddr v) (not (null args))) binds)))) `(let ,(nreverse binds) ,@ (cddr tem))))))) (t nil))) (setf (get 'typep 'b1.5) 'b1.5-typep) (defun b1.5-typep (x where &aux (cd (third x)) (args (call-data-arglist cd))) where (let ((rt (result-type (nth 0 args))) (typ (nth 1 args))) (cond ((and (consp typ) (eq (car typ) 'dv) (subtypep rt (THIRD typ))) (get-object t))))) (defmacro dotimes ((var form &optional (val nil)) &rest body &aux (temp (gensym))) `(do* ((,temp ,form) (,var 0 (1+ ,var))) ((>= ,var ,temp) ,val) ,@ (cond ((typep form 'fixnum) `((declare (fixnum ,temp ,var))))) ,@body)) (defmacro psetq (&optional var val &rest l &aux sets types decls binds) (cond ((null var) nil) ((null l) `(setq ,var ,val)) (t (loop (push `(,(gensym) ,val) binds) (push var sets) (push (caar binds) sets) (push `(type (type-of ,var) ,(caar binds)) types) (or l (return nil)) (desetq (var val) l) (setq l (cddr l))) `(let ,(nreverse binds) (declare ,@ types) (setq ,@(nreverse sets)))))) ;; ;;- Local variables: ;;- mode:lisp ;;- version-control:t ;;- End: gcl/comp/c-pass1.lsp000077500000000000000000000035261242227143400145620ustar00rootroot00000000000000(in-package "BCOMP") (setf (get 'call-set-mv 'b1) 'b1-call-set-mv) (defun b1-call-set-mv (x where &aux form) where (desetq (nil form) x) `(call-set-mv #.(make-desk t) ,(b1-walk form 'call-set-mv))) (setf (get 'multiple-value-bind 'b1) 'b1-multiple-value-bind) (defun b1-multiple-value-bind(x where &aux vars form body ) (desetq (nil vars form . body) x) (b1-walk `(progn (call-set-mv , form) (let , (sloop for v in vars for i from 0 collect `(,v (nth-mv ,i ))) ,@ body)) where)) (setf (get 'multiple-value-setq 'b1) 'b1-multiple-value-setq) (defun b1-multiple-value-setq(x where &aux vars form body gens) (desetq (nil vars form . body) x) (setq gens (sloop for v in-list vars collect (gensym))) (b1-walk `(multiple-value-bind ,gens ,form (setq ,@ (sloop for v in vars for w in gens collect v collect w)) ,@ body) where )) (setf (get 'multiple-value-list 'b1) 'b1-multiple-value-list) (defun b1-multiple-value-list(x where &aux form ) (desetq (nil form ) x) (b1-walk `(progn (call-set-mv ,form) (list-mv)) where)) ;; replace this by storage allocation in c stack of n*multiple-value-limit ;; and then copy into this storage at each stage. Then c_apply_n ;; which funcalls a vector. (setf (get 'multiple-value-call 'b1) 'b1-multiple-value-call) (defun b1-multiple-value-call(x where &aux bod fun ) (desetq (nil fun . bod) x) (b1-walk `(apply ,fun (nconc ,@ (sloop for v in-list bod collect `(the dynamic-extent (multiple-value-list ,v))))) where )) (setf (get 'multiple-value-prog1 'b1) 'b1-multiple-value-prog1) (defun b1-multiple-value-prog1(x where &aux form bod (sym (gensym ))) (desetq (nil form . bod) x) (b1-walk `(let ((,sym (multiple-value-list ,form))) (declare (dynamic-extent ,sym)) ,@ bod (apply #'values ,sym)) where)) gcl/comp/cmpinit.lsp000077500000000000000000000011601242227143400147460ustar00rootroot00000000000000 (proclaim '(optimize (safety 2)(speed 0))) (in-package "BCOMP") (Use-package '("LISP" "SLOOP")) (or (get 'call-data 'si::s-data) (load "defs.lsp")) (or (macro-function 'dolist-safe)(load "macros.lsp")) (or (si::specialp '*top-form*) (load "top.lsp")) (or (si::specialp '*next-data*) (load "top2.lsp")) (or (si::specialp '*C-OUTPUT*) (load "top.lsp")) (or (si::specialp '*function-decls*)(load "top1.lsp")) (or (si::specialp '*immediate-types*) (load "comptype.lsp")) (or (fboundp 'flags-pos) (load "inline.lsp")) (or (si::specialp '*value*)(Load "stmt.lsp")) (or (si::specialp ' *PROMOTED-ARG-TYPES*) (load "utils.lsp")) gcl/comp/comptype.lsp000077500000000000000000000142401242227143400151460ustar00rootroot00000000000000(in-package "BCOMP") (defvar *immediate-types* '(fixnum character short-float double-float boolean)) (dolist (v '((t array package atom float pathname bignum function random-state hash-table ratio single-float rational standard-char keyword readtable stream common list sequence compiled-function complex nil signed-byte symbol cons null unsigned-byte t number simple-array vector ) (bit bit) (integer integer) (double-float long-float single-float) (character string-char) ((vector character) string simple-string) ((vector bit) bit-vector simple-bit-vector) ((vector t) simple-vector) (stream stream) (dynamic-extent dynamic-extent ) (fix-or-sf-or-df fix-or-sf-or-df) )) (dolist (w (cdr v)) (setf (get w 'comp-type) (car v)))) (dolist (v *immediate-types*) (setf (get v 'comp-type) v)) (deftype fix-or-sf-or-df nil '(or fixnum short-float double-float)) (deftype boolean nil t) (proclaim '(declaration dynamic-extent)) ;(deftype dynamic-extent nil t) (defun grab-1-decl (x decls &aux type l tem place) (tagbody (go begin) ERROR (comp-warn "bad declaration ~a" x) (return-from grab-1-decl decls) BEGIN (or (consp x) (go error)) (setq type (car x) l (cdr x)) (or (null l) (consp l) (go error)) (unless (symbolp type) (comp-warn "bad declaration ~a" x) (return-from grab-1-decl decls) ) (cond ((or (setq tem (get type 'comp-type)) (and (eq type 'type) (consp l) (setq tem (comp-type (car l))) (setq l (cdr l)))) (unless (eq t (setq tem (comp-type tem))) (or decls (setq decls (list nil))) (dolist-safe (v l) (or (symbolp v) (go error)) (push (cons v tem) (car decls))))) ((eq type 'special) (cond ((null decls) (setq decls (list nil nil))) ((null (cdr decls)) (setf (cdr decls) (list nil)))) (setq place (cdr decls)) (dolist-safe (v l) (or (symbolp v) (go error)) (push v (car place)) )) ((or (eq type 'inline) (eq type 'not-inline) (and (eq type 'ftype) (progn (desetq (type . l) l) t))) (dolist-safe (v l) (push (cons v (increment-function-decl type (function-declaration v))) *function-decls*))) (t nil))) ; (((v1 . type1) (v2 . type2) ..)(special-var1 special-var2 ..)) decls) (defun best-array-element-type (type) (cond ((or (eql t type) (null type)) t) ((memq type '(bit unsigned-char signed-char unsigned-short signed-short fixnum character )) type) ((subtypep type 'fixnum) (dolist (v '(bit unsigned-char signed-char unsigned-short signed-short) 'fixnum) (cond ((subtypep type v) (return v))))) ((eql type 'string-char) 'character) (t (or (dolist (v '(string-char bit short-float long-float)) (cond ((subtypep type v) (return v)))) t)))) (deftype type-of (x) (cond (*in-pass-1* (let ((tem (b1-walk x 'type-of))) (result-type tem))) (t t))) (defun assure-list (x) (loop (if (null x) (return t)) (if (consp x) (setq x (cdr x)) (error "expected a list ~a" x)))) (deftype struct (x) 'structure) (defun comp-type (type &aux tem element-type sizes) ;; coerce type to ones understood by compiler (cond ;((member type *immediate-types*) ;(return-from comp-type type)) ((and (symbolp type) (setq tem (get type 'comp-type))) (return-from comp-type tem)) ((and(symbolp type) (setq tem (get type 'si::deftype-definition))) (comp-type (funcall tem))) ((consp type) (cond ((eq (car type) 'struct) (list 'struct (best-array-element-type (cadr type)))) ((progn (setq type (si::normalize-type type)) nil)) ((member (car type) '(array simple-array vector simple-vector)) (when (consp (cdr type)) (setq element-type (best-array-element-type (cadr type))) (when(consp (cddr type)) (setq sizes (caddr type)) (cond ((consp sizes) (assure-list sizes) (unless (typep (second sizes) 'fixnum) (setq sizes nil))) ((typep sizes 'fixnum) ) (t (setq sizes nil)))) (cond ((or (eql sizes 1) (null (cdr sizes))) (setq tem 'vector) (setq sizes nil)) (t (setq tem 'array))) (list* tem element-type (if sizes (list sizes))))) ((eq (car type) 'integer) (if (si::sub-interval-p (cdr type) (list most-negative-fixnum most-positive-fixnum)) 'fixnum 'integer)) ((eq (car type) 'values) (if (null (cddr type)) (comp-type (second type)) (cons 'values (mapcar 'comp-type (cdr (the-list type)))))) (t t))) (t t))) (setf (get 'var 'result-type-b1) 'result-type-b1-var) (defun result-type-b1-var (x) (or (third x) t)) (defun result-type (form &aux fd) ;; compute the result type of form , where FORM is somethign ;; returned by b1-walk (cond ((consp form) (cond ((and (symbolp (car form)) (setq fd (get (car form) 'result-type-b1))) (funcall fd form)) ((and (atom (second form)) (typep (second form) 'desk)) (desk-result-type (second form))) (t t))) ((typep form 'var) (var-type form)) (t (wfs-error) ))) (setf (get 'dv 'result-type-b1) 'dv-result-type) (defun dv-result-type (x) (let ((val (third x))) (cond ((typep val 'fixnum) 'fixnum) ((typep val 'short-float) 'short-float) ((typep val 'double-float) 'double-float) ((typep val 'character) 'character) ((typep val 'character) 'character) (t t)))) (defun comp-subtypep (x y &aux xa xb) ; (cond ((and (atom x) (not (eq y t)) (not (eq x y)) ; (subtypep x y))(comp-warn "subtypep ~a ~a" x y))) (cond ((eq y t) t) ((atom x) (subtypep x y)) ((atom y) (subtypep x y)) ((member (car x) '(array struct)) (and (eq (car y) (car y)) (subtypep (cdr x) (cdr y)))) (t (subtypep x y)))) (defun type-and (a b) (if (eq a b) (return-from type-and a)) (if (eq a t) (return-from type-and b)) (if (eq b t) (return-from type-and a)) (multiple-value-bind (typ sure) (subtypep a b) sure (cond (typ (return-from type-and a)))) (multiple-value-bind (typ sure) (subtypep b a) sure (cond (typ (return-from type-and b)))) t) gcl/comp/data.lsp000077500000000000000000000057161242227143400142270ustar00rootroot00000000000000 (in-package "BCOMP") (eval-when (compile eval) (require 'FASDMACROS "../comp/fasdmacros.lsp") (defvar *data*) (defvar *data-output*) (defmacro data-vector () `(car *data*)) ) (defvar *fasd-data*) ; ; (defun verify-data-vector(vec &aux v) ; (dotimes (i (length vec)) ; (setq v (aref vec i)) ; (let ((has (si::hash-equal (cdr v) -1000))) ; (cond ((and (typep (car v) 'fixnum) ; (not (eql (car v) has))) ; (cmpwarn "A form or constant:~% ~s ~%has changed during the eval compile procedure!.~% The changed form will be the one put in the compiled file" (cdr v))))) ; (setf (aref vec i) (cdr v))) ; vec ; ) (defun wt-data-file ( &aux (x (data-vector)) (*package* (find-package "LISP")) fd tem ) (declare (type (array (t)) x)) ; (verify-data-vector x) (setq fd (si::open-fasd *data-output* :output nil nil)) (si::find-sharing-top x (fasd-table fd)) (put-op d_enter_vector *data-output*) (sloop for i below (length x) do (setq tem (aref x i)) (cond ((consp tem) (cond ((eq (car tem) 'd_eval_skip) (put-op d_eval_skip *data-output*)) ((eq (car tem) 'd_eval) (put-op d_eval *data-output*))))) (si::write-fasd-top (cdr tem) fd)) (put-op d_delimiter *data-output*) (si::close-fasd fd)) (defun display-data-file(file &aux fd (eof '(nil)) tem ) (with-open-file (st file) ; (setq fd (si::open-fasd st :input eof nil)) (setq fd (si::open-fasd st :input eof (make-array 100 :adjustable t))) (sloop::sloop for i from 0 while (not (eq eof (setq tem (si::read-fasd-top fd)))) do (format t "~%item ~a:~%~s" i tem )) )) (defun display-data-file1(file &aux fd (eof '(nil)) ) (with-open-file (st file) ; (setq fd (si::open-fasd st :input eof nil)) (setq fd (si::open-fasd st :input eof (make-array 100 :adjustable t))) (let ((si::%memory nil)) (declare (special si::%memory)) (si::read-fasd-top fd)))) (defun push-data (flag val) (vector-push-extend (cons flag val) (data-vector)) (prog1 *next-data* (if (or (eq flag 'dv) (eq flag 'd_eval)) (incf *next-data*)))) (defun get-load-time-form (x) (let ((tem (cdr (assoc x *load-time-forms*)))) (cond (tem) (t (setq tem (list 'dv nil x)) (setf (second tem) (push-data 'd_eval x)) (push (cons x tem) *load-time-forms*) tem)))) (defun get-object (x &aux tem) (cond ((setq tem (gethash x *data-table*))) ((typep x 'compiled-function) (setq tem (list 'd_eval nil `(function ,(or (si::compiled-function-name x) (comp-error "Can't dump un named compiled funs"))) )) (setf (gethash x *data-table*) tem) tem) (t (setq tem (list 'dv nil x)) (setf (gethash x *data-table*) tem) tem))) #| steps in loading 0) (let (*cfun-addresses* *data-object*) 1) copy address in VV vector into *vv-addresses* vector. 2) make a *data-object* whose body is the VV. 3) readin the items into the vector. using read-fasd-top |# gcl/comp/defmacro.lsp000077500000000000000000000174771242227143400151050ustar00rootroot00000000000000(in-package "BCOMP") (eval-when (load eval compile) (defvar *let-bindings* nil) (defvar *pending-action* nil) (defun find-declarations (body &aux decls doc bod) (do ((v body (cdr v))) (()) (or (consp v) (return nil)) (cond ((and (consp (car v)) (eq (caar v) 'declare)) (push (car v) decls)) ((stringp (car v))(if doc (return (setq bod v)) (setq doc (car v)))) (t (setq bod v)(return nil)))) (values (if doc (cons doc decls) decls) bod)) (defun parse-mll (argl whole top &aux u (pos 0) key-list key-test) ;; parse a macro lambda list ARGL, where WHOLE is a variable bound ;; to the whole list we gradually cdr down WHOLE ;; This is called recursively by add-binding, whenever the item to be ;; bound is not a symbol. (declare (fixnum pos)) (when (eq (car argl) '&whole) (or (consp (cdr argl)) (macro-arg-error '&whole)) (setq u (cadr argl)) (add-binding u whole) (setq argl (cddr argl))) (if top (push `(setq ,whole (cdr ,whole)) *pending-action*)) (do () ((atom argl) (cond (key-test (setf (third key-test) `(quote , key-list)))) (when argl (if (>= pos 2) (macro-arg-error '&rest)) ;; ` . body' at the end is the same as `&rest body' (add-binding argl whole))) (let ((x (car argl))) (case x ;; The lambda list keywords must appear in the following order (with ommissions). ;; We have deleted the &environment and &whole at this point. ;; pos 1 &optional, 2 &rest &body, 3 &key, 4 &allow-other-keys, 5 &aux (&optional (when (>= pos 1) (macro-arg-error x)) (setq pos 1)) ((&rest &body) (if (>= pos 2) (macro-arg-error x)) (setq argl (cdr argl)) (if (consp argl) nil (macro-arg-error x)) (add-binding (car argl) whole) (setq pos 2) ) (&key (if (>= pos 3) (macro-arg-error x)) (setq key-test `(dont-allow-other-keys ,whole nil)) (push key-test *pending-action*) (setq pos 3)) (&allow-other-keys (if (or (< pos 3) (>= pos 4)) (macro-arg-error x)) (setf (car key-test) 'progn key-test nil) (setq pos 4)) (&aux (if (>= pos 5) (macro-arg-error x)) (setq pos 5)) (t (cond ((= pos 5) ;&aux (let ((var x) (val nil)) (cond ((atom x)) (t (or (consp (cdr x)) (macro-arg-error '&aux)) ;(or (cddr x) (macro-arg-error '&aux)) (setq var (car x) val (cadr x)))) (or (symbolp var) (macro-arg-error '&aux)) (add-binding var val))) ((= pos 4) (macro-arg-error '&allow-other-keys)) ((= pos 3) ; &key (let (var val supplied-p keyword dont-intern) (cond ((atom x) (setq var x keyword x)) (t (setq var (car x)) (cond ((symbolp var) (setq keyword var)) ((consp var) (setq dont-intern t) (if (consp (cdr var)) nil (macro-arg-error '&key)) (setq keyword (car var) var (cadr var)) (if (symbolp keyword) nil (macro-arg-error '&key))) (t (macro-arg-error '&key))) (cond ((consp (cdr x)) (setq val (cadr x)) (cond ((consp (cddr x)) (setq supplied-p (caddr x)))))))) (or dont-intern (setq keyword (intern (symbol-name keyword) 'keyword))) (push keyword key-list) (let ((key-val (gensym))) (add-binding key-val `(getf ,whole ',keyword 'not-found)) (add-binding var `(if (eq ,key-val 'not-found) ,val ,key-val)) (if supplied-p (add-binding supplied-p `(not (eq ,key-val 'not-found))))))) ((= pos 2) ;; they duplicated an &rest arg eg `&rest a b' (macro-arg-error '&rest)) ((= pos 1) ; &optional (let (var val supplied-p) (cond ((atom x) (setq var x)) ((consp (cdr x)) (setq var (car x) val (cadr x)) (if (consp (cddr x)) (setq supplied-p (caddr x)))) (t (macro-arg-error x))) (add-binding var `(cond ((consp ,whole) ,@(if supplied-p `((setq ,supplied-p t))) (prog1 (car ,whole) (setq ,whole (cdr ,whole)))) (t ,val))))) ((= pos 0) ;&required arg (let ((last-arg (or (null (cdr argl)) (and (consp (cdr argl)) (eq (car argl) '&aux))))) (add-binding x `(cond ((consp ,whole) ,(if last-arg `(if (cdr ,whole) (too-many-arguments-to-macro) (car , whole)) `(car ,whole))) (t (too-few-arguments-to-macro)))) (or last-arg (push `(setq ,whole (cdr ,whole)) *pending-action*)) )))))) (pop argl))) (defun too-many-arguments-to-macro() (error "Too many arguments to a macro or destructuring bind")) (defun too-few-arguments-to-macro() (error "Too few arguments to a macro or destructuring bind")) (defun add-binding (v val) (when *pending-action* (setq val `(progn ,@ (reverse *pending-action*) ,val)) (setq *pending-action* nil)) (cond ((symbolp v) (push (list v val) *let-bindings*)) ((consp v) (let ((sub-whole (gensym))) (push `(,sub-whole ,val) *let-bindings*) (parse-mll v sub-whole nil))) (t (error "Bad lambda list entry ~a" v)))) (defun parse-macro (name lambda-list body &optional env &aux envir whole) ;; process a macro function body, laying out code for destructuring the ;; lambda-list. An implicit block with NAME is placed around the body. ;; The resulting lambda expression is a function of two arguments, suitable ;; for calling as a macroexpander. env (let (*let-bindings* *pending-action*) (do ((v lambda-list (cdr v)) (res nil)) (()) (if (atom v) (return nil)) (cond ((eq (car v) '&environment) (if (consp (cdr v)) nil (macro-arg-error '&environment)) (setq envir (cadr v)) (setf lambda-list (nconc (nreverse res) (cddr v))) (return nil)) (t (push (car v) res)))) (if envir nil (setq envir (gensym))) (setq whole (gensym)) (parse-mll lambda-list whole t) `(function (lambda (,whole ,envir) ,envir (block ,name (let* ,(nreverse *let-bindings*) ,@ body)))) )) (defun macro-arg-error (x) (error "Incorrect position or duplication of ~a arg in macro lambda list" x)) (defun dont-allow-other-keys(arglist allowed-keys) ;; Make sure arglist doesn't contain other keys. (do ((v arglist)) ((null v)) (cond ((consp v) (if (consp (cdr v)) nil (error "Odd number of keyword args")) (if (and (eq (car v) :allow-other-keys) (cadr v)) (return nil)) (if (member (car v) allowed-keys :test 'eq) nil (error "~s is not among the permitted keys ~s" (car v) allowed-keys)) (setq v (cddr v))) (t (error "The keyword args end in an atom ~a instead of NIL" v))))) (defun mset (sym fun) (setf (symbol-function sym) (cons 'macro fun))) ;(defmacro defmacro (name ll &body body)) (setf (macro-function 'defmacro) #'(lambda (bod env &aux ll body name) (setf bod (cdr bod)) (or (consp bod) (too-few-arguments-to-macro)) (setq name (car bod) bod (cdr bod)) (or (consp bod) (too-few-arguments-to-macro)) (setq ll (car bod) body (cdr bod)) (let ((doc (car (find-declarations body))) (def `(eval-when (compile eval load) (mset ',name ,(parse-macro name ll body t))))) (when (stringp doc) (setq def `(progn ,def (setf (get ',name 'si::function-documentation) ,doc)))) def))) (defmacro destructuring-bind (lambda-list expr &body body) (let ((whole (gensym)) *let-bindings* *pending-action*) (parse-mll lambda-list whole nil) `(let* ((,whole ,expr) ,@ (nreverse *let-bindings*)) ,@ body))) ) #+test (progn (defmacro1 billy (a b &key ((:u bil) 0 sup) sil &allow-other-keys) `(billy-list ,a ,b ,sil ,bil,sup ,a)) (defmacro1 mwith ((st . open-args) &body body) `(let (,st (open ,@ open-args)) (unwind-protect (progn ,@ body) (close ,st)))) (defmacro1 joe ((st a) y) `(joe-flat ,st,a,y)) (defmacro jo2 ((a b &key c d) &body body) (list 'hi a b c d body)) (jo2 (1 2 :c 3 ) 4 6) (mwith (st "foo" :direction :input) (read-char st)) (billy 1 2 :sil 1 :u 4 :james 1) (joe (1 2) 3) ) gcl/comp/defs.lsp000077500000000000000000000064201242227143400142300ustar00rootroot00000000000000 (in-package "BCOMP") #| after pass 1 only the following forms are allowed forms1 == (form1 form1 ... form1) form1 == output of (w1-walk form) N == 0,1,2,3.. desk == desk structure var1 == var structure | (var N) binds == ((var1 form1) (var1 form1) ..) arglist == (form1 form1 ... form1) (LET desk binds forms1) ;(LET* desk binds forms1) ; not needed since the variable assign done. (CALL desk call-data ) (FUNCTION desk function-data) ---------------------- |# ;;Globals for Second pass ;; push on to this when special is bound, so that it can be unbound. (defvar *sp-bind* nil) ;; set when a setjmp is laid down, so variables can be declared volatile (defvar *volatile* nil) ;; tells unwind-set that number of values already set. (defvar *MV-N-VALUES-SET* nil) (defvar *top-form* ;; Passes of the compiler may bind this to a form name which they are compiling ;; to make the errors more meaninful. nil) (defstruct var name ;; count of cross lambda block closure references clb type ;; rep type changed ;; var was altered ref ;; var referred to special-p ;; var declared special ;;for special var, something to which wr applies to write it ;;for a closure var, if the the var is NOT in the *closure-vars* ;; (ie those passed in to this function), then it is an (next-cvars) index ;; if the var was passed in then this field is ignored, and the index is ;; the position in the *closure-vars* list. ;;for a normal variable the (next-cvar), eg ind = 3 , var written V3 ind ;; vars which are maybe referred to after return from a setjmp volatile ) (defstruct (desk (:constructor make-desk1 (result-type ))) result-type ;result of first value ;CHANGED-VARS are the plain-var-p vars which are altered in the ;scope of the form of which this desk appears as the second member. ;used when setting up args for a c call, to know if we need to save a var changed-vars single-value ) (defun make-desk (x) (or x (setq x t)) (make-desk1 x)) (defstruct fdata name ll ; list : (ll &required (fdata-ll fd)) == the list of required args. closure-vars ind address-index doc form function-declaration ;; at the time of definition argd local-template ;; local function call template. closure-self ;; if this is a closure and non nil then it points to a funobj = self tail-label ) (defstruct (call-data (:constructor make-call-data (fname arglist local-fun function-declaration))) fname ; may be a name or else fdata for a local function. arglist local-fun ;;declaration at the point of call. ;;If nil, and if not local then ;; it may be retrieved later. function-declaration ) (defstruct label identifier ;; If this label is referred to across functions, a unique-id ;; is assigned and put in the clb-reference field. Otherwise this is nil clb-reference ;; On pass1 this is set to 'clb by clb references. If it is null it is ;; set to t by ordinary references. referred ind ) (defstruct (block (:constructor make-block (label))) label value exit) (defstruct top-form lisp walked funp ;T if contains a function ) (defstruct (link (:constructor make-link (fname proclaimed))) (argd 0 :type fixnum) ind proclaimed fname ) gcl/comp/exit.lsp000077500000000000000000000021251242227143400142560ustar00rootroot00000000000000(in-package "BCOMP") (setf (get 'let-control-stack 'b2) 'b2-let-control-stack) (defun b2-let-control-stack (x) (let ((*control-stack* *control-stack*)(*blocks* 0)) (open-block) (wr "object *VOL SaveVs = VsTop;") (expr-b2 (cadr x)) (close-blocks) )) (defopt control-jumped-back ((t) boolean #.(flags set safe) control-jumped-back-aux)) (defun control-jumped-back-aux(x) (push 'ctl-push *control-stack*) (wr-inline-call1 x "@0;CtlJumpedBack(ctl_TAGGED_CATCH,$0)")) (defopt push-unwind-protect ;; The second argument is a function to call to do unwinding ((t) t #.(flags safe set) push-unwind-protect-aux)) (defun push-unwind-protect-aux (x) ;; we use this function call to push something on control stack (push (list 'unwind-protect (car x)) *control-stack*) (or (and (eq (car *exit*) 'next) (or (and (eq (cadr *control-stack*) 'avma-bind) (eq (cdr *exit*) (cddr *control-stack*))) (eq (cdr *exit*) (cdr *control-stack*)))) (wfs-error)) (setq *exit* (cons 'next *control-stack*)) (wr-inline-call1 x "CtlUnwindPush($0)")) gcl/comp/fasdmacros.lsp000077500000000000000000000041351242227143400154320ustar00rootroot00000000000000(in-package "BCOMP") (provide 'FASDMACROS) (defstruct (fasd (:type vector)) stream table eof direction package index filepos table_length macro ) (defvar *fasd-ops* '( d_nil ;/* dnil: nil */ d_eval_skip ; /* deval o1: evaluate o1 after reading it */ d_delimiter ;/* occurs after d_listd_general and d_new_indexed_items */ d_enter_vector ; /* d_enter_vector o1 o2 .. on d_delimiter make a cf_data with ; this length. Used internally by akcl. Just make ; an array in other lisps */ d_cons ; /* d_cons o1 o2: (o1 . o2) */ d_dot ; d_list ;/* list* delimited by d_delimiter d_list,o1,o2, ... ,d_dot,on ;for (o1 o2 . on) ;or d_list,o1,o2, ... ,on,d_delimiter for (o1 o2 ... on) ;*/ d_list1 ;/* nil terminated length 1 d_list1o1 */ d_list2 ; /* nil terminated length 2 */ d_list3 d_list4 d_eval d_short_symbol d_short_string d_short_fixnum d_short_symbol_and_package d_bignum d_fixnum d_string d_objnull d_structure d_package d_symbol d_symbol_and_package d_end_of_file d_standard_character d_vector d_array d_begin_dump d_general_type d_sharp_equals ; /* define a sharp */ d_sharp_value d_sharp_value2 d_new_indexed_item d_new_indexed_items d_reset_index d_macro d_reserve1 d_reserve2 d_reserve3 d_reserve4 d_indexed_item3 ; /* d_indexed_item3 followed by 3bytes to give index */ d_indexed_item2 ; /* d_indexed_item2 followed by 2bytes to give index */ d_indexed_item1 d_indexed_item0 ; /* This must occur last ! */ )) (defmacro put-op (op str) `(write-byte ,(or (position op *fasd-ops*) (error "illegal op")) ,str)) (defmacro putd (n str) `(write-byte ,n ,str)) (defmacro put2 (n str) `(progn (write-bytei ,n 0 ,str) (write-bytei ,n 1 ,str))) (defmacro put4 (n str) `(progn (write-bytei ,n 0 ,str) (write-bytei ,n 1 ,str) (write-bytei ,n 2 ,str) (write-bytei ,n 3 ,str) )) (defmacro write-bytei (n i str) `(write-byte (the fixnum (ash (the fixnum ,n) >> ,(* i 8))) ,str)) gcl/comp/inline.lsp000077500000000000000000000472241242227143400145740ustar00rootroot00000000000000(in-package "BCOMP") (eval-when (compile load eval) (defmacro opt (key opt) `(nth ,(position key '(args return flag template )) ,opt)) ) (eval-when (eval compile load) (defun flags-pos (flag &aux (i 0)) (declare (fixnum i)) (dolist (v *flags*) (cond ((member flag v :test 'eq) (return-from flags-pos i))) (setq i (+ i 1))) (error "unknown opt flag")) (defvar *flags* '((allocates-new-storage ans) ; might invoke gbc (side-effect-p set) ; no effect on arguments (constantp) ; always returns same result, ;double eval ok. (result-type-from-args rfa) ; if passed args of matching ;type result is of result type (is);; extends the `integer stack'. (mv);; in a declaration, function may return MV. (safe);; can be used at safety 3 (notinline) (touch-mv);;Invoking this may alter the MV locations. (not-1-val) ;; obsoluete (proclaim) ; do a proclaim. )) ) (defmacro flags (&rest lis &aux (i 0)) (dolist (v lis) (setq i (logior i (ash 1 (flags-pos v))))) i) (defun print-flag (n &optional safe) (princ "#.(flags") (dotimes (i (length *flags*)) (if (logbitp i n) (format t " ~(~s~)"(car (last (nth i *flags*))) ))) (if safe (princ " safe")) (princ ")") n) ;#+assist (progn ;; Convert old AKCL opts. (defun print-opt (sym prop &aux tem ) (unless (get 'compiler::boolean 'comp-type) (setf (get 'compiler::boolean 'comp-type) 'boolean) (setf (get :dynamic-extent 'comp-type) 'dynamic-extent) (setf (get 'compiler::fixnum-float 'comp-type) 'fix-or-sf-or-df)) (cond ((setq tem (get sym prop)) (format t "~%(defopt ~s" sym) (let ((*print-case* :downcase)) (dolist (v (reverse tem)) (format t "~% (~s ~s " (mapcar 'comp-type (car v)) (comp-type (second v))) (print-flag (third v) (eq prop 'compiler::inline-always)) (format t " ~s)" (if (stringp (fourth v)) (substitute #\$ #\# (fourth v)) (fourth v))))) (princ ")")))) (defun convert-old (&rest props &aux syms) (sloop for pack in '(lisp si compiler) do (sloop for v in-package pack when (sloop for w in props when (get v w) return t) do (push v syms))) (setq syms (sort syms #'(lambda (x y) (string-lessp (symbol-name x) (symbol-name y))))) (sloop for v in syms do (sloop for w in props do (print-opt v w)))) ;(with-open-file (*standard-output* "/tmp/opts1.lsp" :direction :output) (convert-old 'compiler::inline-always 'compiler::inline-unsafe)) ;(load "/tmp/opts.lsp") ;(with-open-file (*standard-output* "/tmp/opts.lsp" :direction :output) (convert-old 'bcomp-opt)) ) (defmacro defopt (fname &rest l) ;; adds additional opts to the front. ;; last added is most significant. `(defopt1 ',fname ',l)) (defun defopt1 (fname l) (dolist (v l) (let ((fl (opt flag v))) (cond ((flag-p fl proclaim) (proclaim1 `(ftype (function ,(opt args v) ,(opt return v)) ,fname))))) (push v (get fname 'bcomp-opt)))) (defmacro flag-p (n flag) `(logbitp ,(flags-pos flag) ,n)) (setf (get 'aref 'coerce-arg-types) '(t fixnum fixnum fixnum fixnum)) (setf (get 'si::aset1 'coerce-arg-types) '(t fixnum )) (defun get-inline-template (fname fdecl arg-types ret-type type-wanted &aux lis opt-ret tem (opt-flag 0) (mask (if (> *safety* 0) ;*unsafe* #.(flags safe) #.(flags)))) (declare (fixnum mask opt-flag)) (or (symbolp fname) (wfs-error)) (setq lis (get fname 'bcomp-opt)) (or lis (return-from get-inline-template nil)) (cond ((eq type-wanted 'mv) (setq type-wanted t) (unless (and fdecl (not (flag-p (second fdecl) mv))) ;function proclaimed to return 1 arg (setq mask (logior mask #. (flags mv) ))))) (when (setq tem (get fname 'coerce-arg-types)) (sloop for v on arg-types for w in tem unless (eq w t) do (setf (car v) (type-and (car v) w)))) (if (member type-wanted *immediate-types*) (setq ret-type type-wanted)) (sloop for opt in lis do (setq opt-ret (opt return opt)) (setq opt-flag (opt flag opt)) ;; check return return matches do (when (and (eql mask (logand opt-flag mask)) (or (eql opt-ret t) (eql opt-ret '*) (comp-subtypep ret-type opt-ret))) (sloop for v on arg-types for w on (opt args opt) do (cond ((eq (car w) '*) (return-from get-inline-template opt)) ((or (comp-subtypep (car v) (car w)) (return nil)))) finally (cond ((eq (car w) '*) (return-from get-inline-template opt)) ((and (null v) (null w)) (return-from get-inline-template opt)))))) ) (defun result-from-args (sym argl &aux arg-types) (let ((tem (get sym 'bcomp-opt))) (when tem (sloop for opt in tem when (flag-p (opt flag opt) rfa) do (or arg-types (setq arg-types (mapcar 'result-type argl))) (sloop for v on arg-types for w on (opt args opt) do (cond ((eq (car w) '*) (return-from result-from-args (opt return opt))) ((or (subtypep (car v) (car w)) (return nil)))) finally (cond ((eq (car w) '*) (return-from result-from-args (opt return opt)) ) ((and (null v) (null w)) (return-from result-from-args (opt return opt)) )))) (cond ((get sym 'arithmetic-contagion) (or arg-types (setq arg-types (mapcar 'result-type argl))) (setq tem (or (member 'double-float arg-types ) (member 'short-float arg-types))) (if (and tem (sloop for v in arg-types always (or (subtypep v 'fixnum) (subtypep v 'double-float) (subtypep v 'short-float)))) (return-from result-from-args (car tem))) ))))) (dolist (v '(* + - 1- 1+ /)) (setf (get v 'arithmetic-contagion) t)) ;; symbol_value ;; the result depends on WHEN the form is evaluated. ;; list ;; Different invocations give different results with same ;; args, but order of eval is not important. Double EVAL is. ;; (add x y) ;; May be multiple eval'd. WHEN is not important. ;; (aref x i) ;; May be multiple eval'd. WHEN is important. ;; (set x 3) ;; May be multiple eval'd. Changes something in x. WHEN important. ;; by 'not side-effect' in the property of an inline, means that it may be ;; multiple eval'd as long as there were no intervening operation which does ;; not have the no-side-effect property, and the results would be same EXCEPT, ;; that we might get a different storage location. ;; by allocates-new-storage we mean that storage is allocated. ;; A function which has no-side-effect and 'not allocates-new-storage' ;; must return eq results if multiple-eval'd with no intervening ;; no-side-effect function. ;; Call a function foo and goo `unordered' if ;; (setq a (goo x y)) ;; (setq b (foo x y)) ;; Then no common lisp function could tell whether a or b was computed first. ;; The set of 'not side-effect' functions are unordered. ;; This is the case for LIST, CONS, MAKE-ARRAY, APPEND, AREF, .. (defun inline-args (args arg-types &aux type-wanted) ;; returns (cons arglist referred-vars) ;; where REFERRED-VARS is a list of vars which will be eval'd ;; during the inline writeout of the forms in ARGLIST. The ;; list of these variables is necessary so that INLINE-CALL ;; may produce this list. ;; we check thru each ARG, and any one which we find which does not ;; meet the following criteria, is pre eval'd as a temp. ;; 1: Are them selves inline calls to functions with 'not side-effect-p' flag ;; 2: Refer to vars which are setq'd by subsequent inline-calls (since ;; it will be to late to eliminate them then. Those setq's will actually ;; be written out in the preevalling. ) ;; 3: lexical or special vars unless the last arg. ;; eg (foo x (progn (setq x 3) 7)) would require saving initial value of x in a ;; temp, because it is changed by a subsequent arg. ;; In (foo (progn (setq x 3) 7) x (+ x y)) the second x and the (+ x y) ;; could stay and be inlined. ;; All user functions are presumed to have 'side-effect-p' (sloop for v on args with referred = (cons nil nil) do (setf type-wanted (or (equal arg-types '(*)) (pop arg-types))) collect (inline-arg (car v) type-wanted (cdr v) referred) into all finally (setf (car referred) all) (return referred))) (defun function-constant-p (x) ;; a function which returns something which will be the SAME for a given ;; set of arguments, where SAME means that there would not be a way in common lisp ;; of distinguishing between two results of an invocation OTHER than using eq. (member x '(+ * list cons))) (defun remaining-args-constant (rest &aux cd) (sloop for v in rest do (cond ((atom v)) ((eq (car v) 'var)) ((eq (car v) 'call) (setq cd (third v)) (unless (and (function-constant-p (call-data-fname cd)) (remaining-args-constant (call-data-arglist cd))) (return nil))) (t (return nil))) finally (return t))) (defun is-var-changed (var subsequent-args &aux cd) (sloop for v in subsequent-args do (cond ((or (atom v) (eq (car v) 'var) (eq (car v) 'dv)) nil) ((not (plain-var-p var)) (setq cd (third v)) (unless (and (eq (car v) 'call) (function-constant-p (call-data-fname cd)) (not (is-var-changed var (call-data-arglist cd)))) (return t))) ((typep (second v) 'desk) (return (memq var (desk-changed-vars (second v))))) (t (return t))))) (defun inline-arg(a type-wanted rest referred &aux referred-vars result n tem) ;; a value which can be written inline as an arg, and ;; sets referred-vars ;; (when (eq type-wanted 'fix-or-sf-or-df) (let ((x (car (member (result-type a) '(fixnum short-float double-float))))) (and x (setq type-wanted x)))) (when (eq type-wanted 'double_ptr) (let ((v (get-temp 'double-float)) (tem (inline-arg a 'double-float rest referred))) (wr-set-inline-loc v tem) (return-from inline-arg (list 'address v)))) (cond ((atom a) (or (typep a 'var) (wfs-error)) (setq result a) (cond ((or (null rest) (remaining-args-constant rest) (and (plain-var-p a) (not (is-var-changed a rest)))) (push a (cdr referred))) (t (setq result (get-temp (var-implementation-type a))) (wr-nl result "=" a ";"))) (or (eq (var-implementation-type a) type-wanted) (setq result (list 'inline-loc type-wanted result)))) ((eq (car a) 'var) ;a temp var (setq result a) (or (eq (third a) type-wanted) (setq result (list 'inline-loc type-wanted result)))) ((eq (car a) 'dv) (setq result (add-data a)) (or (eq t type-wanted) (setq result (list 'inline-loc type-wanted result)))) ((eq (car a) 'the) (setq result (inline-arg (third a) type-wanted rest referred))) ((eq (car a) 'call) (setq result (inline-call a type-wanted )) (setq tem nil) (setf referred-vars (car result) (car result) 'inline-call) (let ((templ (cddr result)) tem1) (setq n (opt flag templ)) (cond ( ;; need a temp: (or (not (or (flag-p n constantp) (and (not (flag-p n set)) (not (flag-p n ans))))) (and (typep (setq tem1 (fourth templ)) 'link) (or (argd-flag-p (link-argd tem1) requires-nargs) (argd-flag-p (link-argd tem1) requires-fun-passed)))) (setq tem (get-temp type-wanted))) (rest (sloop for referred-var in referred-vars when (is-var-changed referred-var rest) do (setq tem (get-temp (opt return templ))) (loop-finish)))) (unless (null tem) (setq referred-vars nil) (wr-set-inline-loc tem result) (setf result tem)) (unless (eq (opt return templ) type-wanted) (setq result (list 'inline-loc type-wanted result))) (if referred-vars (setf (cdr referred) (nconc referred-vars (cdr referred)))) )) (t (setq result (get-temp type-wanted)) (when *do-pending-open* (setq *do-pending-open* nil)(open-block)) (valex (list 'var result) (next-exit) (expr-b2 a)) result)) result ) (defun constant-inline-fixnum(x &aux y) (or (and (consp x) (eq (car x) 'inline-loc) (eq (second x) 'fixnum) (and (consp (setq y (third x))) (eq (car y) 'dv) (typep (third y) 'fixnum))) (wfs-error)) (third y)) (setf (get 'boole 'bo2) 'bo2-boole) (defun bo2-boole(a type-wanted arg-types) (when (and (equal arg-types '(fixnum fixnum fixnum)) (dv-p (car (call-data-arglist (third a))))) (do-inline-call 'boole3 a 'fixnum))) (defun wr-inline-boole3 (iargs) (wr-inline-call1 (cdr iargs) (ecase (constant-inline-fixnum (car iargs)) (#.boole-ior "(($0) | ($1))" ) (#.boole-xor "(($0) ^ ($1))" ) (#.boole-and "(($0) & ($1))" ) (#.boole-eqv "(~(($0) ^ ($1)))" ) (#.boole-nand "(~(($0) & ($1)))" ) (#.boole-nor "(~(($0) | ($1)))" ) (#.boole-andc1 "((~($0)) & ($1))" ) (#.boole-andc2 "(($0) & (~($1)))" ) (#.boole-orc1 "((~($0)) | ($1))" ) (#.boole-orc2 "(($0) | (~($1)))" ) (#.boole-clr "(0)" ) (#.boole-set "(-1)" ) (#.boole-1 "(($0))" ) (#.boole-2 "(($1))" ) (#.boole-c1 "(~($0))" ) (#.boole-c2 "(~($1))" )))) (defun do-inline-call (fname a type-wanted) (inline-call (list 'call (second a) (make-call-data fname (call-data-arglist (third a)) nil nil)) type-wanted)) (defun coerce-to-binary (sym dsk argl &aux first) (setq first `(call ,dsk ,(make-call-data sym (list (car argl)(second argl)) nil nil))) (cond ((cddr argl) (coerce-to-binary sym dsk (cons first (cddr argl)))) (t first))) (defun bo2-coerce-to-binary (a type-wanted arg-types) arg-types (let* ((form-type (desk-result-type (second a))) (call-dat (third a)) (arglist (call-data-arglist (third a)))) (cond ((and (cddr arglist) (or (not (eq type-wanted t)) (not (eq form-type t)))) (if (eq type-wanted 'mv) (setq type-wanted t)) (inline-call (coerce-to-binary (call-data-fname call-dat) (make-desk (type-and type-wanted form-type)) arglist) type-wanted))))) (dolist (v '(+ * - /)) (setf (get v 'bo2) 'bo2-coerce-to-binary)) (setf (get 'aref 'bo2) 'bo2-aref) (defun bo2-aref (a type-wanted arg-types &aux (cd (third a)) argl type size) arg-types (setq argl (call-data-arglist cd)) (setq type (result-type (car argl))) (cond ((and (= *safety* 0) (eql 3 (length argl)) (consp type) (eq (car type) 'array) (eq (second type) t) (consp (setq size (third type))) (typep (second size) 'fixnum)) (if (eq type-wanted 'mv) (setq type-wanted t)) (inline-call (list 'call (second a) (make-call-data 'aref-2d (append argl (list (get-object (second size)))) nil nil)) type-wanted)))) (defun inline-call (a type-wanted &aux call-dat in-args template tem (*exit* (next-exit))) ;; The arg A is a (call ..) as returned from b1-walk. ;; If TYPE-WANTED is NIL then we may need Mult Values. ;; This function returns a list: ;; (referred-vars inlined-args result-type flags fname-or-string) ;; The REFERRED-VARS and RESULT-TYPE and FLAGS are necessary for ;; recursive calls, while the FNAME-OR-STRING and INLINED-ARGS ;; are used to actually write out the result. (setq call-dat (third a)) (let* ((fname (call-data-fname call-dat)) fdecl check (arglist (call-data-arglist call-dat)) (arg-types (mapcar 'result-type arglist)) (form-type (desk-result-type (second a)))) (cond ((and (setq tem (get fname 'bo2)) (setq tem (funcall tem a type-wanted arg-types))) (return-from inline-call tem))) (cond ((call-data-local-fun call-dat) (setq check t) (setq template (get-template-fdata (second (second (call-data-local-fun call-dat)))))) ((setq template (progn (setq fdecl (function-declaration fname)) (let ((ret (if fdecl (ret-from-argd (fdecl argd fdecl))))) (cond (ret (cond ((eq ret 'double_ptr) (setq form-type (type-and 'double-float form-type))) ((or (eq ret t)(eq ret '*))) (t (setq form-type (type-and ret form-type))))))) (get-inline-template fname fdecl arg-types form-type type-wanted)))) ((setq template (add-link-template fname fdecl arg-types type-wanted)))) ;; now we have template. (when check (sloop for v in (car template) with al = arglist do (cond ((eq v '*) (return t)) ((null al) (comp-error "Too few args passed to ~a " fname)) (t (pop al))))) (cond ((flag-p (opt flag template)is ) (sloop for v on *control-stack* when (or (eq (car v) 'avma-bind) (eq (car v) 'avma-bind-needed)) do (setf (car v) 'avma-bind-needed) (return nil) finally (wfs-error)))) (setq in-args (inline-args arglist (opt args template))) (list* (cdr in-args) ; the referred-vars (car in-args) ; the arglist template))) (defun add-link-template (fname fdecl arg-types type-wanted &aux tem link ans (leng (length arg-types))) (declare (fixnum leng)) (setq tem (assoc fname *file-inline-templates*)) (when tem (setq link (fourth tem)) (cond ((typep link 'link) (cond ((< leng (argd-minargs (link-argd link))) (setf (argd-minargs (link-argd link)) leng)) ((> leng (argd-maxargs (link-argd link))) (setf (argd-maxargs (link-argd link)) leng)) (t nil)) (if (eq type-wanted 'mv) (setf (argd-flag-p (link-argd link) sets-mv) t)))) (return-from add-link-template (cdr tem))) (let ((ret t) (argl '(*)) (flags #.(flags set ans mv)) (argd 0) link) (declare (fixnum argd)) (cond (fdecl (setq argd (car fdecl)) (setq argl (argl-from-argd argd)) (setq ret (ret-from-argd argd)) (setq flags (second fdecl))) (t (setf (argd-minargs argd) (length arg-types)) (setf (argd-maxargs argd) (length arg-types)) (setf (argd-flag-p argd requires-nargs) t) (setf (argd-flag-p argd sets-mv) t))) (setq link (make-link fname fdecl)) (setf (link-argd link) argd) ;; we need the data object now, so make sure it gets in the vector ;; in time (add-data (get-object fname)) (push (setq ans (list fname argl ret flags link)) *file-inline-templates*) (cdr ans))) (defun get-template-fdata (fd &aux fstring tem) ;; make a template for a local fdata (or (typep fd 'fdata) (wfs-error)) (cond ((setq tem (fdata-local-template fd)) (return-from get-template-fdata tem))) (let* ((vararg (vararg-p fd)) (fdecl (fdata-function-declaration fd)) (ll (fdata-ll fd))) (unless fdecl (setq fdecl (increment-function-decl `(function , (nconc (sloop for v in (ll &required ll) collect (value-type v)) (if (ll &optional ll) (cons '&optional (sloop for v in (ll &optional ll) collect (value-type (car v))))) (if (or (ll &rest ll) (ll &key ll)) '(*) nil)) ;; todo arrange that pickup ret type ;; from fdata some day10q *) nil))) (setq fstring (format nil "L~a($@0)" (fdata-ind fd))) (if vararg (setq fstring (format nil "(VFUN_NARGS = $#,~a)" fstring))) ; (wr-h (rep-type t) " L" (fdata-ind fd) "();") ;; it is only fitting that a closure's template `format string' should in ;; fact be a closure. Takes a closure to know a closure. (cond ((fdata-closure-vars fd) (let ((fdc fd) (string fstring)) (setf fstring #'(lambda (iargs) (wr "(fcall.fun=" (or (fdata-closure-self fdc) (fdata-to-obj fdc)) ",") (wr-inline-call1 iargs string) (wr ")")))))) (let ((ans (list (argl-from-argd (fdecl argd fdecl)) (ret-from-argd (fdecl argd fdecl)) (fdecl flag fdecl) fstring))) (setf (fdata-local-template fd) ans) ans))) (defun replace-inline-by-temp (x) (let* ((type (result-type x)) (tem (get-temp type))) (wr-set-inline-loc tem x) tem)) gcl/comp/integer.doc000077500000000000000000000022511242227143400147110ustar00rootroot00000000000000 1) b2-call (or anyone who calls inline-arg or inline-args) will push an 'avma-bind onto the *control-stack* if it is there is not one between where it is and the next tag. If it did the push, then it will pop it off an leaving. If the 'avma-bind has been changed to 'avma-bind-needed then a) it will also set the *used-function-saved-avma* to be t if at outer scope b) bind *do-restore-avma* to the point in the *control-stack* where we pushed to 'avma-bind, for the benefit of unwind-set. c)It is an error if the *value* var is of type GEN and the level is outer. 2) Any call to an 'is' fun will cause the most recent 'avma-bind or 'avma-bind-needed to 'avma-bind-needed 3) unwind-set if doing a go or return must do the restore to the level appropriate to the tag, if there is an intervening 'avma-bind-needed in the *control-stack* If not going to a tag then if *do-restore-avma* is set, then unwind to the current avma level. current level is global_saved_avma if there is not an intervening inner-avma on the stack. 4) entering tagbody, if there is an 'avma-bind on the stack, then push an 'inner-avma and write { GEN Inner_avma= avma; ..}. gcl/comp/lambda.lsp000077500000000000000000000020311242227143400145210ustar00rootroot00000000000000(in-package "BCOMP") #| (let ((a 3)) (defun f0 (x) (+ x 2)) (defun f1 (x) (setq a x) (+ x 2)) (defun f2 (x &aux u) #'(lambda (y) (+ x y a u))) (list #'f0 #'f1 #'f2 (f2 1) (f2 1))) f1 alters the a which the function f2 outputs. each call to f2 makes a different closure variable x however. There is only one closure variable a. (function (lambda ....)) is a closure if in (lambda ....) there are references to the cross boundary You get the list of such vars A compiled closure will be struct closure { object name; .. object *cldata; short cldata_dim; } MakeClosure(3,fn,argd,V1,V2,V3) would construct it, and the V1,V2,V4 would be the cons's whose cars represent the closure variables. inside the closure we will have this_cldata variable, and can reference the variables by position for this closure. Each time we enter a let or &aux or lambda variable which freshly binds a closure variable, a new cons must be created. This cons is immediately put in the accessor array for this closure. |# gcl/comp/lisp-decls.doc000077500000000000000000001120731242227143400153170ustar00rootroot00000000000000(in-package "BCOMP") ;first load the proclaims then get them: ;(setq lis (sort (sloop for v in-package 'lisp when (get v 'PROCLAIMED-FUNCTION-DECLARATION) collect v) #'(lambda (x y) (string-lessp (symbol-name x) (symbol-name y))))) ;(sloop for v in lis when (setq tem (get v 'proclaimed-function-declaration)) do (format t "(~a ~a ~a " v (car tem)(second tem)) (print-flag (third tem))(princ ")") (unless (eq (second tem) '*) (princ " ;Mv touched?")) (terpri)) (defmacro proclaim2 (name args res flag) (progn (proclaim1 `(ftype (function ,args ,res) ,name)) (setf (fdecl flag (get name 'proclaimed-function-declaration) ) flag))) (proclaim2 * (*) T #.(flags ans constantp)) ;Mv touched? (proclaim2 + (*) T #.(flags ans constantp)) ;Mv touched? (proclaim2 - (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 / (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 /= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 1+ (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 1- (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 < (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 <= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 = (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 > (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 >= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ABS (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ACONS (T T T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ACOS (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ACOSH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ADJOIN (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ADJUST-ARRAY (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ADJUSTABLE-ARRAY-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ALPHA-CHAR-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ALPHANUMERICP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 APPEND (*) T #.(flags ans set )) ;Mv touched? (proclaim2 APPLY (T T *) * #.(flags ans set mv touch-mv)) (proclaim2 APROPOS (T *) * #.(flags ans set mv touch-mv)) (proclaim2 APROPOS-LIST (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 AREF (T &optional fixnum fixnum fixnum fixnum *) T #.(flags ans constantp)) (proclaim2 si::aset1 (T fixnum t) T #.(flags ans set constantp)) (proclaim2 ARRAY-DIMENSION (T FIXNUM) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 ARRAY-DIMENSIONS (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ARRAY-ELEMENT-TYPE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ARRAY-HAS-FILL-POINTER-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ARRAY-IN-BOUNDS-P (T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ARRAY-RANK (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 ARRAY-ROW-MAJOR-INDEX (T *) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ARRAY-TOTAL-SIZE (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 ARRAYP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ASH (INTEGER FIXNUM) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 ASIN (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ASINH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ASSOC (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ASSOC-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ASSOC-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ATAN (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ATANH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ATOM (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 BIT (T *) BIT #.(flags ans constantp)) ;Mv touched? (proclaim2 BIT-AND (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-ANDC1 (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-ANDC2 (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-EQV (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-IOR (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-NAND (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-NOR (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-NOT (T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-ORC1 (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-ORC2 (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-VECTOR-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 BIT-XOR (T T *) (ARRAY BIT) #.(flags ans set )) ;Mv touched? (proclaim2 BOOLE (FIXNUM INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 BOTH-CASE-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 BOUNDP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 BREAK (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 BUTLAST (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 BYTE (FIXNUM FIXNUM) T #.(flags ans constantp)) ;Mv touched? (proclaim2 BYTE-POSITION (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 BYTE-SIZE (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 CAAAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAAADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAADAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAADDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADDAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADDDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDAAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDAADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDADAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDADDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDDAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDDDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CEILING (T *) * #.(flags ans set mv touch-mv)) (proclaim2 CERROR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 CHAR (T FIXNUM) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-CODE (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-DOWNCASE (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-EQUAL (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-GREATERP (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-INT (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-LESSP (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-NAME (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-NOT-EQUAL (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-NOT-GREATERP (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-NOT-LESSP (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-UPCASE (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR/= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR< (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR<= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR> (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR>= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHARACTER (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CHARACTERP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CIS (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CLEAR-INPUT (*) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CLEAR-OUTPUT (*) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CLOSE (T *) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 CLRHASH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 CODE-CHAR (FIXNUM) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COERCE (T T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COMPILE (T *) * #.(flags ans set mv touch-mv)) (proclaim2 COMPILE-FILE (T *) * #.(flags ans set mv touch-mv)) (proclaim2 COMPILED-FUNCTION-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 COMPLEX (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 COMPLEXP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CONCATENATE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 CONJUGATE (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CONS (T T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CONSP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CONSTANTP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 COPY-ALIST (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COPY-LIST (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COPY-READTABLE (*) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COPY-SEQ (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COPY-SYMBOL (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COPY-TREE (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COS (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COSH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COUNT (T T *) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 COUNT-IF (T T *) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 COUNT-IF-NOT (T T *) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DECODE-UNIVERSAL-TIME (T *) * #.(flags ans set mv touch-mv)) (proclaim2 DELETE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DELETE-DUPLICATES (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DELETE-FILE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DELETE-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DELETE-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DENOMINATOR (T) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 DEPOSIT-FIELD (INTEGER T INTEGER) INTEGER #.(flags ans set)) ;Mv touched? (proclaim2 DESCRIBE (T *) * #.(flags ans set mv touch-mv)) (proclaim2 DIGIT-CHAR (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 DIGIT-CHAR-P (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 DIRECTORY (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DIRECTORY-NAMESTRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DOCUMENTATION (T T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 DPB (INTEGER T INTEGER) INTEGER #.(flags ans set )) ;Mv touched? (proclaim2 DRIBBLE (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ED (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 EIGHTH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ELT (T FIXNUM) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ENCODE-UNIVERSAL-TIME (T T T T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ENDP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ENOUGH-NAMESTRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 EQ (T T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 EQL (T T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 EQUAL (T T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 EQUALP (T T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ERROR (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 EVAL (T) * #.(flags ans set mv touch-mv)) (proclaim2 EVENP (INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 EVERY (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 EXP (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 EXPORT (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 EXPT (T T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 FBOUNDP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 FCEILING (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FFLOOR (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FIFTH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 FILE-AUTHOR (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FILE-LENGTH (STREAM) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FILE-NAMESTRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FILE-POSITION (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FILE-WRITE-DATE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FILL (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FILL-POINTER (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 FIND (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FIND-ALL-SYMBOLS (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FIND-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FIND-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FIND-PACKAGE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FIND-SYMBOL (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FINISH-OUTPUT (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FIRST (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 FLOAT-DIGITS (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 FLOAT-PRECISION (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 FLOAT-RADIX (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 FLOAT-SIGN (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 FLOATP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 FLOOR (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FMAKUNBOUND (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FORCE-OUTPUT (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FORMAT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FOURTH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 FRESH-LINE (*) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FROUND (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FTRUNCATE (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FUNCALL (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FUNCTIONP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 GCD (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GENSYM (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GENTEMP (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GET (T T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 GET-DECODED-TIME NIL * #.(flags ans set mv touch-mv)) (proclaim2 GET-DISPATCH-MACRO-CHARACTER (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GET-INTERNAL-REAL-TIME NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GET-INTERNAL-RUN-TIME NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GET-MACRO-CHARACTER (T *) * #.(flags ans set mv touch-mv)) (proclaim2 GET-OUTPUT-STREAM-STRING (STREAM) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GET-PROPERTIES (T T) * #.(flags ans set mv touch-mv)) (proclaim2 GET-SETF-METHOD (T *) * #.(flags ans set mv touch-mv)) (proclaim2 GET-SETF-METHOD-MULTIPLE-VALUE (T *) * #.(flags ans set mv touch-mv)) (proclaim2 GET-UNIVERSAL-TIME NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GETF (T T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 GETHASH (T T *) * #.(flags ans set mv touch-mv)) (proclaim2 GRAPHIC-CHAR-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 HASH-TABLE-COUNT (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 HOST-NAMESTRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 IDENTITY (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 IMAGPART (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 IMPORT (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 IN-PACKAGE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 INPUT-STREAM-P (STREAM) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 INSPECT (T) * #.(flags ans set mv touch-mv)) (proclaim2 INTEGER-DECODE-FLOAT (T) * #.(flags ans set mv touch-mv)) (proclaim2 INTEGER-LENGTH (INTEGER) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 INTEGERP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 INTERN (T *) * #.(flags ans set mv touch-mv)) (proclaim2 INTERSECTION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ISQRT (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 KEYWORDP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 LCM (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LDB (T INTEGER) INTEGER #.(flags ans set )) ;Mv touched? (proclaim2 LDB-TEST (T INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 LDIFF (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LENGTH (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 LISP-IMPLEMENTATION-VERSION NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LIST (*) T #.(flags ans constantp)) ;Mv touched? (proclaim2 LIST* (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 LIST-ALL-PACKAGES NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LIST-LENGTH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LISTEN (*) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LISTP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 LOAD (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LOG (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LOGAND (*) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGANDC1 (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGANDC2 (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGBITP (FIXNUM INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGCOUNT (INTEGER) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGEQV (*) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGIOR (*) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGNAND (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGNOR (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGNOT (INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGORC1 (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGORC2 (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGTEST (INTEGER INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGXOR (*) INTEGER #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LONG-SITE-NAME NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LOWER-CASE-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 MACHINE-INSTANCE NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MACHINE-TYPE NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MACHINE-VERSION NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MACRO-FUNCTION (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 MACROEXPAND (T *) * #.(flags ans set mv touch-mv)) (proclaim2 MACROEXPAND-1 (T *) * #.(flags ans set mv touch-mv)) (proclaim2 MAKE-BROADCAST-STREAM (*) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-CONCATENATED-STREAM (*) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-DISPATCH-MACRO-CHARACTER (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-ECHO-STREAM (STREAM STREAM) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-HASH-TABLE (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-LIST (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-PACKAGE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-PATHNAME (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-RANDOM-STATE (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-SEQUENCE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-STRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-STRING-INPUT-STREAM (T *) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-STRING-OUTPUT-STREAM NIL STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-SYMBOL (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-SYNONYM-STREAM (T) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-TWO-WAY-STREAM (STREAM STREAM) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKUNBOUND (T) T #.(flags ans set )) ;Mv touched? (proclaim2 MAP (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPC (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPCAN (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPCAR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPCON (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPHASH (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPL (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPLIST (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MASK-FIELD (T INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 MAX (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 MEMBER (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MEMBER-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MEMBER-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MERGE (T T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MERGE-PATHNAMES (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MIN (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 MINUSP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 MISMATCH (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MOD (T T) T #.(flags ans touch-mv)) ;Mv touched? (proclaim2 NAME-CHAR (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NAMESTRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NBUTLAST (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NCONC (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NINTERSECTION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NINTH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 NOT (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 NOTANY (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NOTEVERY (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NRECONC (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NREVERSE (T) T #.(flags ans set )) ;Mv touched? (proclaim2 NSET-DIFFERENCE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSET-EXCLUSIVE-OR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSTRING-CAPITALIZE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSTRING-DOWNCASE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSTRING-UPCASE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBLIS (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBST (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBST-IF (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBST-IF-NOT (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBSTITUTE (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBSTITUTE-IF (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBSTITUTE-IF-NOT (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NTH (FIXNUM T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 NTHCDR (FIXNUM T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 NULL (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 NUMBERP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 NUMERATOR (T) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 NUNION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ODDP (INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 OPEN (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 OUTPUT-STREAM-P (STREAM) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 PACKAGE-NAME (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 PACKAGE-NICKNAMES (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 PACKAGE-SHADOWING-SYMBOLS (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 PACKAGE-USE-LIST (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 PACKAGE-USED-BY-LIST (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 PAIRLIS (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PARSE-INTEGER (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PARSE-NAMESTRING (T *) * #.(flags ans set mv touch-mv)) (proclaim2 PATHNAME (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PATHNAME-DEVICE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PATHNAME-DIRECTORY (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PATHNAME-HOST (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PATHNAME-NAME (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PATHNAME-TYPE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PATHNAME-VERSION (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PEEK-CHAR (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PHASE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PLUSP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 POSITION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 POSITION-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 POSITION-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PRIN1 (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PRIN1-TO-STRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PRINC (T *) T #.(flags ans set )) ;Mv touched? (proclaim2 PRINC-TO-STRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PRINT (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PROBE-FILE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RANDOM (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RASSOC (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RASSOC-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RASSOC-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RATIONAL (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RATIONALIZE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RATIONALP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ-BYTE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ-CHAR (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ-CHAR-NO-HANG (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ-DELIMITED-LIST (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ-FROM-STRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ-LINE (*) * #.(flags ans set mv touch-mv)) (proclaim2 READ-PRESERVING-WHITESPACE (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REALPART (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REDUCE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REM (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REMHASH (T T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REMOVE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REMOVE-DUPLICATES (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REMOVE-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REMOVE-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REMPROP (T T) T #.(flags ans set )) ;Mv touched? (proclaim2 RENAME-FILE (T T) * #.(flags ans set mv touch-mv)) (proclaim2 RENAME-PACKAGE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REPLACE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REST (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REVAPPEND (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REVERSE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ROOM (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ROUND (T *) * #.(flags ans set mv touch-mv)) (proclaim2 RPLACA (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RPLACD (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SBIT (T *) BIT #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SCALE-FLOAT (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SCHAR (T FIXNUM) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SEARCH (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SECOND (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SET (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SET-DIFFERENCE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SET-DISPATCH-MACRO-CHARACTER (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SET-EXCLUSIVE-OR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SET-MACRO-CHARACTER (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SET-SYNTAX-FROM-CHAR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SEVENTH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SHADOW (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SHADOWING-IMPORT (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SHORT-SITE-NAME NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SIGNUM (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SIMPLE-BIT-VECTOR-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SIMPLE-STRING-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SIMPLE-VECTOR-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SIN (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SINH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SIXTH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SLEEP (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SOFTWARE-TYPE NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SOFTWARE-VERSION NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SOME (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SORT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SPECIAL-FORM-P (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SQRT (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STABLE-SORT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STANDARD-CHAR-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STREAM-ELEMENT-TYPE (STREAM) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-CAPITALIZE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-DOWNCASE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-EQUAL (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-GREATERP (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-LEFT-TRIM (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-LESSP (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-NOT-EQUAL (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-NOT-GREATERP (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-NOT-LESSP (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-RIGHT-TRIM (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-TRIM (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-UPCASE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING/= (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING< (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING<= (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING= (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING> (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING>= (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRINGP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBLIS (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBSEQ (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBSETP (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBST (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBST-IF (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBST-IF-NOT (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBSTITUTE (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBSTITUTE-IF (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBSTITUTE-IF-NOT (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBTYPEP (T T) * #.(flags ans set mv touch-mv)) (proclaim2 SVREF ((VECTOR T) FIXNUM) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SXHASH (T) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SYMBOL-FUNCTION (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SYMBOL-NAME (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SYMBOL-PACKAGE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SYMBOL-PLIST (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SYMBOL-VALUE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SYMBOLP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TAN (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TANH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TENTH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TERPRI (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 THIRD (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TREE-EQUAL (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TRUENAME (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TRUNCATE (T *) * #.(flags ans set mv touch-mv)) (proclaim2 TYPE-OF (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TYPEP (T T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 UNEXPORT (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 UNINTERN (T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 UNION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 UNREAD-CHAR (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 UNUSE-PACKAGE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 UPPER-CASE-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 USE-PACKAGE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 USER-HOMEDIR-PATHNAME (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 VALUES (*) * #.(flags ans set mv touch-mv)) (proclaim2 VALUES-LIST (T) * #.(flags ans set mv touch-mv)) (proclaim2 VECTOR (*) (VECTOR T) #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 VECTOR-POP (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 VECTOR-PUSH (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 VECTOR-PUSH-EXTEND (T T *) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 VECTORP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WARN (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WRITE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WRITE-BYTE (INTEGER STREAM) INTEGER #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WRITE-CHAR (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WRITE-LINE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WRITE-STRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WRITE-TO-STRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 Y-OR-N-P (*) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 YES-OR-NO-P (*) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ZEROP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 si::structure-ref (t t fixnum) t #.(flags ans)) (proclaim2 si::structure-set (t t fixnum t) t #.(flags ans set)) gcl/comp/macros.lsp000077500000000000000000000042551242227143400145770ustar00rootroot00000000000000(in-package "BCOMP") ;(dolist-safe (a b) (foo a)) (defmacro dolist-safe ((x l &optional res) &body body) (let ((l1 (gensym)) (l2 (gensym))) `(let* ( (,l1 ,l) (,l2 ,l1) ,x) (loop (cond ((consp ,l1) (setq ,x (car ,l1) ,l1 (cdr ,l1)) ,@body) ((null ,l1) (return ,res)) (t (comp-error "expected a list ~a" ,l2)))))))) ;; go through a list safely signalling an error if not a true list. (def-loop-for in-list (var lis) (let ((point (gensym "POINT")) (l1 (gensym))) `(with ,point with ,l1 with ,var initially (setf ,l1 (setf ,point ,lis)) do(or (consp ,point) (comp-error "Expected a list ~a " ,l1)) (desetq ,var (car ,point)) end-test (and (null ,point)(local-finish)) increment (setf ,point (cdr ,point))))) (def-loop-for on-list (point lis) (let ((l1 (gensym))) `(with ,point with ,l1 initially (setf ,l1 (setf ,point ,lis)) do(or (consp ,point) (comp-error "Expected a list ~a " ,l1)) end-test (and (null ,point)(local-finish)) increment (setf ,point (cdr ,point))))) (defmacro safe-cdr (x) (if (symbolp x) `(progn (or (consp ,x)(null ,x) (comp-error "expected list ~a" ,x)) (cdr ,x)) (let ((xx (gensym))) `(let ((,xx ,x)) (safe-cdr ,xx))))) (defmacro memq (a l) `(member ,a,l :test 'eq)) (defmacro valex (a b form) (let (binds ) (or (eq b '*exit*) (push (list '*exit* b) binds)) (or (eq a '*value*) (push (list '*value* a) binds)) `(let ,binds ,form))) (defsetf logbitp logstore) (defmacro logstore ( i a val) `(setf (ldb (byte 1 ,i) ,a) (if ,val 1 0))) (defmacro argd-minargs(x) `(the fixnum (ldb (byte 6 0) (the fixnum ,x)))) (defmacro argd-maxargs(x) `(the fixnum (ldb (byte 6 9) (the fixnum ,x)))) (defmacro argd-flags(x) `(the fixnum (ldb (byte 3 6) (the fixnum ,x)))) (defmacro argd-atypes(x) `(the fixnum (ldb (byte 16 15) (the fixnum ,x)))) (defmacro argd-flag-p (x name) `(logbitp ,(+ 6 (position name '(requires-nargs sets-mv requires-fun-passed))) (the fixnum ,x) )) (defmacro ll (key lambda-list) `(nth ,(position key (cons '&required lambda-list-keywords)) ,lambda-list)) gcl/comp/makefile000066400000000000000000000015501242227143400142630ustar00rootroot00000000000000 LISP=../unixport/saved_kcl LOAD='(load "sysdef.lsp")(make::make :bcomp :compile t)' all: echo ${LOAD} | ${LISP} tests: echo ${LOAD}'(load "try1")(load "../tests/all-tests.lsp")(in-package "BCOMP")(do-some-tests)' \ '(test-sloop)' | ${LISP} test1: echo '(load "../tests/try-comp")' | ${LISP} TFILES=src/makefile comp/makefile unixport/makefile o/makefile \ h/enum.h src/kclobjs src/sobjs src/NewInit src/make-init tar: (cd .. ; tar cvf - ${TFILES} src/sobjs src/*.c src/*.el newh/*.el src/makefile comp/*.lsp comp/*.doc newh/*.h newh/makefile | gzip -c > ${HOME}/`date '+acl-%y%m%d'`.tar.z) all-tests: $(MAKE) - $(MAKE) tests test1 - (cd /u11/wfs/nqthm1 ; rm *.o ; $(MAKE) "LISP=nacl") - (cd /u11/wfs/gabriel ; $(MAKE) "LISP=nacl") tests2: $(MAKE) - $(MAKE) tests test1 - (cd /u11/wfs/nqthm1 ; rm *.o ; $(MAKE) "LISP=nacl") -include ../makedefs gcl/comp/mangle.lsp000077500000000000000000000074211242227143400145540ustar00rootroot00000000000000(in-package "BCOMP") ;; Naming convention ;; {f | s | q | l} ;; where f = Function, s = Symbol , q = special form (Quote) , l= Lexical ;; eg fLcar, sLnil, fSallocate_internal,sLAstandard_outputA.qLprogn (eval-when (load eval compile) (defvar *mangle-base* (make-array 128 :element-type 'character)) (defvar *mangle-escapes* (make-array 128 :element-type 'character)) (defmacro mangle-type (flag) `(position ',flag '(octal self special-escape))) (defvar *mangle-escape* #\E) (sloop for i below 128 with tem for ch = (code-char i) do (setf (aref *mangle-escapes* i) (code-char 0)) (setf (aref *mangle-base* i) (code-char (mangle-type octal))) (when (alphanumericp ch) (setf (aref *mangle-base* i) (if (upper-case-p ch) (char-downcase ch) (char-upcase ch))))) (sloop for (v ch) in '((#\+ #\Q)(#\- #\_)(#\* #\A)(#\% #\P) (#\; #\X)(#\. #\Z)(#\, #\Y) (#\ #\E) (#\@ #\B) ) do (setf (aref *mangle-base* (char-code v)) ch) (setf (aref *mangle-base* (char-code v)) ch) (setf (aref *mangle-base* (char-code (char-downcase ch))) (code-char (mangle-type special-escape))) (setf (aref *mangle-escapes* (char-code (char-downcase ch))) (char-downcase ch))) (sloop for i from (char-code #\0) to (char-code #\9) for j from (char-code #\A) do (setf (aref *mangle-escapes* i) (code-char j))) (defvar *mangle-out* (make-array 40 :element-type 'string-char :fill-pointer 0 :adjustable t)) (proclaim '(string *mangle-out* *mangle-escapes* *mangle-base*)) (proclaim '(character *mangle-escape*)) ) (defun mangle(string) (let ((string (if (symbolp string) (symbol-name string) string))) (declare (string string)) (let ((n (length string)) (start 0)) (declare (fixnum n)) (unless (> (array-total-size *mangle-out*) (the fixnum (* 4 n))) (adjust-array *mangle-out* (* 4 n) :fill-pointer 0 )) (cond ((and (> n 0) (digit-char-p (aref string 0))) (setf (aref *mangle-out* 0) *mangle-escape*) (setf (aref *mangle-out* 1) (aref *mangle-escapes* (char-code (aref string 0)))) (setf (fill-pointer *mangle-out*) 2) (incf start)) (t (setf (fill-pointer *mangle-out*) 0))) (sloop for i from start below n do (mangle1 (aref string i))) *mangle-out*))) (defun mangle1 (ch ) (declare (character ch)) (let* ((tem (aref *mangle-base* (char-code ch))) (n (char-code tem)) (out *mangle-out*)) (declare (character tem)(fixnum n)) (cond ((> n (mangle-type special-escape)) (vector-push tem *mangle-out*)) ((= n (mangle-type special-escape)) (vector-push *mangle-escape* out) (vector-push (aref *mangle-escapes* (char-code ch) )out)) ((= n (mangle-type octal)) (vector-push #.(char-upcase *mangle-escape*) out) (let ((m (char-code ch))) (vector-push (code-char (the fixnum (+ (logand (the fixnum (ash m -6)) 7) (char-code #\0)))) out) (vector-push (code-char (the fixnum (+ (logand (the fixnum (ash m -3)) 7) (char-code #\0)))) out) (vector-push (code-char (the fixnum (+ (logand m 7) (char-code #\0)))) out))) (t (wfs-error))))) #+how_to_unmangle ;; get next character and unmangle it. (defun unmangle-next () (let ((y (get-next))) (cond ((alpha-char-p y) (cond ((lower-case-p y) (upcase-char y)) ((eql y *mangle-escape*) (let ((n (get-next))) (cond ((digit-char-p n) (make-octal-char n (get-next) (get-next))) ((upper-case-p n) (code-char (+ (char-code #\0) (- n (char-code #\A))))) (t n)))) ((car (rassoc (list n) '((#\+ #\Q)(#\- #\_)(#\* #\A)(#\% #\P) (#\; #\X)(#\. #\Z)(#\, #\Y) (#\e #\E))))) (t (char-downcase n)))) (t y)))) gcl/comp/opts-base.lsp000077500000000000000000000023601242227143400152030ustar00rootroot00000000000000(in-package "BCOMP") (defopt NTH-MV ((fixnum) t #.(flags safe constantp) "(fcall.nvalues > $0 ? fcall.values[$0] : sLnil)")) (defopt LIST-MV (() t #.(flags proclaim safe ans ) "ListVector(fcall.nvalues,&fcall.values[0])") ;(() dynamic-extent #.(flags safe ans ) ; "ON_STACK_LIST_VECTOR(fcall.nvalues,&fcall.values[0])") ) ;(defopt pop-control-stack ; (() t #.(flags safe set) "CtlPop")) (defopt progv-bind ((t t) fixnum #.(flags set safe) "IprogvBind(#0,#1)")) (defopt do-throw ((t)t #.(flags proclaim set safe) "Ido_throw(#0)")) (defopt unique-id (() t #.(flags ans safe) "alloc_object(t_spice)")) (defopt pass-values (() * #.(flags proclaim mv safe) "fcall.values[0]")) (defopt nlj-active-off (()t #.(flags safe set) "nlj_active=0;VsTop = SaveVs ")) ;(defopt nlj-active-off ; (()t #.(flags safe set) "nlj_active=0; ")) (defopt assign-args (( *) t #.(flags safe set) do-assign-args)) (defopt funcall ((t *) t #.(flags set ) "@0;(VFUN_NARGS=($#-1),fcall.fun=$0,(type_of($0)==t_afun||type_of($0)==t_closure) && F_PLAIN($0->sfn.Argd) ? *($0->sfn.Body) : fcalln)($@1)")) (proclaim1 '(ftype (function (*) t) si::make-structure)) (defopt si::make-structure ((t *) t #.(flags ans safe) "ImakeStructure($#,$*0)")) gcl/comp/opts.lsp000077500000000000000000000525271242227143400143050ustar00rootroot00000000000000(in-package "BCOMP") (defopt * ((t t) t #.(flags ans safe) "number_times($0,$1)") ((fix-or-sf-or-df fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)*(double)($1)") ((fix-or-sf-or-df fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)*(double)($1)") ((integer integer) integer #.(flags rfa is safe) "mulii($0,$1)") ((integer integer integer) integer #.(flags rfa is safe) "mulii($0,mulii($1,$2))") ((fixnum integer) integer #.(flags rfa is safe) "mulsi($0,$1)") ((fixnum fixnum) fixnum #.(flags safe) "($0)*($1)")) (defopt + ((t t) t #.(flags ans safe) "number_plus($0,$1)") ((fix-or-sf-or-df fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)+(double)($1)") ((fix-or-sf-or-df fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)+(double)($1)") ((integer integer) integer #.(flags rfa is safe) "addii($0,$1)") ((integer integer integer) integer #.(flags rfa is safe) "addii($0,addii($1,$2))") ((fixnum fixnum) fixnum #.(flags safe) "($0)+($1)")) (defopt - ((t) t #.(flags ans safe) "number_negate($0)") ((t t) t #.(flags ans safe) "number_minus($0,$1)") ((fix-or-sf-or-df fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)-(double)($1)") ((fix-or-sf-or-df) short-float #.(flags safe) "-(double)($0)") ((fix-or-sf-or-df) double-float #.(flags safe) "-(double)($0)") ((fix-or-sf-or-df fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)-(double)($1)") ((integer integer) integer #.(flags rfa is safe) "subii($0,$1)") ((integer) integer #.(flags rfa is safe) "subii(gzero,$0)") ((fixnum fixnum) fixnum #.(flags safe) "($0)-($1)") ((fixnum) fixnum #.(flags safe) "-($0)")) (defopt / ((fix-or-sf-or-df fix-or-sf-or-df) short-float #.(flags rfa safe) "(double)($0)/(double)($1)") ((fix-or-sf-or-df fix-or-sf-or-df) double-float #.(flags rfa safe) "(double)($0)/(double)($1)") ((fixnum fixnum) fixnum #.(flags ) "($0)/($1)") ) (defopt /= ((t t) boolean #.(flags safe) "number_compare($0,$1)!=0") ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)!=($1)")) (defopt 1+ ((t) t #.(flags ans safe) "one_plus($0)") ((fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)+1") ((fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)+1") ((fixnum) fixnum #.(flags safe) "($0)+1")) (defopt 1- ((t) t #.(flags ans safe) "one_minus($0)") ((fixnum) fixnum #.(flags safe) "($0)-1") ((fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)-1") ((fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)-1")) (defopt < ((t t) boolean #.(flags safe) "number_compare($0,$1)<0") ((integer integer) boolean #.(flags safe) "cmpii($0,$1)<0") ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)<($1)")) (defopt <= ((t t) boolean #.(flags safe) "number_compare($0,$1)<=0") ((integer integer) boolean #.(flags safe) "cmpii($0,$1)<=0") ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)<=($1)")) (defopt = ((t t) boolean #.(flags safe) "number_compare($0,$1)==0") ((integer integer) boolean #.(flags safe) "cmpii($0,$1)==0") ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)==($1)")) (defopt > ((t t) boolean #.(flags safe) "number_compare($0,$1)>0") ((integer integer) boolean #.(flags safe) "cmpii($0,$1)>0") ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)>($1)")) (defopt >= ((t t) boolean #.(flags safe) "number_compare($0,$1)>=0") ((integer integer) boolean #.(flags safe) "cmpii($0,$1)>=0") ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)>=($1)")) (defopt APPEND ((t t) t #.(flags ans safe) "append($0,$1)")) (defopt aref-2d (((array t) fixnum fixnum fixnum) t #.(flags) "@0;($0)->a.Body[($1)*($3)+$2]")) (defopt AREF ((t t) t #.(flags ans safe) "aref1($0,fixint($1))") ((t fixnum) t #.(flags ans safe) "aref1($0,$1)") ((t t) t #.(flags ans) "aref1($0,fix($1))") (((array t) fixnum) t #.(flags) "($0)->v.Body[$1]") (((array character) fixnum) character #.(flags rfa) "($0)->ust.Body[$1]") (((array fixnum) fixnum) fixnum #.(flags rfa) "($0)->fixa.Body[$1]") (((array unsigned-char) fixnum) fixnum #.(flags rfa) "($0)->ust.Body[$1]") (((array signed-char) fixnum) fixnum #.(flags rfa) "SIGNED_CHAR(($0)->ust.Body[$1])") (((array unsigned-short) fixnum) fixnum #.(flags rfa) "((unsigned short *)($0)->ust.Body)[$1]") (((array signed-short) fixnum) fixnum #.(flags rfa) "((short *)($0)->ust.Body)[$1]") (((array short-float) fixnum) short-float #.(flags rfa) "($0)->sfa.Body[$1]") (((array long-float) fixnum) double-float #.(flags rfa) "($0)->lfa.Body[$1]") ((t t t) t #.(flags ans) "@0;aref($0,fix($1)*($0)->a.Dims[1]+fix($2))") (((array t) fixnum fixnum) t #.(flags) "@0;($0)->a.Body[($1)*($0)->a.Dims[1]+$2]") (((array character) fixnum fixnum) character #.(flags rfa) "@0;($0)->ust.Body[($1)*($0)->a.Dims[1]+$2]") (((array fixnum) fixnum fixnum) fixnum #.(flags rfa) "@0;($0)->fixa.Body[($1)*($0)->a.Dims[1]+$2]") (((array short-float) fixnum fixnum) short-float #.(flags rfa) "@0;($0)->sfa.Body[($1)*($0)->a.Dims[1]+$2]") (((array long-float) fixnum fixnum) double-float #.(flags rfa) "@0;($0)->lfa.Body[($1)*($0)->a.Dims[1]+$2]")) (defopt ARRAY-TOTAL-SIZE ((t) fixnum #.(flags rfa) "(($0)->st.Dim)")) (defopt ARRAYP ((t) boolean #.(flags safe) "@0;type_of($0)==t_array|| type_of($0)==t_vector|| type_of($0)==t_string|| type_of($0)==t_bitvector")) (defopt SYSTEM:ASET ((t t t) t #.(flags set safe) "aset1($0,fixint($1),$2)") ((t fixnum t) t #.(flags set safe) "aset1($0,$1,$2)") ((t t t) t #.(flags set) "aset1($0,fix($1),$2)") (((array t) fixnum t) t #.(flags set) "($0)->v.Body[$1]= ($2)") (((array character) fixnum character) character #.(flags set rfa) "($0)->ust.Body[$1]= ($2)") (((array fixnum) fixnum fixnum) fixnum #.(flags set rfa) "($0)->fixa.Body[$1]= ($2)") (((array signed-short) fixnum fixnum) fixnum #.(flags set rfa) "((short *)($0)->ust.Body)[$1]=($2)") (((array signed-char) fixnum fixnum) fixnum #.(flags set rfa) "(($0)->ust.Body)[$1]=($2)") (((array unsigned-short) fixnum fixnum) fixnum #.(flags set rfa) "((unsigned short *)($0)->ust.Body)[$1]=($2)") (((array unsigned-char) fixnum fixnum) fixnum #.(flags set rfa) "(($0)->ust.Body)[$1]=($2)") (((array short-float) fixnum short-float) short-float #.(flags set rfa) "($0)->sfa.Body[$1]= ($2)") (((array long-float) fixnum double-float) double-float #.(flags set rfa) "($0)->lfa.Body[$1]= ($2)") ((t t t t) t #.(flags set) "@0;aset($0,fix($1)*($0)->a.Dims[1]+fix($2),$3)") (((array t) fixnum fixnum t) t #.(flags set) "@0;($0)->a.Body[($1)*($0)->a.Dims[1]+$2]= ($3)") (((array character) fixnum fixnum character) character #.(flags set rfa) "@0;($0)->ust.Body[($1)*($0)->a.Dims[1]+$2]= ($3)") (((array fixnum) fixnum fixnum fixnum) fixnum #.(flags set rfa) "@0;($0)->fixa.Body[($1)*($0)->a.Dims[1]+$2]= ($3)") (((array short-float) fixnum fixnum short-float) short-float #.(flags set rfa) "@0;($0)->sfa.Body[($1)*($0)->a.Dims[1]+$2]= ($3)") (((array long-float) fixnum fixnum double-float) double-float #.(flags set rfa) "@0;($0)->lfa.Body[($1)*($0)->a.Dims[1]+$2]= ($3)")) (defopt ash ((fixnum fixnum) fixnum #.(flags ) "@1;($1 > 0 ? ($0) <<( $1 ): ($0) >> (-($1)))")) (defopt ATOM ((t) boolean #.(flags safe) "type_of($0)!=t_cons")) (defopt BIT-VECTOR-P ((t) boolean #.(flags safe) "(type_of($0)==t_bitvector)")) (defopt BOOLE3 ((fixnum fixnum fixnum) fixnum #.(flags rfa safe) wr-inline-boole3)) (defopt BOUNDP ((t) boolean #.(flags) "($0)->s.Bind!=OBJNULL")) (defopt CAAAAR ((t) t #.(flags) "Mcaaaar($0)")) (defopt CAAADR ((t) t #.(flags) "Mcaaadr($0)")) (defopt CAAAR ((t) t #.(flags) "Mcaaar($0)")) (defopt CAADAR ((t) t #.(flags) "Mcaadar($0)")) (defopt CAADDR ((t) t #.(flags) "Mcaaddr($0)")) (defopt CAADR ((t) t #.(flags) "Mcaadr($0)")) (defopt CAAR ((t) t #.(flags) "Mcaar($0)")) (defopt CADAAR ((t) t #.(flags) "Mcadaar($0)")) (defopt CADADR ((t) t #.(flags) "Mcadadr($0)")) (defopt CADAR ((t) t #.(flags) "Mcadar($0)")) (defopt CADDAR ((t) t #.(flags) "Mcaddar($0)")) (defopt CADDDR ((t) t #.(flags) "Mcadddr($0)")) (defopt CADDR ((t) t #.(flags) "Mcaddr($0)")) (defopt CADR ((t) t #.(flags) "Mcadr($0)")) (defopt CAR ((t) t #.(flags) "Mcar($0)")) (defopt CDAAAR ((t) t #.(flags) "Mcdaaar($0)")) (defopt CDAADR ((t) t #.(flags) "Mcdaadr($0)")) (defopt CDAAR ((t) t #.(flags) "Mcdaar($0)")) (defopt CDADAR ((t) t #.(flags) "Mcdadar($0)" )) (defopt CDADDR ((t) t #.(flags) "Mcdaddr($0)")) (defopt CDADR ((t) t #.(flags) "Mcdadr($0)")) (defopt CDAR ((t) t #.(flags) "Mcdar($0)")) (defopt CDDAAR ((t) t #.(flags) "Mcddaar($0)")) (defopt CDDADR ((t) t #.(flags) "Mcddadr($0)")) (defopt CDDAR ((t) t #.(flags) "Mcddar($0)")) (defopt CDDDAR ((t) t #.(flags) "Mcdddar($0)")) (defopt CDDDDR ((t) t #.(flags) "Mcddddr($0)")) (defopt CDDDR ((t) t #.(flags) "Mcdddr($0)")) (defopt CDDR ((t) t #.(flags) "Mcddr($0)")) (defopt CDR ((t) t #.(flags) "Mcdr($0)")) (defopt CHAR ((t t) t #.(flags ans safe) "elt($0,fixint($1))") ((t fixnum) t #.(flags ans safe) "elt($0,$1)") ((t t) t #.(flags) "code_char(($0)->ust.Body[fix($1)])") ((t fixnum) character #.(flags rfa) "($0)->ust.Body[$1]")) (defopt CHAR-CODE ((character) fixnum #.(flags rfa safe) "($0)")) (defopt SYSTEM:CHAR-SET ((t t t) t #.(flags set safe) "elt_set($0,fixint($1),$2)") ((t fixnum t) t #.(flags set safe) "elt_set($0,$1,$2)") ((t t t) t #.(flags set) "@2;(($0)->ust.Body[fix($1)]=char_code($2),($2))") ((t fixnum character) character #.(flags set rfa) "($0)->ust.Body[$1]= ($2)")) (defopt CHAR/= ((character character) boolean #.(flags safe) "($0)!=($1)") ((t t) boolean #.(flags) "!eql($0,$1)") ((t t) boolean #.(flags) "char_code($0)!=char_code($1)")) (defopt CHAR< ((character character) boolean #.(flags safe) "($0)<($1)")) (defopt CHAR<= ((character character) boolean #.(flags safe) "($0)<=($1)")) (defopt CHAR= ((t t) boolean #.(flags) "eql($0,$1)") ((t t) boolean #.(flags) "char_code($0)==char_code($1)") ((character character) boolean #.(flags) "($0)==($1)")) (defopt CHAR> ((character character) boolean #.(flags safe) "($0)>($1)")) (defopt CHAR>= ((character character) boolean #.(flags safe) "($0)>=($1)")) (defopt CHARACTERP ((t) boolean #.(flags safe) "type_of($0)==t_character")) (defopt CODE-CHAR ((fixnum) character #.(flags safe rfa) "($0)") ((t) character #.(flags rfa) "fix($0)")) (defopt CONS ((t t) t #.(flags ans constantp safe) "make_cons($0,$1)") ((t t) dynamic-extent #.(flags ans safe) "ON_STACK_CONS($0,$1)")) (defopt CONSP ((t) boolean #.(flags safe) "type_of($0)==t_cons")) (defopt COS ((double-float) double-float #.(flags rfa safe) "cos($0)")) (defopt DIGIT-CHAR-P ((character) boolean #.(flags safe) "@0; (($0) <= '9' && ($0) >= '0')")) (defopt ELT ((t t) t #.(flags ans safe) "elt($0,fixint($1))") ((t fixnum) t #.(flags ans safe) "elt($0,$1)") ((t t) t #.(flags ans) "elt($0,fix($1))")) (defopt SYSTEM:ELT-SET ((t t t) t #.(flags set safe) "elt_set($0,fixint($1),$2)") ((t fixnum t) t #.(flags set safe) "elt_set($0,$1,$2)") ((t t t) t #.(flags set) "elt_set($0,fix($1),$2)")) (defopt ENDP ((t) boolean #.(flags) "($0)==sLnil")) (defopt EQ ((t t) boolean #.(flags safe) "($0)==($1)") ((fixnum fixnum) boolean #.(flags safe) "0")) (defopt EQL ((t t) boolean #.(flags safe) "eql($0,$1)") ((fixnum fixnum) boolean #.(flags safe) "($0)==($1)")) (defopt EQUAL ((t t) boolean #.(flags safe) "equal($0,$1)") ((fixnum fixnum) boolean #.(flags safe) "($0)==($1)")) (defopt EQUALP ((t t) boolean #.(flags safe) "equalp($0,$1)") ((fixnum fixnum) boolean #.(flags safe) "($0)==($1)")) (defopt EXPT ((t t) t #.(flags ans safe) "number_expt($0,$1)") ((integer integer) integer #.(flags is safe) "powerii($0,$1)") ((fixnum fixnum) fixnum #.(flags safe) (lambda (l &aux (x1 (car l))tem) (if (and (consp x1) (eq (car x1) 'inline-loc) (consp (setq tem (third x1)))(eq 'dv (car tem)) (eql (third tem) 2)) (wr-inline-call1 l "(1 << ($1))") (wr-inline-call1 l "fixnum_expt($@0)"))))) (defopt FILL-POINTER ((t) fixnum #.(flags rfa) "(($0)->st.Fillp)")) (defopt SYSTEM:FILL-POINTER-SET ((t fixnum) fixnum #.(flags set rfa) "(($0)->st.Fillp)=($1)")) (defopt FIRST ((t) t #.(flags) "Mcar($0)")) (defopt SYSTEM:FIXNUMP ((t) boolean #.(flags safe) "type_of($0)==t_fixnum") ((fixnum) boolean #.(flags safe) "1")) (defopt FLOAT ((fix-or-sf-or-df) double-float #.(flags safe) "((doublefloat)($0))") ((fix-or-sf-or-df) short-float #.(flags safe) "((shortfloat)($0))")) (defopt FLOATP ((t) boolean #.(flags safe) "@0;type_of($0)==t_shortfloat||type_of($0)==t_doublefloat")) (defopt FLOOR ((fixnum fixnum) fixnum #.(flags rfa safe) "@01;($0>=0&&($1)>0?($0)/($1):ifloor($0,$1))")) (defopt FOURTH ((t) t #.(flags) "Mcadddr($0)")) (defopt COMPILER::FP-OK ((t) fixnum #.(flags set) "@0;(type_of($0)==t_stream? (int)(($0)->sm.Fp): 0 )") ((stream) fixnum #.(flags set) "(($0)->sm.Fp)")) (defopt GET ((t t t) t #.(flags safe) "get($0,$1,$2)") ((t t) t #.(flags safe) "get($0,$1,sLnil)")) (defopt INTEGERP ((t) boolean #.(flags safe) "@0;type_of($0)==t_fixnum||type_of($0)==t_bignum")) (defopt KEYWORDP ((t) boolean #.(flags safe) "@0;(type_of($0)==t_symbol&&($0)->s.Hpack==keyword_package)")) (defopt COMPILER::LDB1 ((fixnum fixnum fixnum) fixnum #.(flags safe) "((((~(-1 << ($0))) << ($1)) & ($2)) >> ($1))")) (defopt LENGTH ((t) fixnum #.(flags rfa safe) "length($0)") (((array t)) fixnum #.(flags rfa) "($0)->v.Fillp") (((vector character)) fixnum #.(flags rfa) "($0)->v.Fillp")) (defopt LIST ((t *) t #.(flags ans safe constantp) "list($#,$@0)") (() t #.(flags ans safe constantp) "sLnil") ) (defopt LIST* ((t *) t #.(flags ans safe constantp) "listA($#,$@0)")) (defopt LISTP ((t) boolean #.(flags constantp safe) "@0;type_of($0)==t_cons||($0)==sLnil")) (defopt LOGAND ((fixnum fixnum) fixnum #.(flags rfa safe) "(($0) & ($1))")) (defopt LOGIOR ((fixnum fixnum) fixnum #.(flags rfa safe) "(($0) | ($1))")) (defopt LOGNOT ((fixnum) fixnum #.(flags rfa safe) "(~($0))")) (defopt COMPILER::LONG-FLOAT-P ((t) boolean #.(flags safe) "type_of($0)==t_doublefloat")) (defopt MAKE-LIST ((fixnum) dynamic-extent #.(flags ans safe) "@0;(ALLOCA_CONS($0),ON_STACK_MAKE_LIST($0))")) (defopt MAX ((t t) t #.(flags safe) "@01;(number_compare($0,$1)>=0?($0):$1)") ((fixnum fixnum) fixnum #.(flags rfa safe) "@01;($0)>=($1)?($0):$1")) (defopt MIN ((t t) t #.(flags safe) "@01;(number_compare($0,$1)<=0?($0):$1)") ((fixnum fixnum) fixnum #.(flags rfa safe) "@01;($0)<=($1)?($0):$1")) (defopt MINUSP ((t) boolean #.(flags safe) "number_compare(small_fixnum(0),$0)>0") ((fix-or-sf-or-df) boolean #.(flags safe) "($0)<0")) (defopt MOD ((fixnum fixnum) fixnum #.(flags rfa safe) "@01;($0>=0&&($1)>0?($0)%($1):imod($0,$1))")) (defopt SYSTEM:MV-REF ((fixnum) t #.(flags ans set safe) "(MVloc[($0)])")) (defopt NCONC ((t t) t #.(flags set safe) "nconc($0,$1)")) (defopt NOT ((t) boolean #.(flags safe) "($0)==sLnil") ((boolean) boolean #.(flags safe) "!($0)")) (defopt NREVERSE ((t) t #.(flags ans set safe) "nreverse($0)")) (defopt NTH ((t t) t #.(flags safe) "nth(fixint($0),$1)") ((fixnum t) t #.(flags safe) "nth($0,$1)") ((t t) t #.(flags) "nth(fix($0),$1)")) (defopt NTHCDR ((t t) t #.(flags safe) "nthcdr(fixint($0),$1)") ((fixnum t) t #.(flags safe) "nthcdr($0,$1)") ((t t) t #.(flags) "nthcdr(fix($0),$1)")) (defopt NULL ((t) boolean #.(flags safe) "($0)==sLnil")) (defopt NUMBERP ((t) boolean #.(flags safe) "@0;type_of($0)==t_fixnum|| type_of($0)==t_bignum|| type_of($0)==t_ratio|| type_of($0)==t_shortfloat|| type_of($0)==t_doublefloat|| type_of($0)==t_complex")) (defopt PLUSP ((t) boolean #.(flags safe) "number_compare(small_fixnum(0),$0)<0") ((fix-or-sf-or-df) boolean #.(flags safe) "($0)>0")) (defopt PRIN1 ((t t) t #.(flags set safe) "prin1($0,$1)") ((t) t #.(flags set safe) "prin1($0,sLnil)")) (defopt PRINC ((t t) t #.(flags set safe) "princ($0,$1)") ((t) t #.(flags set safe) "princ($0,sLnil)")) (defopt PRINT ((t t) t #.(flags set safe) "print($0,$1)") ((t) t #.(flags set safe) "print($0,sLnil)")) (defopt PROBE-FILE ((t) boolean #.(flags safe) "(file_exists($0))")) (defopt SYSTEM:PUTPROP ((t t t) t #.(flags set safe) "putprop($0,$1,$2)")) (defopt COMPILER::QFEOF ((fixnum) boolean #.(flags set) "(feof((FILE *)($0)))")) (defopt COMPILER::QGETC ((fixnum) fixnum #.(flags set rfa) "($0=getc((FILE *)($0)))")) (defopt COMPILER::QPUTC ((fixnum fixnum) fixnum #.(flags set rfa) "(putc($0,((FILE *)($1))))") ((character fixnum) fixnum #.(flags set rfa) "(putc($0,((FILE *)($1))))")) (defopt COMPILER::READ-BYTE1 ((t t) t #.(flags ans set) "read_byte1($0,$1)")) (defopt COMPILER::READ-CHAR1 ((t t) t #.(flags ans set) "read_char1($0,$1)")) (defopt REM ((integer integer) integer #.(flags rfa is safe) "dvmdii($0,$1,-1)") ((integer fixnum) fixnum #.(flags rfa is safe) "(FIXtemp=(int)dvmdii($0,stoi($1),-1), (signe(FIXtemp)> 0 ? (int) ((GEN)FIXtemp)[2] : (signe(FIXtemp)< 0 ? -(int)((GEN)FIXtemp)[2] : 0)))") #+truncate_use_c ((fixnum fixnum) fixnum #.(flags rfa safe) "($0)%($1)")) (defopt REMPROP ((t t) t #.(flags set safe) "remprop($0,$1)")) (defopt REST ((t) t #.(flags) "Mcdr($0)")) (defopt REVERSE ((t) t #.(flags ans safe) "reverse($0)")) (defopt RPLACD ((t t) t #.(flags set) "@0;($0->c.Cdr=$1,$0)")) (defopt RPLACA ((t t) t #.(flags set) "@0;($0->c.Car=$1,$0)")) (defopt SCHAR ((t t) t #.(flags ans safe) "elt($0,fixint($1))") ((t fixnum) t #.(flags ans safe) "elt($0,$1)") ((t t) t #.(flags rfa) "code_char(($0)->ust.Body[fix($1)])") ((t fixnum) character #.(flags rfa) "($0)->ust.Body[$1]")) (defopt SYSTEM:SCHAR-SET ((t t t) t #.(flags set safe) "elt_set($0,fixint($1),$2)") ((t fixnum t) t #.(flags set safe) "elt_set($0,$1,$2)") ((t t t) t #.(flags set) "@2;(($0)->ust.Body[fix($1)]=char_code($2),($2))") ((t fixnum character) character #.(flags set rfa) "($0)->ust.Body[$1]= ($2)")) (defopt SECOND ((t) t #.(flags) "Mcadr($0)")) (defopt SYSTEM:SET-MV ((fixnum t) t #.(flags ans set safe) "(MVloc[($0)]=($1))")) (defopt COMPILER::SHIFT<< ((fixnum fixnum) fixnum #.(flags safe) "(($0) << ($1))")) (defopt COMPILER::SHIFT>> ((fixnum fixnum) fixnum #.(flags safe) "(($0) >> (- ($1)))")) (defopt COMPILER::SHORT-FLOAT-P ((t) boolean #.(flags safe) "type_of($0)==t_shortfloat")) (defopt COMPILER::SIDE-EFFECTS (nil t #.(flags ans set safe) "Ct")) (defopt SIN ((double-float) double-float #.(flags rfa safe) "sin($0)")) (defopt SYSTEM:SPUTPROP ((t t t) t #.(flags set safe) "sputprop($0,$1,$2)")) (defopt COMPILER::STACK-CONS ((fixnum t t) t #.(flags safe) "(STcons$0.t=t_cons,STcons$0.m=0,STcons$0.Car=($1), STcons$0.Cdr=($2),(object)&STcons$0)") ((fixnum t t) t #.(flags safe) "(STcons$0.t=t_cons,STcons$0.m=0,STcons$0.Car=($1), STcons$0.Cdr=($2),(object)&STcons$0)")) (defopt STRING ((t) t #.(flags ans safe) "coerce_to_string($0)")) (defopt STRINGP ((t) boolean #.(flags safe) "type_of($0)==t_string")) (defopt SYSTEM:STRUCTURE-DEF ((t) t #.(flags) "($0)->str.Def")) (defopt SYSTEM:STRUCTURE-REF ((t t fixnum) t #.(flags ans safe) "structure_ref($0,$1,$2)") ((t t fixnum) t #.(flags ) do-structure-ref) (((struct fixnum) t fixnum) fixnum #.(flags ) do-structure-ref) (((struct character) t fixnum) character #.(flags ) do-structure-ref) (((struct double-float) t fixnum) double-float #.(flags ) do-structure-ref) (((struct short-float) t fixnum) short-float #.(flags ) do-structure-ref) ) (defopt SYSTEM:STRUCTURE-SET ((t t fixnum t) t #.(flags set safe) "structure_set($0,$1,$2,$3)") ((t t fixnum t) t #.(flags set ) do-structure-set) (((struct fixnum) t fixnum fixnum) fixnum #.(flags set ) do-structure-set) (((struct character) t fixnum character) character #.(flags set ) do-structure-set) (((struct double-float) t fixnum double-float) double-float #.(flags set ) do-structure-set) (((struct short-float) t fixnum short-float) short-float #.(flags set ) do-structure-set) ) (defopt SYSTEM:STRUCTUREP ((t) boolean #.(flags safe) "type_of($0)==t_structure")) (defopt COMPILER::SUBLIS1 ((t t t) t #.(flags ans set safe) compiler::sublis1-inline)) (defopt SVREF ((t t) t #.(flags ans safe) "aref1($0,fixint($1))") ((t fixnum) t #.(flags ans safe) "aref1($0,$1)") ((t t) t #.(flags) "($0)->v.Body[fix($1)]") ((t fixnum) t #.(flags) "($0)->v.Body[$1]")) (defopt SYSTEM:SVSET ((t t t) t #.(flags set safe) "aset1($0,fixint($1),$2)") ((t fixnum t) t #.(flags set safe) "aset1($0,$1,$2)") ((t t t) t #.(flags set) "(($0)->v.Body[fix($1)]=($2))") ((t fixnum t) t #.(flags set) "($0)->v.Body[$1]= ($2)")) (defopt COMPILER::SYMBOL-LENGTH ((t) fixnum #.(flags rfa safe) "@0;(type_of($0)==t_symbol ? ($0)->s.Fillp :not_a_variable(($0)))")) (defopt SYMBOL-NAME ((t) t #.(flags ans safe) "symbol_name($0)")) (defopt SYMBOL-PLIST ((t) t #.(flags) "(($0)->s.Plist)")) (defopt SYMBOLP ((t) boolean #.(flags safe) "type_of($0)==t_symbol")) (defopt TAN ((double-float) double-float #.(flags rfa safe) "tan($0)")) (defopt TERPRI ((t) t #.(flags set safe) "terpri($0)") (nil t #.(flags set safe) "terpri(sLnil)")) (defopt THIRD ((t) t #.(flags) "Mcaddr($0)")) (defopt TRUNCATE ((integer integer) integer #.(flags rfa is safe) "dvmdii($0,$1,0)") #+truncate_use_c ((fixnum fixnum) fixnum #.(flags rfa safe) "($1)/($2)") ((fix-or-sf-or-df) fixnum #.(flags safe) "(fixnum)($0)")) (defopt COMPILER::VECTOR-TYPE ((t fixnum) boolean #.(flags safe) "@0;(type_of($0) == t_vector && ($0)->v.Elttype == ($1))")) (defopt VECTORP ((t) boolean #.(flags safe) "@0;type_of($0)==t_vector|| type_of($0)==t_string|| type_of($0)==t_bitvector")) (defopt WRITE-CHAR ((t) t #.(flags set) "@0;(writec_stream(char_code($0),Vstandard_output->s.Bind),($0))")) (defopt ZEROP ((t) boolean #.(flags safe) "number_compare(small_fixnum(0),$0)==0") ((integer) boolean #.(flags rfa safe) "lgef($0)==2") ((fix-or-sf-or-df) boolean #.(flags safe) "($0)==0")) gcl/comp/proclaim.lsp000077500000000000000000000000251242227143400151100ustar00rootroot00000000000000(in-package "BCOMP") gcl/comp/smash-oldcmp.lsp000077500000000000000000000004111242227143400156700ustar00rootroot00000000000000 (dolist (v '((compile-file . bcomp::compile-file1) (proclaim . bcomp::proclaim1) (disassemble . bcomp::disassemble1))) (setf (symbol-function (car v)) (symbol-function (cdr v)))) (setq compiler::*cc* (si::concatenate 'string compiler::*cc* " -g ")) gcl/comp/stmt.lsp000077500000000000000000000300451242227143400142760ustar00rootroot00000000000000(in-package "BCOMP") ;; pass 2 c compilation (defvar *value* ;; indicates where to store the value of the current expression being ;; computed. ;; one of '(var ) ;; '(mv ) ;; '(ignore) ) (setf (get 'nil 'dv) "sLnil") (setf (get 't 'dv) "sLt") ;; This function is the main dispatch. It causes writing out of the ;; code for x. An implicit *value* is set during this write out. ;; The code for doing that is in b2-call, b2-var, b2-return, and ;; any other primitives which might return a value. Note things like ;; progn, let, prog1, all just call expr-b2 on their last term. (defun expr-b2(x &aux fd) (cond ((consp x) (setq fd (get (car x) 'b2)) (cond (fd (funcall fd x)) (t (wfs-error)))) ((typep x 'var) (unwind-set x)) ((eq x nil) (unwind-set '(dv "sLnil" nil))) ((eq x t) (unwind-set '(dv "sLt" t))) (t (wfs-error)))) (setf (get 'call 'b2) 'b2-call) (defun maybe-push-avma-bind () (sloop for v on *control-stack* do (cond ((or (eq (car v) 'avma-bind) (eq (car v) 'avma-bind-needed)) (return nil)) ((typep (car v) 'label) (loop-finish))) finally (push 'avma-bind *control-stack*) (return *control-stack*))) (defun b2-call (x &aux type-wanted (loc (second *value*)) tem avma-bind) (cond ((eq (car *value*) 'mv) (setq type-wanted 'mv)) (loc (cond ((typep loc 'var) (setq type-wanted (var-type loc))) ((and (consp loc) (eq (car loc) 'var)) (setq type-wanted (third loc))) (t (wfs-error)))) (t (setq type-wanted t))) (setq avma-bind (maybe-push-avma-bind)) (setq tem (cons 'inline-call (cdr (inline-call x type-wanted )))) (cond ((eq (car *value*) 'ignore) (unwind-set tem avma-bind)) (t (let ((*MV-N-VALUES-SET* *MV-N-VALUES-SET*)) ;; We must communicate whether or not this inline-call ;; sets multiple values, before we replace it by a temp (when (unwind-stack-p (cdr *exit*)) (if (flag-p (opt flag (cddr tem)) mv) (setq *MV-N-VALUES-SET* t)) (setq tem (replace-inline-by-temp tem))) (unwind-set tem avma-bind)))) ) (setf (get 'setq 'b2) 'b2-setq) (defun b2-setq (form &aux last) ;;(setq desk var val var val..) (do ((x (cddr form) (cddr x))) ((null x)) (setq last (car x)) (valex (list 'var last) (next-exit) (expr-b2 (second x)))) (unwind-set last)) (setf (get 'tagbody 'b2) 'b2-tagbody) (defun b2-tagbody (x &aux bod lab all-labels it (*blocks* 0) (*control-stack* *control-stack*)) (setq bod (third x)) (dolist (v bod) (when (and (consp v) (eq (car v) 'label)) (setq lab (second v)) (setf (label-ind lab) (next-label)) (push lab all-labels))) (sloop for v on *control-stack* when (or (eq (car v) 'avma-bind) (eq (car v) 'avma-bind-needed)) do (push 'inner-avma *control-stack*) (open-block) (wr "long InnerAvma=avma;") (return nil)) (setq *control-stack* (nconc all-labels *control-stack*)) (sloop for v on bod do (setq it (car v)) (valex '(ignore) (next-exit) (expr-b2 it))) ;; this should do the unwinding to the outside frame. (cond ((and (consp it) (or (eq (car it) 'return-from) (eq (car it) 'go))) ;;I don't even think this unwind-stack is necessary. ;; I don't see hwo it will be reached. (unwind-stack (cdr *exit*))) (t (expr-b2 (get-object nil)))) (close-blocks) ) (setf (get 'label 'b2) 'b2-label) (defun b2-label (x &aux (lab (second x))) (or (typep lab 'label) (wfs-error)) (wr-label x) (wr ";")) (setf (get 'go 'b2) 'b2-go) (defun b2-go (x &aux lab) (setq lab (cadr x)) (let ((upto (member lab *control-stack* :test 'eq))) (or upto (wfs-error)) (unwind-stack upto) (wr-go lab))) (setf (get 'if 'b2) 'b2-if) (defmacro ifb (x y) `(nth ,(position x '(test then else)) (cddr ,y))) (defun dv-p (x) (and (consp x) (eq (car x) 'dv))) (defun trans-if (x &aux test then else t-test t-then t-else lab new (desk (second x))) ;; transform an if expression so that the TEST is neither an IF nor a CONSTANT. (desetq (test then else) (cddr x)) (cond ((and (consp test) (eq (car test) 'if)) (setq t-then (ifb then test) t-else (ifb else test) t-test (ifb test test)) (setq lab (make-label)) (cond ((dv-p t-then)) ((dv-p t-else) (setq t-test (do-not t-test)) (rotatef t-then t-else)) (t (return-from trans-if x))) (setq new (cond ((null (third t-then)) `(if ,desk,t-test (progn ,desk ((nlabel ,lab) ,else)) (if ,desk ,t-else ,then (go ,lab) ))) (t `(if ,(second x),t-test (progn ,desk ((nlabel ,lab) ,then)) (if ,desk ,t-else (go ,lab) ,else)))))) ((dv-p test) (setq new (if (third test) then else)) (cond ((and (consp new) (eq (car new) 'if)) (setq new (trans-if new)))) (return-from trans-if new))) (cond (new (trans-if new)) (t x))) (defun do-not (x) `(call ,(make-desk 'boolean) ,(make-call-data 'not (list x) nil nil))) (setf (get 'nlabel 'b2) 'b2-nlabel) (defun b2-nlabel (x) (push (second x) *control-stack*) (wr-label (second x)) (wr ";")) (defun b2-if (form &aux test then else (*control-stack* *control-stack*) avma-bind) (setq form (trans-if form)) (unless (and (consp form) (eq (car form) 'if)) (return-from b2-if (expr-b2 form))) (desetq (test then else) (cddr form)) (setq avma-bind (maybe-push-avma-bind)) (let ((tem (inline-arg test 'boolean nil (cons nil nil)))) (when avma-bind (cond ((eq (car avma-bind) 'avma-bind-needed) (let ((tem1 (get-temp 'boolean))) (valex (list 'var tem1) (next-exit) (unwind-set tem avma-bind)))) (t (remove-avma-bind avma-bind)))) (wr-nl "if(" tem "){")) (let ((*blocks* 0)) (expr-b2 then) (close-blocks) (wr "}")) (unless (and (or (atom else) (eq (car else) 'dv)) (eq (car *value*) 'ignore) (eq (car *exit*) 'next) (not (unwind-stack-p (cdr *exit*)))) (let ((*blocks* 0)) (wr-nl "else ") (open-block) (expr-b2 else) (close-blocks))) ) (setf (get 'block 'b2) 'b2-block) (defun b2-block (x &aux sform block bod dsk end-label (*control-stack* *control-stack*)) (desetq (sform dsk block bod) x) (push block *control-stack*) (setq end-label (make-label)) (setf (block-exit block) (cond ((eq (car *exit*) 'next) (cons end-label (cdr *exit*))) (t *exit*))) (setf (block-value block) *value*) (valex *value* (block-exit block) (progn-b2 bod)) (cond ((label-ind end-label) (wr-label end-label) (wr ";")))) (setf (get 'return-from 'b2) 'b2-return-from) (defun b2-return-from (x &aux block form tem) (desetq (block form) (cddr x)) (cond ((setq tem (member block *control-stack*)) (valex (block-value block) (block-exit block) (expr-b2 form))) (t (wfs-error)))) (setf (get 'the 'b2) 'b2-the) (defun b2-the (x) (expr-b2 (third x))) (defun fdata-to-obj (fdat ) (or (typep fdat 'fdata) (wfs-error)) (or (fdata-ind fdat) (setf (fdata-ind fdat) (incf *next-function*))) (cond ((fdata-closure-vars fdat) (let ((args (mapcar #'(lambda (x) (list 'var (var-ind x))) (fdata-closure-vars fdat)))) (list 'inline-call (list* (get-load-time-form 'si::%memory) fdat args) '(*) t #.(flags ans) (format nil "MakeClosure(~a,~a,$@0)" (length (fdata-closure-vars fdat)) (fdata-to-argd fdat) )))) (t (list 'inline-call (list fdat (fdata-to-argd fdat) (get-load-time-form 'si::%memory) ) '(t fixnum t) t #.(flags ans constantp) "MakeAfun($0,$1,$2)" )))) (setf (get 'pointer-to-funobj 'b2) 'b2-pointer-to-funobj) (defun b2-pointer-to-funobj (x &aux ans tem) (setq tem (second x)) (cond ((and (consp tem) (eq (car tem) 'lambda-block)) (setq tem (second tem)))) (setq ans (fdata-to-obj tem)) (unwind-set ans)) (setf (get 'lambda-block 'b2) 'b2-lambda-block) (setf (get 'lambda 'b2) 'b2-lambda-block) (defun b2-lambda-block (x &aux result (*used-names* *used-names*)) (let ((fdat (second x))) (unless (fdata-ind fdat) (setf (fdata-ind fdat) (mangle-name (fdata-name fdat) 'function))) (push (list 'local-function x) *local-funs*) ; (wr-h "static object " fdat "();") (setq result (fdata-to-obj fdat)) (unwind-set result))) (defun might-touch-mv (x) ;; This needs expanding to handle functions like LIST,+, ;; .. etc which do not touch mv (not (or (atom x) (eq (car x) 'var) (eq (car x) 'dv)))) (setf (get 'values 'b2) 'b2-values) (defun b2-values (x &aux (argl (third x)) avma-bind) (cond ((eq (car *value*) 'mv) (setq avma-bind (maybe-push-avma-bind)) (let ((args (car (inline-args argl '(*))))) (sloop for v on args when (and (consp (car v)) (might-touch-mv (car v))) do (setf (car v) (replace-inline-by-temp (car v)))) (when (cdr args) (wr-nl "{obj *MVptr = &fcall.values[1];" "*MVptr =" (second args) ";") (dolist (v (cddr args))(wr "*(++MVptr) = " v ";")) (wr "}")) (wr " fcall.nvalues=" (length args) ";") (let ((*MV-N-VALUES-SET* t)) (unwind-set (if args (car args) (get-object nil)) avma-bind)) )) (argl (expr-b2 (car argl))) (t (expr-b2 (get-object nil))))) (setf (get 'call-set-mv 'b2) 'b2-call-set-mv) (defun b2-call-set-mv (x &aux form) ;; invoke form setting up multiple-values. ;; x == (call-set-mv desk form) (setq form (third x)) (valex `(mv (var "fcall.values[0]")) (next-exit) (expr-b2 form))) (setf (get 'progv 'b2) 'b2-progv) (defun b2-progv (x &aux binds body) (desetq (binds body) (cddr x)) (let ((tem (get-temp 'fixnum))) (valex `(var ,tem) (next-exit) (expr-b2 binds)) (let ((*control-stack* (cons `(progv-bind ,tem) *control-stack*))) (progn-b2 body)))) (setf (get 'flet 'b2) 'b2-flet) (defun b2-flet (x &aux binds body fd) (desetq (binds body) (cddr x)) (sloop for v in binds do (setq fd (cadr (third v))) (or (typep fd 'fdata) (wfs-error)) (or (fdata-ind fd) (setf (fdata-ind fd) (incf *next-function*))) (valex '(ignore) (next-exit) (expr-b2 (third v))) ) (progn-b2 body)) (defun do-assign-args (x &aux reqs) (setq reqs (ll &required (fdata-ll *fdata*))) (or (eql (length x) (length reqs)) (comp-error "Wrong number of args in call to ~a " (fdata-name *fdata*))) (sloop for v in reqs for val in x do (wr-set-inline-loc (car v) val) ) ) (defvar *aet-types* #(T STRING-CHAR SIGNED-CHAR FIXNUM SHORT-FLOAT DOUBLE-FLOAT SIGNED-CHAR UNSIGNED-CHAR SIGNED-SHORT UNSIGNED-SHORT)) (defun aet-type (i) (aref *aet-types* i)) (defun aet-c-type (type) (ecase type ((t) "object") ((string-char signed-char) "char") (fixnum "fixnum") (unsigned-char "unsigned char") (unsigned-short "unsigned short") (signed-short "short") (unsigned-short "unsigned short") (double-float "double") (short-float "float"))) (defun do-structure-ref (iargs &aux x name ind (index 0) sd) (declare (fixnum index)) (setq x (car iargs) name (second iargs) ind (third iargs)) (or (and (consp ind) (eq (car ind)'inline-loc) (dv-p (third ind))) (wfs-error)) (setq index (third (third ind))) (setq sd (get (third name) 'si::s-data)) (or sd (wfs-error)) (let* ((aet (aref (si::s-data-raw sd) index)) (c-type (aet-c-type (aref *aet-types* aet))) (pos (aref (si::s-data-slot-position sd) index))) (wr "STREF(" c-type "," x "," pos")"))) (defun do-structure-set (iargs) (let ((rargs (butlast iargs))) (do-structure-ref rargs) (wr " = " (car (last iargs))))) (defun si::setf-structure-access (struct type index newvalue) (case type (list `(si:rplaca-nthcdr ,struct ,index ,newvalue)) (vector `(si:aset ,struct ,index ,newvalue)) (t (let ((sd (get type 'si::s-data))) (when sd (let ((res-type (comp-type(aet-type (aref (si::s-data-raw sd) index))))) (cond ((eq res-type t) `(si::structure-set ,struct ',type ,index ,newvalue)) (t `(the ,res-type (si::structure-set (the (struct ,res-type),struct) ',type ,index (the ,res-type ,newvalue))))))))))) (setf (get 'eval-when 'b2) 'b2-eval-when) (defun b2-eval-when (x) (progn-b2 (cddr x))) gcl/comp/sysdef.lsp000077500000000000000000000012521242227143400146020ustar00rootroot00000000000000(in-package "BCOMP" :use '("LISP" "SLOOP")) (setq compiler::*cc* (concatenate 'string compiler::*cc* " -I../newh -I../h")) (setf macros '(defmacro data defs macros wr)) (require "MAKE" "../lsp/make.lisp") (setf files '( var c-pass1 fasdmacros lambda top top1 bo1 inline top2 stmt exit mangle utils comptype)) (proclaim '(optimize (speed 0))) (setf (get :bcomp :make) `((:serial ,@ macros) ,@ files (:progn (unless (get 'list 'bcomp-opt) (load "lisp-decls.doc") (load "opts.lsp")) (load "opts-base.lsp") ) (:depends ,files ,macros))) (setf (get :bcomp :source-path) "foo.lsp") (setf (get :bcomp :object-path) "foo.o") gcl/comp/top.lsp000077500000000000000000000047111242227143400141120ustar00rootroot00000000000000(in-package "BCOMP") (eval-when (compile eval load) (defparameter *comp-vars* '(*c-output* *h-output* *lsp-input* *data-output* *next-vv* *data* *data-table* *hard-error* *top-form* *top-forms* )) (proclaim (cons 'special *comp-vars*)) ) (defun get-output-pathname (ext) (declare (special input-pathname )) (setq input-pathname (pathname input-pathname)) (let ((dir (pathname-directory *default-pathname-defaults*))) (make-pathname :directory (or (pathname-directory input-pathname) dir) :name (pathname-name input-pathname) :type ext))) (defvar *safety* 0 ;; the safety level set by proclaim '(optimize (safety n)) ) (defvar *speed* 3 ;; the desired speed level of the final code. The higher the ;; speed the slower the compilation, but the faster the code runs. ) (proclaim '(fixnum *safety* *space* *speed*)) (defun open-out (ext flag) (if (streamp flag) flag (open (get-output-pathname ext) :direction :output))) (defun compile-file1 (input-pathname &key output-file (load nil) (message-file nil) system-p (c-debug t) (c-file t) (h-file t)( data-file t) (o-file t) &aux (*package* *package*) (*readtable* *readtable*)) (declare (special input-pathname output-file c-debug)) message-file system-p (progv *comp-vars* '#. (make-list (length *comp-vars*)) (unwind-protect (progn (setq *data-table* (make-hash-table :test 'eql)) (setq *data* (list (make-array 50 :fill-pointer 0 ))) (setq *lsp-input* (open input-pathname)) (execute-pass-1) (setq *c-output* (open-out "c" c-file)) (setq *h-output* (open-out "h" h-file)) (setq *data-output* (open-out "data" data-file)) (execute-pass-2) (compile-and-add-data-file o-file) (let ((out (get-output-pathname "o"))) (and output-file (rename-file out output-file)) (if load (load out)) out) ) ;; unwind protect forms: (flet ((maybe-delete (f flag) (cond ((and (streamp f) (not (eq f flag))) (close f) (if (not flag) (delete-file (pathname f))))))) (maybe-delete *c-output* c-file) (maybe-delete *h-output* h-file) (maybe-delete *data-output* data-file) (if (streamp *lsp-input*) (close *lsp-input*)) )))) gcl/comp/top1.lsp000077500000000000000000000064511242227143400141760ustar00rootroot00000000000000(in-package "BCOMP") (setf (get 'eval-when 't1) 't1eval-when) (setf (get 'progn 't1) 't1progn) (setf (get 'defun 't1) 't1top-macro) (setf (get 'quote 't1) 't1ignore) (setf (get 'defmacro 't1) 't1top-macro) (setf (get 'defvar 't1) 't1top-macro) (setf (get 'defparameter 't1) 't1top-macro) (defun t1top-macro (x) (let ((*top-form* x)) (setq x (macroexpand x)) (pass-1 x))) (defun t1ignore (form) form nil) (defvar *changed* nil) (defvar *FUNCTION-DECLS* nil) (defvar *in-pass-1* nil) (defun execute-pass-1 ( &aux (eof '(nil)) tem (*in-pass-1* t) (*changed* (make-array 40 :fill-pointer 0 :adjustable t))) (sloop while (not (eq eof (setq tem (read *lsp-input* nil eof)))) do (pass-1 tem)) (setq *top-forms* (nreverse *top-forms*)) ) (defvar *eval-when-defaults* :defaults) (dolist (v '(si::*make-special si::*make-constant proclaim si::define-macro make-package in-package shadow shadowing-import export unexport si::define-structure use-package unuse-package import provide require)) (setf (get v 'eval-at-compile) t)) ;; return t if we do an eval, (defun maybe-comp-eval (default-action form) (or default-action (and (symbolp (car form)) (setq default-action (get (car form) 'eval-at-compile)))) (cond ((or (and default-action (eq :defaults *eval-when-defaults*)) (and (consp *eval-when-defaults*)(member 'compile *eval-when-defaults* ))) (comp-eval form) t))) (defun t1eval-when (x &aux do-load do-compile) (sloop for v in-list (second x) do (case v (eval) (load (setq do-compile t)) (compile (setq do-compile t)) (otherwise (comp-error "Bad arg to eval-when ~a" v)))) (let ((*eval-when-defaults* (second x))) (cond (do-compile (t1progn (cddr x)))))) (defun walk-top-form (x &aux (*top-form* x)) (let* (*contains-function* (tem (walk-top x))) (setq tem (make-top-form :lisp x :walked tem :funp *contains-function*)))) (defvar *variable-decls*) (defvar *function-decls*) (defun pass-1 (x &aux *variable-decls* fd) ;; fix for symbol macro (cond ((atom x) (return-from pass-1 nil))) (cond ((symbolp (car x)) (cond ((setq fd (get (car x) 't1)) (funcall fd x)) ((macro-function (car x)) (setq x (macroexpand x)) (pass-1 x)) (t (maybe-comp-eval nil x) (push (walk-top-form x) *top-forms*) ))) ((and (consp (car x)) (eq (caar x) 'lambda)) (pass-1 `(funcall (function ,(car x)) ,@ (cdr x)))) (t (comp-error "Unexpected form ~a" x)))) (setf (get 'si::defmacro* 'b1) 'b1-defmacro*) (setf (get 'si::fset 't1) 't1-set) (setf (get 'mset 't1) 't1-set) ;; use for fset,define-macro and defvar (defun t1-set (form &aux var val sform) (maybe-comp-eval nil form) (desetq (sform var val) form) (or (and (consp var) (eq (car var) 'quote) (symbolp (second var))) (error "expected a symbol")) (push `(,sform ,var ,(walk-top-form val)) *top-forms*) ) (defun t1progn(form) (sloop for v in-list form do (pass-1 v))) (defun b1-defmacro* (form where) (let* ((tem (comp-eval form))) (push 'list tem) (b1-walk tem where))) (defun comp-eval (form ) (multiple-value-bind (error res) (si::error-set `(eval ',form)) (or error (return-from comp-eval res))) (comp-error "Evaluation of ~s failed" form)) gcl/comp/top2.lsp000077500000000000000000000771321242227143400142030ustar00rootroot00000000000000(in-package "BCOMP") ;; pass 2 c compilation (eval-when (compile eval load) (defparameter *pass-2-vars* '( *address-vector* ;; At load time the index in *cfun-addresses* ;; will be the address of the function. This *address-vector* is used ;; at the end to create this vector in the .h file. *next-data* ;; is the next data index available *next-label* ;; is next label available number *next-function* ;; next function number as `3' in L3 *blocks* ;; number of '{' we have nested using open-block *next-cvar* ;; is next c variable number *file-inline-templates* *local-funs* ;; are extra-local-funs to do *local-inline-templates* ;; inline templates *top-level-closure-vars* ;; call links. *links* ;; alist of forms to eval at load time and put in constant vector. *load-time-forms* ;; if not nil open a block *do-pending-open* )) (proclaim (cons 'special *pass-2-vars*)) ) (defun vararg-p (fd) (let ((ll (fdata-ll fd))) (or (ll &optional ll) (ll &rest ll) (ll &key ll)))) (eval-when (load compile eval) (defvar *illegal-names* (make-hash-table :size 100 :test 'equal)) (unless ; (gethash "case" *illegal-names*) (dolist (v'(;;C reserved words: "do" "for" "sizeof" "typedef" "extern" "static" "auto" "register" "void" "char" "short" "int" "long" "float" "double" "signed" "unsigned" "struct" "union" "enum" "const" "volatile" "case" "default" "if" "else" "switch" "while" "do" "for" "goto" "continue" "break" ;;varargs "va_start" "va_end" "va_list" "va_dcl" "va_alist" "stdin" "stdout" "inline" ;lisp specific: "length" "elt" "object" "car" "cdr" "list" "number_plus" "number_times" "bool" fixnum" shortfloat" "doublefloat" )) (setf (gethash v *illegal-names*) t))) (defvar *use-mangled-names* t) (defvar *used-names* ;; bound by lets and constructions which bind variables nil) (defun mangle-name (name name-type &aux p) ;; NAME is a symbol which we wish to mangle, and name-type is ;; 'var or 'function. (cond ((or (null *use-mangled-names*) (null name) (null (setq p (symbol-package name)))) (cond ((eq name-type 'var) *next-cvar*) ((eq name-type 'function) (incf *next-function*)) (t (incf *next-cvar*)))) (t (or (eq name-type 'var) (setq p (get-package-shortname p))) (let ((v (mangle name))) (cond ((eq name-type 'var) (do ((i 0) (w v (setq w (format nil "V~a~a" (incf i) v)))) ((not (or (gethash w *illegal-names*) (member w *used-names* :test 'equal))) (setq w (copy-seq w)) (Push w *used-names*) w))) (t (si::string-concatenate (cond ((eq name-type 'function) "f") ((eq name-type 'symbol) "s") (t "u")) p v ))))))) (defvar *package-names* nil) (defun get-package-shortname (x) (or *package-names* (setq *package-names* `((,(find-package "LISP") . "L") (,(find-package "SYSTEM") . "S") (,(find-package "KEYWORD") . "K")))) (let ((tem (cdr (assoc x *package-names*)))) (cond (tem tem) (t (let((na (or (car (package-nicknames x)) (package-name x)))) (setq na (mangle (string-downcase na))) (if (rassoc na *package-names*) (error "You need to add another nickname: ~a is in use" na)) (setq na (copy-seq na)) (push (cons x na) *package-names*) na))))) (defun next-cvar (&optional v &aux name) (let ((n (incf *next-cvar*))) (cond ((null v) n) ((consp v) (setf (second v) n) v) ((typep v 'var) (cond ((var-special-p v) (setf (var-special-p v) n)) (t (setq name (var-name v)) (setf (var-ind v) (if (and name (symbol-package name)) (copy-seq (mangle-name name 'var)) n))))) (t (wfs-error))))) (defun next-label() (incf *next-label*)) (proclaim (cons 'special *pass-2-vars*)) (defun execute-pass-2 ( &aux (top *top-forms*) ) (let #.*pass-2-vars* (setq *next-data* 0 *next-label* 0 *next-function* 0 *address-vector* (make-array 30 :adjustable t :fill-pointer 0)) (terpri *c-output*) (wr " #include \"cmpinclude.h\" #include \"" (pathname-name *h-output*) ".h\"") (wr " init_code(){IdoInit(sizeof(VV)/sizeof(char *),VV);} ") (sloop for v in top do (do-one-pass-2 v)) (write-out-links) (write-out-address-and-data) (terpri *h-output*) (wr-nl "") ; (print *data*) )) (defun do-one-pass-2 (x &aux df *local-funs* fd) (cond ((consp x) (cond ((and (symbolp (car x)) (setq fd (get (car x) 'e2))) (funcall fd x)) (t (wfs-error)))) ((typep x 'top-form) (cond ((top-form-funp x) (setq df (add-dummy-fun (top-form-walked x)))) (t (push-data 'd_eval_skip (top-form-lisp x))))) (t (wfs-error))) (dolist (v *local-funs*) (do-one-pass-2 v)) (when df (push-data 'd_eval_skip `(si::invoke ,df)))) (proclaim '(ftype (function () t) dummy-top)) (defun add-dummy-fun (x &aux ans) ;; create a simple C function of no args which invokes the ;; lisp form x in compiled form. returns the integer index ;; of the *function-addresses* array where the C function's address resides. (setq ans`(lambda-block ,(make-fun-data 'dummy-top nil nil nil nil x nil))) (setf (fdata-ind (second ans)) (incf *next-function*)) (e2-write-top (make-top-form :walked ans :funp t)) (push-address (second ans)) ) (defun car-get (x flag) (and (consp x) (symbolp (car x)) (get (car x) flag))) (setf (get 'write-top 'e2) 'e2-write-top) (defun e2-write-top (x &aux fd) ;(print x) ; for (lambda #S(fdata ..)) ; sets the ind in #s(fdata ) and writes out the definition. ; writes out the L20() { ..} ; side .. (cond ((and (typep x 'top-form) (setq fd (car-get (top-form-walked x) 'e2))) (return-from e2-write-top (funcall fd (top-form-walked x))))) (unless (and (consp x) (symbolp (car x))) (wfs-error)) (cond ((setq fd (get (car x) 'e2)) (funcall fd x)) (t (wfs-error))) ) ;; writing out the .data file: ;; each time something in *data-table* is first referenced we assign ;; an index and put it in *data*. This normally happens while a function ;; definition (and its local functions) are being written out. After ;; that is written out (so all its constants are looked after) we push ;; the (d_eval_skip (fset argd function-address-index "docstring")) (setf (get 'si::fset 'e2) 'e2fset) (setf (get 'mset 'e2) 'e2fset) (defun push-address (x) (let ((n (fill-pointer *address-vector*))) (vector-push-extend x *address-vector*) n)) (defun link-descriptor-from-decl (argl ret &aux (atypes 0) saw-optional (min 0) (max 0) ) (declare (fixnum min max atypes)) (sloop for v in-list argl when (eq v '&optional) do (setq saw-optional t) else when (member v '#. (cons '* lambda-list-keywords)) do (setq max 63) (return nil) else do ; (if (eq v 'short-float) (setq v 'double-float)) (unless saw-optional (incf min)) (incf max) (cond ((< max 7) (setq atypes (+ atypes (the fixnum (ash (arg-type-code (promote-arg-type v)) (the fixnum (* max 2))))) )))) ;; set the return type: (setq atypes (logior atypes (arg-type-code (promote-arg-type ret)))) (let ((res 0)) (declare (fixnum res)) (setf res (make-argd min max atypes)) (or (eql max min) (setf (argd-flag-p res requires-nargs) t)) (when (or (eql ret '*)(and (consp ret)(eq (car ret) 'values))) (setf (argd-flag-p res sets-mv) t)) res)) (defun make-argd (min max atypes &aux (result 0)) (declare (fixnum min max atypes result)) (setf (argd-minargs result) min) (setf (argd-maxargs result) max) (setf (argd-atypes result) atypes) result) (defun describe-argd (argd) (format t "~%min=~a,max=~a,atypes=~a,arg-types=~a,ret=~a flags[set-mv=~a, requires-nargs=~a,requires-fun-passed=~a " (argd-minargs argd) (argd-maxargs argd) (argd-atypes argd) (argl-from-argd argd) (ret-from-argd argd) (argd-flag-p argd sets-mv) (argd-flag-p argd requires-nargs) (argd-flag-p argd requires-fun-passed))) ;(defstruct arg-stepper (atype 0 :type fixnum)) ;(defvar *arg-stepper* (make-arg-stepper)) ; ;(defun init-arg-stepper (argd) (setf (arg-stepper-atype *arg-stepper*) ; (argd-atypes (the fixnum argd))) ; nil) ; ;(defun next-arg-type () ; (let* ((a (arg-stepper-atype *arg-stepper*)) ; (res (aref *promoted-arg-types* (the fixnum (logand a 3))))) ; (setf a (ash a -2)) ; (setf (arg-stepper-atype *arg-stepper*) a) ; res)) (defun argl-from-argd (argd &aux ans) (declare (fixnum argd)) (let ((atypes (argd-atypes argd)) (min (argd-minargs argd)) (max (argd-maxargs argd)) (i 0)) (declare (fixnum atypes min max i)) (sloop while (<= i 7) do (setq atypes (ash atypes -2)) (cond ((and (>= i min) (eql atypes 0)) (if (< i max) (push '* ans)) (return nil)) ((eql i min) (push '&optional ans))) (push (aref *promoted-arg-types* (logand atypes 3)) ans) (setq i (+ i 1))) (or (eq (car ans) '*) (<= max 7) (push '* ans)) (nreverse ans))) (defun ret-from-argd (argd &aux ans) (declare (Fixnum argd)) (let ((tem (logand (argd-atypes argd) 3))) (declare (fixnum tem)) (setq ans (aref *promoted-arg-types* tem)) (cond ((argd-flag-p argd sets-mv) '*) (t ans)))) ) (defun fdata-to-argd(fdat &aux tem) (cond ((setq tem (fdata-function-declaration fdat)) (return-from fdata-to-argd (the fixnum(car tem))))) (let* ((ll (fdata-ll fdat)) (min (length (ll &required ll))) (max (+ min (length (ll &optional ll)))) (argd 0)) (declare (fixnum min max argd)) (cond ((or (ll &rest ll) (ll &key ll)) (setq max 63))) (setq argd (make-argd min max 0)) (setf (argd-flag-p argd requires-nargs ) (> max min)) (setf (argd-flag-p argd sets-mv) t) (setf (argd-flag-p argd requires-fun-passed)(fdata-closure-vars fdat)) argd)) (defun get-install-form (fdat sym &aux tem) (let ((argd (fdata-to-argd fdat)) (n (push-address fdat))) `(si::initfun ,sym ,n ,argd,@ (sloop for v in (fdata-closure-vars fdat) do (setq tem (cdr (assoc v *top-level-closure-vars*))) (or tem (setq tem (push-data 'dv (cons nil nil)))) collect tem)))) (defun e2fset (form &aux sym fun fdat tem sform) (desetq (sform sym fun) form) (or (typep fun 'top-form) (wfs-error)) (cond ((and (consp (setq tem (top-form-walked fun))) (consp (cdr tem)) (typep (setq fdat (cadr tem)) 'fdata)) (e2-write-top fun) (push-data 'd_eval_skip (ecase sform (si::fset (get-install-form fdat sym)) (mset (cons 'si::initmacro (cdr (get-install-form fdat sym)))))) ) (t (setf (third form) (top-form-lisp (third form))) (push-data 'd_eval_skip form)))) (setf (get 'local-function 'e2) 'e2-local-function) (defun e2-local-function (x ) (e2-write-top (second x)) ) #+later (defun multiple-value-p (ret-type) ;; return T if the ret-type is one for not a single value. (or (eq ret-type '*) (and (consp ret-type) (eq (car ret-type) 'values)))) (setf (get 'lambda-block 'e2) 'e2-lambda-block) (setf (get 'lambda 'e2) 'e2-lambda-block) (defvar *temp-cvars* ;; list of C Vars (ind type) which will be written out as the ;; TEMP_CVARSi macro at the beginning. ) (defvar *next-vcs* ;; size of block of c stack reserved for this function ;; declare by object Vcs[n]; ) (defvar *exit* ;; a CONS whose CAR ;; 'function-return' indicates return from function after set ;; 'next' control just continues ;; a label struct do a goto this lavel ;; Its CDR is a pointer into the control stack. The interval of the controlstack ;; between this pointer and the current *control-stack*, must be unwound before jumping ;; or setting a possibly special variable. ) (defvar *closure-vars* nil) (defvar *fdata* nil) (defvar *used-function-saved-avma* nil ;; is set to t if we need to ;; save the entering avma address. ) (defun e2-lambda-block (x &aux (*next-cvar* 0) (*blocks* 0) fdat *used-names* (*next-vcs* 0) (*next-label* 0) *temp-cvars* *closure-vars* freturn-type *control-stack* ;; in this pass *control-stack* contains info about ;; binding specials,saved-avma, tags so we know when ;; we jump if we need a setjmp, or if we need to unwind. ;; also for function-return. *alloc-decls* *fdata* *used-function-saved-avma* ) (declare (special *fdata*)) (setq fdat (second x)) (setq *fdata* fdat) (unless (fdata-ind fdat) (setf (fdata-ind fdat) (mangle-name (fdata-name fdat) 'function))) (setq *closure-vars* (fdata-closure-vars fdat)) (wr-comment "function definition: " (fdata-name fdat)) (wr" static " (rep-type (setq freturn-type (function-return-type fdat))) " " fdat"(") (wr-h "static " (rep-type freturn-type) fdat "() ;"); (write-args-and-open (fdata-ll fdat) (fdata-closure-vars fdat)) (if (eq freturn-type 'double_ptr)(setq freturn-type 'double-float)) (let* ((var (get-temp freturn-type)) (value `(,(if (eq freturn-type 'mv) 'mv 'var) ,var))) (valex value `(function-return ,var) (expr-b2 (fdata-form fdat)))) (close-blocks) (wr-h-temp-vars) ;; This var is shared elsewhere and we want new reference mechanism. (dolist (v *closure-vars*) (setf (var-ind v) nil)) (when (ll &key (fdata-ll fdat)) (let ((tem (push-address (list 'VK (fdata-ind fdat) )))) (push-data 'd_eval_skip `(si::set-key-struct ,tem)))) ) (defun wr-h-temp-vars( &aux type v) (let ((*c-output* *h-output*)) (wr " #define TEMP_VARS" *fdata*) (cond (*used-function-saved-avma* (wr " long FunctionEntryAvma = avma;"))) (dolist (w *temp-cvars*) (let ((t1 (or (second w) t))) (setq v (car w)) (cond ((eq type t1) (wr " ,V" v) ) (t (or (null type) (wr ";")) (setq type t1) (format *h-output* " ~a V~a" (rep-type type) v))) (cond ((eq type 'integer) (format *h-output* "= 0,V~aalloc" v) )) )) (and *temp-cvars* (format *h-output* ";")) (unless (eql *next-vcs* 0) (format *h-output* " object Vcs[~a];" *next-vcs*)) )) (defun open-block () (incf *blocks*) (wr-nl "{")) (defun close-blocks() (loop (if (<= *blocks* 0) (return nil)) (wr "}")(incf *blocks* -1))) (defun rep-type (type) (cond ((stringp type) (return-from rep-type type))) (case type ((character fixnum boolean) "int ") ((gen integer) "GEN ") (short-float "float ") (double-float "double ") (double_ptr "DoublePtr ") (otherwise "object "))) (defun bind-special (var val) (push 'bdsp *control-stack*) ; (incf *bdsp*) (or (var-ind var) (setf (var-ind var) (get-object (var-name var)))) (wr-nl "BdSp("(var-ind var)","(list 'inline-loc t val)");") ) (defun b2-bind-var (w v) (cond ((typep w 'var) (cond ((var-special-p w) (bind-special w v)) ((var-clb w) (wr-nl) (wr-vind (var-ind w)) (wr "=MakeClosVar(" v ");") (or (var-ind w) (wfs-error)) ) ((and (consp v) (eq (car v) 'var) (eql (second v) (var-ind w)))) (t (wr-set-inline-loc w v)))) ;; save writing V3=V3 ((and (consp w) (eq (car w) 'var)) (cond ((and (typep v 'var) (eql (second w) (var-ind v)))) (t (wr-set-inline-loc w v)))) (t (wfs-error) ;(wr-nl w "=" v ";") ))) (defun b2-bind-var-b2 (var val &aux tem) ;; like b2-bind-var-b2, but does a b2 eval on its second arg. (if (plain-var-p var) (setq tem var ) (setq tem (get-temp t))) (valex (list 'var tem) (next-exit) (expr-b2 val)) (or (eq tem var) (b2-bind-var var tem))) (defun assign-reqds-and-optionals (ll fdat &aux (atypes 0) var tem type (did-required nil) (lis (ll &required ll))) (declare (fixnum atypes)(boolean did-required)) (let ((fdecl (fdata-function-declaration fdat))) (cond (fdecl (setq atypes (argd-atypes(fdecl argd fdecl)))))) (tagbody again (sloop for v on lis with vtype do (setq var (if did-required (caar v) (car v))) (setq type (aref *promoted-arg-types* (logand (setq atypes (ash atypes -2)) 3))) (setq vtype (var-implementation-type var)) (cond ((or (eq type vtype) (eql (rep-type type) (rep-type vtype))) (setq tem var)) (t (setq tem nil) (cond ((plain-var-p var) (next-cvar var) (push var *alloc-decls*))))) (setf (car v) (cons (list 'var (next-cvar tem) type) (car v)))) (unless did-required (setq did-required t) (setq lis (ll &optional ll)) (go again)) )) ;; if not nil try to allocate all rest args on the c stack. (defun wr-decl-var (var) (cond ((typep var 'var) (if (var-volatile var) (wr "VOL ")) (let ((type (var-type var))) (cond ((eq type 'integer) (wr "IDECL("var","var"__space,"var"__alloc);")) (t (wr (rep-type type) " ") (wr-vind (var-ind var))(wr ";"))))) ((and (consp var) (eq (car var) 'var)) (wr (if (third var) (rep-type (third var)) "object ") var ";")) (t (wfs-error)))) (defvar *rest-on-stack* nil) (defvar *alloc-decls* nil) (defun write-args-and-open(ll closure-vars &aux reqds varargp va-start labels deflt rest-var (fdat *fdata*) tem (cfun (fdata-ind fdat))) (assign-reqds-and-optionals ll fdat) (setq reqds (ll &required ll)) (wr-list (mapcar 'car reqds)) (cond ((vararg-p fdat)(setq varargp t) (if reqds (wr ",")) (wr "va_alist) ")) (t (wr ") "))) (sloop for v in reqds do (wr-decl-var (car v))) (cond (varargp (wr "va_dcl "))) (incf *blocks*) (wr " { TEMP_VARS" fdat" ") (sloop for v in *alloc-decls* do (wr-decl-var v)) (setq *alloc-decls* nil) ;; we must actually have the pointers in our function point to the closure cells. ;; Otherwise if noone keeps a pointer to the closure itself during the call, ;; the closure might be gc'd and the variables themselves be unprotected. (when closure-vars (dolist (v closure-vars) (allocate-var v 'kw)) (wr "VOL object CLfun;") (wr-nl "struct { ") (write-alloc-decls (rep-type t)) ;; the *& is to make sure this goes into the Cstack. (wr "} *CLvars = (void *) (*&CLfun = fcall.fun, CLfun->cl.Env);")) (cond (varargp (wr-nl "int Inargs = VFUN_NARGS - " (length reqds)";va_list Iap;") (dolist (v (ll &optional ll)) (wr-decl-var (car v)) (allocate-var (cadddr v) t)) (write-alloc-decls (rep-type t)) (when (ll &rest ll) (setq rest-var (caar (ll &rest ll))) (allocate-var rest-var t)) (write-alloc-decls (rep-type t)) ;; Todo : Use a structure to get named args: ;; struct { object V1,V2,...V10;} Vk; ;; Refer Kw.V2 (when (ll &key ll) (wr-nl " struct {") (dolist (v (ll &key ll)) (allocate-var (car v) 'kw)) (write-alloc-decls (rep-type t)) (dolist (v (ll &key ll)) (allocate-var (caddr v) 'kw)) (wr-nl"") (write-alloc-decls (rep-type t)) (wr "} Vk;")) )) (cond ((and (setq tem (fdata-tail-label fdat))(label-referred tem)) (wr "LA" tem ":;") (push tem *control-stack*) )) (sloop for v in reqds do (b2-bind-var (cdr v) (car v))) (when varargp (wr-nl "Inargs = VFUN_NARGS - " (length reqds) " ; ") (when (ll &optional ll) (let (*control-stack*) ;; don't double BDSP. These will be added below (dolist (opt (ll &optional ll)) (push (next-label) labels) (wr-nl "if( --Inargs < 0)") (wr-go (car labels)) (wr-nl "else {") (unless va-start (setq va-start t) (wr-nl "va_start(Iap);")) (b2-bind-var (car opt) (list 'next-var-arg)) (b2-bind-var (cadr opt) (car opt)) (wr "}") (when (cadddr opt) (b2-bind-var (cadddr opt) (get-object t))) )) (setq labels (nreverse labels)) (let ((label (next-label))) (wr-go label) ;;; Bind unspecified optional parameters. (dolist-safe (opt (ll &optional ll)) (wr-label (car labels)) (pop labels) (b2-bind-var-b2 (car opt) (caddr opt)) (b2-bind-var (cadr opt) (car opt)) (when (cadddr opt) (b2-bind-var (cadddr opt) (get-object nil)))) (wr-label label) )) ;; bind &rest arg (when rest-var (let ((dynamic-extent (or *rest-on-stack* (eq 'dynamic-extent (var-type rest-var)))) (temp (get-temp t))) (unless va-start (setq va-start t) (wr-nl "va_start(Iap);")) (wr-nl temp "=" ) (cond ((ll &key ll) (cond (*rest-on-stack* (wr "(ALLOCA_CONS(Inargs),ON_STACK_MAKE_LIST(Inargs));")) (t (wr "make_list(Inargs);")))) (dynamic-extent (wr "(ALLOCA_CONS(Inargs),ON_STACK_LIST_VECTOR(Inargs,Iap));")) (t (wr "list_vector(Inargs,Iap);"))) (b2-bind-var rest-var temp))) ;; bind keywords (when (ll &key ll) (unless va-start (setq va-start t) (wr-nl "va_start(Iap);")) (setq deflt (mapcar 'cadr (ll &key ll))) (let ((vkdefaults nil) (n (length (ll &key ll)))) (do* ((v deflt (cdr v)) (kwds (ll &key ll) (cdr kwds)) (kwd (car kwds) (car kwds))) ((null v)) (unless (and (dv-p (car v)) (eq (third (car v)) nil)) (setq vkdefaults t)) (when (or (not (and (dv-p (car v)) (progn (add-data (car v))))) ;; the supplied-p variable is not there (not (null (third kwd))) ) (setf Vkdefaults t) (setf (car v) 0))) (if (> (length deflt) 15) (setq vkdefaults t)) (open-block) (let ((*c-output* *h-output*)) (when vkdefaults (terpri *h-output*) (wr "static int VK" cfun "defaults[" (length deflt) "]={") (do ((v deflt(cdr v))(tem)) ((null v)) (cond ((eql (car v) 0) (wr "-1")) ;; must be location ((and (eq (caar v) 'dv) (eq (setq tem (third (car v))) nil)) (wr "-2")) ;; fix these two to allow fixnum constants. ((eq (caar v) 'dv) (wr (get-dv-index (car v)))) (t (wfs-error))) (if (cdr v) (wr ","))) (wr "};")) (terpri *h-output*) (wr "static struct { short n,allow_other_keys;" "int *defaults;") (wr-nl " int keys[" n "];") (wr "} VK" cfun "key=") (wr "{" (length (ll &key ll)) "," (if (ll &allow-other-keys ll) 1 0) ",") (if vkdefaults (wr "VK" cfun "defaults") (wr "(int *)Cstd_key_defaults")) (when (ll &key ll) (wr ",{") (do ((v (reverse (ll &key ll)) (cdr v))) ((null v)) ;; We write this list backwards for convenience ;; in stepping through it in parse_key (wr (second (add-data (fourth (car v)) ))) (if (cdr v) (wr ","))) (wr "}")) (wr "};") ) (cond (rest-var (wr-nl "parse_key_rest(" rest-var ",")) (t (wr-nl "parse_key_new("))) (wr "Inargs,&Vk,&VK" cfun "key,Iap);") ) ;; end setup keys ;; bind the keys (dolist (kwd (ll &key ll)) (cond ((not (eql 0 (pop deflt))) ;; keyword default bound by parse_key.. and no supplied-p (b2-bind (car kwd))) (t (wr-nl "if(" `(key-var ,(car kwd)) "==0){") (b2-bind-var-b2 (car kwd) (cadr kwd)) (unless (null (caddr kwd)) (b2-bind-var (caddr kwd) (get-object nil))) (wr-nl "}else{") (let (*control-stack*) ;; don't do extr BdSP (b2-bind (car kwd)) (and (caddr kwd) (b2-bind-var (caddr kwd) (get-object t)))) (wr "}")))))) )) (defun b2-bind (w) (cond ((var-special-p w) (b2-bind-var w (var-special-p w))) ((var-clb w) (or (consp (var-ind w)) (wfs-error)) (b2-bind-var w (list 'closure-var-loc w))) (t nil))) (setf (get 'var 'b2) 'b2-var) (setf (get 'dv 'b2) 'b2-dv) (defun b2-dv (x ) (unless (cadr x) (add-data x)) (unwind-set x)) (defun b2-var (v) ;; what about the strategy of having everything except var's ;; eval'd into a temp var. (unwind-set v) v) (defun needs-temp (val sofar rest &aux tem) ;; VAL is the result of a expr-b2 ? '(1val) and SOFAR is the list of ;; results sofar and REST is the list of future arguments to expr-b2. ;; We must create a temp variable and assign it to val if any evaluation ;; of the things in rest or sofar might alter the value in VAL. (and (null sofar) (null rest) (return-from needs-temp nil)) ;; if sofar is only vars and rest is null ;; also would be ok. (cond ((consp val) (cond ((eq (car val) 'var) (return-from needs-temp nil)) ((eq (car val) 'dv) (if (or (numberp (third val)) (keywordp (third val))) (return-from needs-temp nil))) ((eq (car val) 'call) ;; symbol-function does not have side-effect, but ;; we need to preeval both to make sure order is write. ;; (foo (symbol-function 'bil) (deff 'bil)) (cond ((not (side-effect-p val)) (return-from needs-temp nil)))))) ((typep val 'var) (or (null (var-special-p val)) (wfs-error)) (cond ((and (null (var-clb val))) (return-from needs-temp nil))))) (setq tem (get-temp (result-type val))) (wr-nl tem "=" val ";") tem) (defun sets-mv-p (loc) (cond ((atom loc) nil) ((eq (car loc) 'inline-loc) (sets-mv-p (third loc))) ((eq (car loc) 'inline-call) (flag-p (opt flag (cddr loc)) mv)) (t nil))) (defun unwind-avma (ctl-stack) (sloop for v on *control-stack* do (cond ((eq v ctl-stack)(return nil)) ((eq (car v) 'avma-bind-needed) (cond ((member 'inner-avma (cdr v)) (wr-nl "avma = InnerAvma;")) (t (wr-nl "avma = FunctionEntryAvma;") (setq *used-function-saved-avma* t))))))) (defun unwind-stack (ctl-stack) ;; Does the unbinding of special variables, popping the CtlStack, ;; Cases here must also appear in unwind-stack-p (sloop for v on *control-stack* until (eq v ctl-stack) do (case (car v) (bdsp (wr-nl "UnBdSp;")) (ctl-push (wr-nl "CtlPop;")) (t (cond ((consp (car v)) (case (caar v) (progv-bind (wr-nl "IunwindBdSp(" (cadar v) ");")) (unwind-protect (wr-nl "CtlPop;IcallUnwindFun(" (cadar v) ");")) ))))))) (defun unwind-stack-p (ctl-stack) (sloop for v on *control-stack* until (eq v ctl-stack) when (or (eq (car v) 'bdsp) (eq (car v) 'ctl-push) (and (consp (car v)) (or (eq (caar v) 'progv-bind) (eq (caar v) 'unwind-protect)))) do (return t))) (defun restore-function-avma () (wr-nl "avma = EntryAvma;") (setq *used-function-saved-avma* t)) (defun unwind-set (val &optional avma-bind) (cond ((and (typep val 'var) (var-special-p val) (cdr *value*) (unwind-stack-p (cdr *exit*))) (setq val (replace-inline-by-temp val)))) (cond ((second *value*) (unwind-stack (cdr *exit*)) (wr-set-inline-loc (second *value*) val)) ((and (consp val) (eq (car val) 'inline-call)) (let ((flag (opt flag (cddr val)))) (cond ((flag-p flag set) (wr-nl val ";"))) (unwind-stack (cdr *exit*)))) (t (unwind-stack (cdr *exit*)))) (cond ((and (eq (car *value*) 'mv) ;; *MV-N-VALUES-SET* bound to t by values special form (null *MV-N-VALUES-SET*) (not (sets-mv-p val))) ;; detect if val does a set of MV ;; if not then we must (wr "fcall.nvalues = 1;"))) (case (car *exit*) (function-return (or (eq (second *exit*) (second *value*)) (wfs-error)) ;; must make sure CLfun and so its closure vars are not gc'd. The ;; usage *&CLfun may mean this touch can be empty, since I think ANSI (unwind-avma nil) (if *closure-vars* (wr "TOUCH_CLfun;")) (let ((val (second *value*))) (or (eq (car val) 'var) (wfs-error)) (cond ((eq (third val) 'double-float) (wr-nl "RETURN_DOUBLE_PTR(" val ");")) (t (wr-nl "return " val ";"))))) (next (if avma-bind (unwind-avma (cdr *exit*)))) (otherwise (cond ((typep (car *exit*) 'label) (unwind-avma (cdr *exit*)) (wr-go (car *exit*))) (t (wfs-error))))) ;; remove the avma-bind which has just been used. (if avma-bind (remove-avma-bind avma-bind)) ) (defun remove-avma-bind (avma-bind) (cond ((eq *control-stack* avma-bind) (setq *control-stack* (cdr avma-bind))) ((eq (cddr *control-stack*) (cdr avma-bind)) (setq *control-stack* (cons (car *control-stack*) (cdr avma-bind)))) (t (wfs-error)))) (setf (get 'progn 'b2) 'b2-progn) (defun b2-progn (x) (progn-b2 (third x))) (defun progn-b2 (body) (sloop for v on body do (if (cdr v) (valex '(ignore) (next-exit) (expr-b2 (car v))) (expr-b2 (car v)))) (or body (expr-b2 (get-object nil)))) (defun get-temp (type) (cond ((eq type 'integer) (setq type 'gen))) (let ((tem (list 'var (next-cvar) type))) (push (cdr tem) *temp-cvars*) tem)) (defun push-vcs () (prog1 (list 'vcs *next-vcs*) (incf *next-vcs*))) (defun write-alloc-decls(str) (when *alloc-decls* (wr str) (wr-list (nreverse *alloc-decls*)) (wr ";") (setq *alloc-decls* nil))) (defun allocate-var (v type) (cond ((if (null v) (push `(var ,(next-cvar)) *alloc-decls*)) (return-from allocate-var nil)) ((typep v 'var) (cond ((eq type 'kw) (let ((ind (next-cvar v))) (push (list 'var ind) *alloc-decls*) (cond ((var-special-p v) (setf (var-special-p v) `(var (kw ,ind)))) (t (setf (var-ind v) (list 'kw ind)))))) ((var-special-p v)) (t (next-cvar v) (push (list 'var (var-ind v)) *alloc-decls*)))))) (defun plain-var-p (x) (and (typep x 'var) (not (var-special-p x)) (not (var-clb x)))) (setf (get 'let 'b2) 'b2-let) (setf (get 'let* 'b2) 'b2-let) (defvar *last* nil) (defun next-exit () ;; a hack to avoid some consing. (cond ((and *last* (eq (cdr *last*) *control-stack*)) *last*) (t (setq *last* (cons 'next *control-stack*))))) (defun b2-let (x &aux (*control-stack* *control-stack*) (*blocks* 0) binds body (*used-names* *used-names*) todo ) (desetq (binds body) (cddr x)) (open-block) (sloop for (var) in binds when (not (var-special-p var)) do (next-cvar var) (wr-decl-var var)) (sloop for (var val) in binds do (cond ((plain-var-p var) (valex (list 'var var) (next-exit) (expr-b2 val))) (t (let ((tem (get-temp t))) (valex (list 'var tem) (next-exit) (expr-b2 val)) (if (eql (car x) 'let) (push (cons var tem) todo) (b2-bind-var var tem)))))) (sloop for (var . val) in (nreverse todo) do (b2-bind-var var val)) (progn-b2 body) (close-blocks) nil) (defun safe-system (x) (unless (eql 0 (system x)) (error "The command ~s failed" x))) (defun compile-and-add-data-file ( o-file &aux command dir) (declare (special c-debug)) (force-output *c-output*) (force-output *data-output*) (force-output *h-output*) (if (eql *c-output* *standard-output*) (return-from compile-and-add-data-file nil)) (setq dir (namestring (make-pathname :directory (or (pathname-directory *c-output*) '(:current))))) (setq command (format nil "(cd ~a ; ~a -c -I. -I/u/wfs/new-lisp/newh ~a ~a ~a )" dir compiler::*cc* (namestring *c-output*) (if c-debug "-g" "") (if (> *speed* 0) "-O" "") )) (cond (o-file (safe-system command) (with-open-file (st (get-output-pathname "o") :direction :output :if-exists :append) (setq o-file (truename st)) (sloop for v in-array "" do (write-char v st)) (write-char #\N st)) (system (format nil "cat ~a >> ~a" (namestring *data-output*) (namestring o-file))))) ) (defun disassemble1 (name) (with-open-file (st "/tmp/wfs1.lsp" :direction :output) (print `(in-package ,(package-name *package*))) (let ((def (symbol-function name))) (cond ((and (consp def) (eq (car def) 'lambda-block)) (print `(defun ,name ,@ (cddr def)) st)) (t (return-from disassemble1 'cant)))) (force-output st) (compile-file1 (pathname st) :c-file *standard-output*))) gcl/comp/try.lsp000077500000000000000000000013501242227143400141220ustar00rootroot00000000000000(in-package "BCOMP" :use '("SLOOP" "LISP")) (setq *print-pretty* t) (defun compiler::boole3 (a b c) (boole a b c)) (setq compiler::*cc* (concatenate 'string compiler::*cc* " -I../newh -I../h")) (let ((*load-verbose* nil)) (dolist (v '( data defs macros var c-pass1 fasdmacros lambda top top1 inline top2 stmt wr bo1 exit defmacro utils comptype )) (si::nload (format nil "~(~a~).lsp" v))) (load "opts-base.lsp") (let ((u "top2.o")) (unless (get 'list 'bcomp-opt) (if (probe-file u) (load u)) (load "lisp-decls.doc") (load "opts.lsp") (if (probe-file U ) (si::nload "top2.lsp")) )) (or (fboundp 'do-some-tests) (load "../tests/all-tests.lsp")) (load "mangle") ) gcl/comp/try1.lsp000077500000000000000000000002451242227143400142050ustar00rootroot00000000000000(setq *load-verbose* nil) (defun compiler::boole3 (a b c) (boole a b c)) (load "sysdef.lsp") (make::make :bcomp) (load "smash-oldcmp.lsp") (setq *load-verbose* t) gcl/comp/utils.lsp000077500000000000000000000113431242227143400144470ustar00rootroot00000000000000 (in-package "BCOMP") (defmacro fdecl (key fd) `(nth ,(position key '(argd flag)) ,fd)) (defun comp-warn (fmt &rest l &aux (*print-length* 3) (*print-level* 3)) (if *top-form* (format t ";~%~s is being compiled" *top-form*)) (setq *top-form* nil) (format t ";;~%Warning:") (apply 'format t fmt l)) (defun comp-error (fmt &rest l &aux (*print-length* 3) (*print-level* 3)) (setq *hard-error* t) (format t "~%Error:") (apply 'format t fmt l)) (defun add-prop (symbol-lis prop val) (dolist-safe (v symbol-lis) (or (symbolp v) (comp-error "Can't add ~a prop ~a to non symbol ~a" val prop v)) (setf (get v prop) val))) (defun bad-proclamation () (declare (special *procl*)) (comp-error "The proclamation ~a was illegal." *procl*)) (defun proclaim1 (x &aux ptype body (*procl* x) flag val tem) (declare (special *space* *speed*)) ;; will eventually be proclaim. (declare (special *procl*)) (desetq (ptype . body) x) (case ptype (optimize (sloop for v in-list body do (cond ((atom v) (setq flag v val 3)) (t (desetq (flag val) v))) (or (typep val 'fixnum) (bad-proclamation)) (case flag (safety (if (> (the fixnum val) 0) (setq *safety* val))) (space (setq *space* val)) (speed (setq *speed* val)) (compilation-speed (setq *speed* 0)) (t (comp-warn "Unknown optimize quality ~a" flag))))) (special (dolist-safe (v body) (si::*make-special v))) (type (desetq (ptype . body) body) (setq ptype (comp-type ptype)) (add-prop body 'proclaimed-variable-type ptype)) (function (let (name ) (desetq (name . body) body) (proclaim1 `(ftype (function ,@ body) ,name)))) (ftype (desetq (ptype . body) body) (add-prop body 'proclaimed-function-declaration (increment-function-decl ptype nil))) (inline (add-prop body 'proclaimed-inline t)) (declaration (add-prop body 'proclaimed-declaration t)) (t (cond ((symbolp ptype) (cond ((setq tem (get ptype 'comp-type)) (add-prop body 'proclaimed-variable-type (comp-type ptype))) ((get ptype 'proclaimed-declaration)) (t (bad-proclamation)))) (t (bad-proclamation)))))) (defun ftype-from-fdecl (fdecl &aux (n (fdecl argd fdecl))) ;; (setq fdecl (get fname 'proclaimed-fun57qction-declaration)) (when n (let ((args (argl-from-argd n)) (ret (ret-from-argd n))) `(ftype (function ,args ,ret))))) (defun describe-fdecl(fdecl) (format t "Ftype is ~s, flags are " (ftype-from-fdecl fdecl)) (print-flag (fdecl flag fdecl))) (defun promote-arg-type (x) (setq x (comp-type x)) (case x (fixnum 'fixnum) ((t) t) ; (short-float 'short-float) ((long-float double-float ) 'double_ptr) (t (cond ((subtypep x 'fixnum) 'fixnum) (t t))))) (defvar *promoted-arg-types* #( t fixnum double_ptr ;short-float )) (defun arg-type-code (x) (cond ((eq x t) 0) ((eq x 'fixnum) 1) ((eq x 'double_ptr) 2) ; ((eq x 'short-float) 3) (t (wfs-error) 0))) (defun increment-function-decl (new-prop old-decl &aux tem args ret-types retl) ;; produce a new function-decl with prop added. (setq old-decl (list 0 (if old-decl (second old-decl) #.(flags set ans mv touch-mv) ))) (cond ((atom new-prop) (case new-prop (inline (setf (flag-p (fdecl flag old-decl) notinline) nil)) (notinline (setf (flag-p (fdecl flag old-decl) notinline) t)) (t (wfs-error))) old-decl) ((eq (car new-prop) 'function) (desetq (args . ret-types) (cdr new-prop)) (tagbody again (cond ((null ret-types) (setq retl '*)) ((atom ret-types) (comp-error "Bad return decl ~a" retl)) ((cdr ret-types) (setq retl '*)) ((eq (setq tem (car ret-types)) '*)(setq retl '*)) ((and (consp tem) (eq (car tem) 'values)) (setq ret-types (cdr tem)) (go again)) (t (setq retl (comp-type tem))))) (setf (car old-decl) (link-descriptor-from-decl args retl)) (cond ((not (eq retl '*)) (setf (flag-p (second old-decl) mv) nil))) old-decl) (t (wfs-error)))) (defun function-declaration (v) (or (symbolp v) (wfs-error)) (or (cdr (assoc v *function-decls*)) (get v 'proclaimed-function-declaration))) (defun function-return-type (fdat &aux ret fdecl) ;; returns (member *immediate-types*), T, or MV ;; (member *immediate-types*), T, *, (values t t) (values) .. (let ((fname (fdata-name fdat))) (cond ((and fname (setq fdecl (get fname 'proclaimed-function-declaration))) (setf (fdata-function-declaration fdat) fdecl) (setq ret (ret-from-argd (fdecl argd fdecl))) (cond ((eq ret '*) 'mv) (t ret))) (t 'mv)))) (defun the-list (x &aux (y x)) (sloop while x do (or (consp x) (comp-error "not a list ~a" x)) (setq x (cdr x))) y) gcl/comp/var.lsp000077500000000000000000001060451242227143400141030ustar00rootroot00000000000000;;Copyright William F. Schelter 1990, All Rights Reserved (in-package "BCOMP") (use-package "SLOOP") (setq SYSTEM:*INHIBIT-MACRO-SPECIAL* nil) ;(fmakunbound 'multiple-value-list) (defvar *default-desk* (make-desk t)) (defun get-desk (type) (if (eq type t) *default-desk* (make-desk type))) (defun set-desk-type (desk new-type) (cond ((eq desk *default-desk*) (make-desk new-type)) (t (setf (desk-result-type desk) (type-and (desk-result-type desk) new-type)) desk))) (setq SYSTEM:*INHIBIT-MACRO-SPECIAL* t) (do ((v '(QUOTE b1-quote MACROLET b1-macrolet symbol-macrolet b1-symbol-macrolet MULTIPLE-VALUE-PROG1 b1-MULTIPLE-VALUE-PROG1 UNWIND-PROTECT b1-unwind-protect EVAL-WHEN b1-quote-first LET b1-let RETURN-FROM b1-return-from MULTIPLE-VALUE-LIST b1-eval IF b1-if THE b1-the PROGV b1-progv FUNCTION b1-function FLET b1-flet COMPILER-LET b1-compiler-let DECLARE b1-declare TAGBODY b1-tagbody LABELS b1-flet PROGN b1-progn LET* b1-let* CATCH b1-catch THROW b1-throw BLOCK b1-block GO b1-go SETQ b1-setq VALUES b1-values LAMBDA-BLOCK b1-lambda-block DONE-b1 b1-done-b1 #+c-pass1 MULTIPLE-VALUE-BIND b1-multiple-value-bind #+c-pass1 MULTIPLE-VALUE-setq b1-multiple-value-setq ) (cddr v))) ((null v)) (setf (get (car v) 'b1) (second v))) (defmacro locally (&body body) `(let nil ,@body)) (defvar *control-stack* ;; When a special is bound 'bound-special is pushed ;; When clb lambda is entered 'clb is pushed ;; When save_avma is entered 'save-avma is pushed ;; Thus go can tell whether the tag is acros 'clb or ;; or else how many bds-unbinds it has to do before going. nil) (defvar *walk-functions* ;; bindings of functions and macros by flet,macrolet,labels nil) (defvar *walk-variable-bindings* ;; bindings of variables by let,lambda, let*, symbol-macrolet. ;; nil) (defvar *digest-line-info* (make-hash-table :test 'eq)) (defvar *line-info* nil) (defun walk-environment () (list nil *walk-functions*)) (defun mapcar2 (f lis c &optional last) (or last (setq last c)) (do ((v lis (cdr v)) (result) (ptr)) ((null v) result) (or (consp v) (comp-error "Expected a list of forms ~a" lis)) (let ((tem (funcall (the (function (t t) t) f) (car v) (if (cdr v) c last)))) (cond (ptr (setf (cdr ptr) (list tem)) (setf ptr (cdr ptr))) (t (setq result (setq ptr (list tem)))))))) (eval-when (compile eval load) (defun desetq-consp-check (val) (or (consp val) (error "~a is not a cons" val))) (defun desetq1 (form val) (cond ((symbolp form) (cond (form ;(push form *desetq-binds*) `(setf ,form ,val)))) ((consp form) `(progn (desetq-consp-check ,val) ,(desetq1 (car form) `(car ,val)) ,@ (if (consp (cdr form)) (list(desetq1 (cdr form) `(cdr ,val))) (and (cdr form) `((setf ,(cdr form) (cdr ,val))))))) (t (error "")))) ) (defmacro desetq (form val) (cond ((atom val) (desetq1 form val)) (t (let ((value (gensym))) `(let ((,value ,val)) , (desetq1 form value)))))) (defun b1-quote-two (form where &aux sform a b c) where (desetq (sform a b . c) form) (list* sform a b (mapcar2 'b1-walk c sform))) (eval-when (compile eval load) (defun wbind1 (v decls &aux var specialp tem) (or (symbolp v) (comp-error "binding non symbol ~a")) (if (null v) (comp-error "binding nil ~a")) (sloop for w on-list (second decls) when (eq (car w) v) do (setq specialp t)(setf (car w) nil)) (if (si::specialp v) (setq specialp t)) (setq var (makevar v specialp)) (if specialp (push 'bound-special *control-stack*)) (push var *walk-variable-bindings*) (cond ((setq tem (assoc v (car decls))) (setf (var-type var) (cdr tem)))) var ) (defmacro wbind (v decls) `(setf ,v (wbind1 ,v ,decls))) (defun makevar (var specialp) (or (symbolp var) (error "not a symbol ~a" var)) (let ((v (make-var :name var))) (when specialp (setf (var-special-p v) t) (setf (var-ind v) (get-object var))) (setf (var-type v) (or (get var 'proclaimed-variable-type) t)) v)) (defun canon-opt-arg (v type &aux var val supplied-p keyword (intern (eql type '&key))) ;; (list var val supplied-p keyword) (tagbody (if intern (setq keyword v)) (cond ((atom v) (or (symbolp v) (go error)) (setq var v)) (t (cond ((consp (car v)) (or intern (go error)) (setq intern nil) (desetq (keyword var) (car v))) (t (setq keyword (car v) var (car v)))) (or (consp (cdr v)) (go error)) (setq val (cadr v)) (if (consp (cddr v)) (setq supplied-p (caddr v))))) (or (symbolp keyword) (go error)) (or (symbolp var ) (go error)) (or (null intern) (setq keyword (intern (symbol-name keyword) 'keyword))) (return-from canon-opt-arg (list var val supplied-p keyword)) error (comp-error "bad ~a arg ~s" type v))) ;;lambda-list-keywords has value: ;; '(&optional &rest &key &allow-other-keys &aux &whole &environment &body) (defun decode-ll (list) (let (ll sections) (do ((v list (cdr v)) (this (list '&required))) ((null v) (push (nreverse this) sections) (setq sections (nreverse sections ))) (cond ((member (car v) lambda-list-keywords) (push (nreverse this) sections) (setq this (list (car v)))) (t (push (if (consp (car v)) (car v) (if sections (list (car v) nil) (car v))) this)))) (do ((v (cons '&required lambda-list-keywords) (cdr v)) tem) ((eq (car v) '&whole) (or (null sections) (error "unrecognized or duplicate '&' keyword in lambda-list ~a" sections))) (cond ((setq tem (assoc (car v) sections)) (or (eq (car sections) tem) (error "~a in incorrect position" (car v))) (setf sections (cdr sections)))) (push tem ll) ) (setq ll (nreverse ll)) (dolist (v (ll &required ll)) (unless (symbolp v) (error "required arg not a symbol ~a" v))) (if (ll &allow-other-keys ll) (setf (cdr (ll &allow-other-keys ll)) t)) (setf (ll &key ll) (sloop for v in-list (ll &key ll) collect (canon-opt-arg v '&key))) (setf (ll &optional ll) (sloop for v in-list (ll &optional ll) collect (canon-opt-arg v '&optional))) (setf ll (mapcar 'cdr ll)))) (defun lambda-bind-b1 (decoded clb decls) (let ((*walk-variable-bindings* *walk-variable-bindings*) (*control-stack* *control-stack*)) (if clb (push 'clb *walk-variable-bindings*)) (flet ((fbind1 ( l decls &aux v) (sloop for w on l do (cond ((atom (car w)) (wbind (car w) decls)) (t (setq v (car w)) ; v = (list var val supplied-p keyword) (setf (nth 1 v) (b1-walk (nth 1 v) 'bind)) (wbind (nth 0 v) decls) (setq v (cddr v)) (if (car v) (wbind (car v) decls)) (setq v (cdr v)) (if (car v) (setf (car v) (get-object (car v))))))))) (fbind1 (ll &required decoded) decls) (fbind1 (ll &optional decoded) decls) (if (ll &rest decoded) (wbind (caar (ll &rest decoded)) decls)) (fbind1 (ll &key decoded) decls)) (add-remaining-special-decls decls) *walk-variable-bindings*)) ;;end eval-when ) (defvar *contains-function* ;; set if the form contains a lambda expression. ) (defvar *setjmps* ;; the number of setjmps encountered so far. ;; tagbody with clb tags, unwind-protect, catch all lay down setjmps. ) (defun bound-variables-volatile () (dolist (v *walk-variable-bindings*) (cond ((eql v 'clb) (return nil)) ((typep v 'var) (setf (var-volatile v) t))))) (defun check-used (binds pos &aux w) (dolist (v binds) (cond ((consp v) (setq w (nth pos v)) (if (typep w 'var) (or (var-special-p w) (var-changed w ) (var-ref w ) (comp-warn "Variable ~s was not used" (var-name w)))))))) (defun add-remaining-special-decls (decls) (sloop for v in (second decls) when v do (push (list v 'special (makevar v t)) *walk-variable-bindings*))) (defun b1-lambda-block (form where &optional (clb 'clb) &aux sform name closure-record result decls doc (*control-stack* (cons clb *control-stack*)) (*function-decls* *function-decls*) (tail-label (make-label :identifier '#.(gensym "tail"))) ll bod decoded) where (desetq (sform) form) (setq form (cdr form)) ;; set (setq *contains-function* t) (cond ((eq sform 'lambda-block) (desetq (name) form) (setq form (cdr form)))) (desetq (ll . bod) form) (setq decoded (decode-ll ll)) (desetq (decls bod doc) (grab-declares bod t)) (cond ((and (null name) (consp bod) (consp (car bod)) (eq (caar bod) 'block)) (desetq (name) (cdar bod))) ((and (symbolp name) (eq sform 'lambda-block)) (setq bod `((block ,name ,. bod))))) (when clb (dolist (v *walk-variable-bindings*) (and (typep v 'var) (var-clb v) (push (cons v (var-clb v)) closure-record)))) (let* ((*control-stack* *control-stack*) (*walk-variable-bindings* (lambda-bind-b1 decoded clb decls)) (tail-recursion (and (not (ll &optional decoded)) (eq sform 'lambda) (not (ll &key decoded)) (not (ll &rest decoded)) (list 'lambda-block name (ll &required decoded) tail-label)))) (push tail-label *control-stack*) (setq result (b1-walk `(let* ,(ll &aux decoded) ,@ (get-back-some-decls decls (mapcar 'car (ll &aux decoded))) ,@ bod) tail-recursion)) (check-used *walk-variable-bindings* 1)) (if (ll &aux decoded) (setf ll (butlast ll (length (member '&aux ll))))) `(,sform , (make-fun-data name closure-record clb decoded doc result tail-label ) ))) (defun make-fun-data (name closure-record clb ll doc form tail-label &aux tem result) (setq result (make-fdata :name name :ll ll :doc doc)) (setf (fdata-form result) form) (setf (fdata-tail-label result) tail-label) (when clb (dolist (v *walk-variable-bindings*) (cond ((and (typep v 'var) (setq tem (var-clb v))) (if (> tem (or (cdr (assoc v closure-record)) 0)) (push v (fdata-closure-vars result))))))) result) (defun declare-volatile (binds) (dolist (v binds) (or (and (consp v) (typep (car v) 'var) (wfs-error))) (setf (var-volatile (car v)) t))) (defun find-bind (var &optional (set-clb t) &aux clb) (cond ((and (consp var) (eq (car var) 'done-b1)) (setq var (cdr var)))) (dolist (v *walk-variable-bindings*) (cond ((var-p v) (when (or (eq var (var-name v)) (eq var v)) (cond ((and clb set-clb (not (var-special-p v))) (setf (var-clb v) (+ 1 (the fixnum (or (var-clb v) 0)))))) (return-from find-bind v))) ((eq 'clb v) (setq clb t)) ((consp v) (cond ((eq (car v) var) (case (second v) (special (return-from find-bind (third v))) (symbol-macro (return-from find-bind (cdr v))) (otherwise (wfs-error)))))) (t (wfs-error)))) (or (si::specialp var) (keywordp var) (comp-warn "~a is an unknown variable. Assuming it is special." var)) (let ((tem (makevar var t))) (push (list var 'special tem) *walk-variable-bindings*) tem)) (defun b1-macro-function (name) (let ((tem (assoc name *walk-functions*))) (cond (tem (if (eq 'macro (cadr tem)) (third tem) nil)) (t (macro-function name))))) (eval-when (compile) (proclaim '(function expand-fun (t) t))) (defun expand-fun (form &aux f) (unless (and (consp form) (eq (car form) 'lambda-block)) (return-from expand-fun form)) (setq f (second form)) (let* ((line-info (get f 'line-info)) (*digest-line-info* (if (and line-info *digest-line-info*) (progn (clrhash *digest-line-info*) (dotimes (i (length line-info)) (setf (gethash (aref line-info i) *digest-line-info*) i)) *digest-line-info*) nil)) (*line-info* line-info)) (let ((result (walk-top form))) (setf (car form) 'lambda-block-expanded) (setf (cdr form) (cdr result)) form))) (defun walk-top (form) (let ((*walk-variable-bindings* nil) (*control-stack* nil) (*walk-functions* nil) ) (b1-walk form 'top))) (defun transfer-line-info (form result for-sure &aux tem) ;; transfer the line info from FORM to RESULT. ;; If FOR-SURE holds, do it even if this would destroy ;; line info of RESULT. (cond ((atom result) nil) ((setq tem (gethash form *digest-line-info*)) (when (or for-sure (not (gethash result *digest-line-info*))) (remhash form *digest-line-info*) (and *line-info* (setf (aref *line-info* tem) result)) (setf (gethash result *digest-line-info*) tem))))) (defun b1-walk (form where &aux tem sym result (changed 0)) (declare (fixnum changed)) (setq result (cond ((atom form) (cond ((constantp form) (cond ((symbolp form) (get-object (symbol-value form))) (t (get-object form)))) ((symbolp form) (let ((v (find-bind form t))) (cond ((and (consp v) (eq (car v) 'symbol-macro)) (b1-walk (second v) where)) (t (or (var-ref v) (setf (var-ref v) t)) v)))))) ((symbolp (setq sym (car form))) ;;possibly fix line info (and *digest-line-info* (cond ((setq tem (get sym 'wl)) (funcall tem form)))) (setq changed (fill-pointer *changed*)) (cond ((setq tem (get sym 'b1)) (funcall tem form where)) ((and (setq tem (get sym 'bo1)) (setq tem (funcall tem form where))) (b1-walk tem where)) ((b1-macro-function sym) (b1-walk (macroexpand form (walk-environment)) where)) ((setq tem (get sym 'si::structure-access)) (let (arg res-type sd (index (cdr tem))) (desetq (arg) (cdr form)) (setq tem (case (car tem) (vector `(aref (the (array t) ,arg) ,index)) (list `(nth ,index ,arg)) (t (setq sd (get (car tem) 'si::s-data)) (or (null (cddr form)) (comp-warn "Too many args to ~a" sym)) (cond ((null sd) (comp-warn "Structure not defined ~a" (car tem))) (t (setq res-type (comp-type(aet-type (aref (si::s-data-raw sd) index)))) (cond ((eq res-type t) `(si::structure-ref ,arg ',(car tem) ,index)) (t `(the,res-type (si::structure-ref (the (struct ,res-type) ,arg) ',(car tem) ,index))))))))) (b1-walk tem where))) ;; function application (t (do-call-b1 form where) ))) ((and (consp (car form)) (eq (caar form) 'lambda)) (b1-walk `(funcall (function ,(car form)) ,@ (cdr form)) where)) (t (error "unrecognized form to eval ~a" form)))) (when (and (consp result) (consp (cdr result)) (typep (second result) 'desk)) (let ((tem (let ((v *changed*)) (declare (type (vector (t)) v)) (sloop for i from changed below (fill-pointer v) collect (aref v i))))) (when tem (if (eq (second result) *default-desk*) (setf (second result) (make-desk t))) (setf (desk-changed-vars (second result))tem) ))) (and *digest-line-info* (transfer-line-info form result t)) result) (defun constant-call (sym arglist) (and (sloop for v in arglist always (and (consp v) (eq (car v) 'dv))) (cons (b1-walk (apply sym (mapcar 'caddr arglist)) 'call) nil))) (defun do-call-b1 (form where &aux (sym (car form)) tem args) (let* ((wf (cdr (assoc sym *walk-functions*))) (res `(call ,*default-desk* ,(make-call-data sym (setq args (mapcar2 'b1-walk (cdr form) 'funcall)) wf (cdr (assoc sym *function-decls*)) )))) (cond (wf ;; indicate a closure ref if necessary. (if (third wf) (find-bind (var-name (third wf)))) ) ((setq tem (result-from-args sym args)) (setf (second res) (set-desk-type (second res) tem))) ((setq tem (get sym 'proclaimed-function-declaration)) (setq tem (ret-from-argd (fdecl argd tem))) (cond ((eq tem 'double_ptr) (setq tem 'double-float)) ((eq tem '*) (setq tem 't))) (setf (second res) (set-desk-type (second res) tem)))) (cond ((and (member sym '(< > length + - * / )) (setq tem (constant-call sym (call-data-arglist (third res))))) (return-from do-call-b1 (car tem)))) ;; tail recursion???? (cond ((and (consp where) (eq (car where) 'lambda-block) (eq (second where) sym) (not (member 'bound-special *control-stack*)) (not wf)) (format t "~%;;Note: Replaced tail call of ~a by iteration." sym) (let ((args (call-data-arglist (third res)))) (sloop for v in args with s do (unless (cdr args) (setq sets (list (cons 'done-b1 (car args)))) (loop-finish)) (setq s (gensym)) for var in (third where) collect (list s (cons 'done-b1 v)) into binds unless (eq t (var-type var)) collect (list 'type (var-type var) s) into decls collect s into sets finally (setq res (b1-walk `(let ,binds ,(cons 'declare decls) (assign-args ,@sets) (go ,(label-identifier (nth 3 where)))) 'let)))))) ;;ordinary functioncall res)) (defun b1-quote-first (form where &aux sform fir bod) where (desetq (sform fir . bod) form) `(,sform ,fir ,@ (mapcar2 'b1-walk bod sform))) (defun b1-quote (form where &aux val) where (desetq (nil val) form) (and (cddr form) (comp-error "Two many args to quote ~a"form)) (get-object val)) (defun b1-setq (form where &aux sform var bod val ans) where (cond ((null (cdr form)) (return-from b1-setq (get-object nil)))) (desetq (sform var val . bod) form) (do () (nil) (let ((v (find-bind var t))) (setf (var-changed v) t) (and (plain-var-p v) (vector-push-extend v *changed*)) (setq val (b1-walk val sform)) (push v ans) (push val ans) (if bod (desetq (var val . bod) bod) (return nil)))) `(,sform, (make-desk (var-type (second ans))) ,@ (nreverse ans))) (defun b1-eval (form where &aux sform bod) where (desetq (sform . bod) form) `(,sform ,@ (mapcar2 'b1-walk bod sform))) ;; using (control-jumped-back id) ;; ;; and (pass-values) (defun b1-tagbody (form where &aux sform bod (*walk-variable-bindings* *walk-variable-bindings*) (*control-stack* *control-stack*) (longjmp-id (makevar nil nil)) sym (clb-ref (list 0 longjmp-id)) ) where (desetq (sform . bod) form) (push longjmp-id *walk-variable-bindings*) (setq bod (sloop for v in-list bod when (or (integerp v) (symbolp v)) collect (list 'done-b1 'label (let ((tem (make-label :identifier v :clb-reference (cons nil clb-ref) ))) (push tem *control-stack*) tem)) else collect v)) (setq bod (mapcar2 'b1-walk bod sform)) (cond ((var-clb longjmp-id) (setq sym (gensym)) (bound-variables-volatile) `(let-control-stack (let ,*default-desk* ((,longjmp-id ,(b1-walk '(unique-id) 'let-var))) (,(b1-walk `(let ((,sym 0) (ctl-came-back (control-jumped-back (done-b1 . ,longjmp-id)))) (declare (fixnum ,sym)(boolean ctl-came-back)) (if ctl-came-back (progn (nlj-active-off)(setq ,sym (pass-values)))) (switch ,sym ,@ (sloop for v in bod with tem when (and (consp v) (eq (car v) 'label) (setq tem (car (label-clb-reference (cadr v))))) collect `(case ,tem) collect (cons 'done-b1 v)))) 'tagbody))))) (t `(,sform ,*default-desk* ,bod)))) ;; wrapper so you can avoid doing b1 twice on a form. ;; when we need to do it once to get the result type. (defun b1-done-b1 (form where) where (cdr form)) (defun b1-prog1 (form where &aux sform body first) (desetq (sform first body) form) (setq first (b1-walk first where)) (let ((sym (gensym))) (b1-walk `(let ((,sym (done-b1 . ,first))) (declare (type ,(result-type first) ,sym)) ,@ (append body (list sym))) where))) (defun b1-progn (form where &aux sform bod) where (desetq (sform . bod) form) (cond ((and (eq sform 'progn) (null (cdr bod))) (b1-walk (car bod) where)) (t (setq bod (mapcar2 'b1-walk bod sform where)) `(progn ,(make-desk (result-type (car (last bod)))) ,bod )))) (defun b1-if (form where &aux sform test then else) where (desetq (sform test then) form) (setq form (cdddr form)) (when (consp form) (setq else (car form)) (setq form (cdr form))) (if form (error "Too many args to if")) (setq test (b1-walk test sform)) (setq then (b1-walk then where)) (setq else (b1-walk else where)) (cond ((and (consp test) (eq (car test) 'dv)) (return-from b1-if (if (eq (third test) nil) else then)))) `(,sform ,(make-desk (type-and (result-type then) (result-type else))) ,test ,then ,else)) (defun b1-macrolet (form where &aux sform mbinds ll name body mbody funs) (desetq (sform mbinds . body) form) (do ((v mbinds (cdr v))) ((atom v)) (desetq ((name ll . mbody)) v) (let ((fun (second (parse-macro name ll mbody t)))) (push (list name 'macro fun) funs))) (let ((*walk-functions* (nconc (nreverse funs) *walk-functions*))) (b1-walk (cons 'progn body) where))) (defun b1-flet (form where &aux sform mbinds name ll body mbody new-binds fun ans let-binds let-sets var fdat tem (*walk-variable-bindings* *walk-variable-bindings*) (*walk-functions* *walk-functions*)) (desetq (sform mbinds . body) form) (do ((v mbinds (cdr v))) ((atom v)) (desetq ((name ll . mbody)) v) (setq fun `(lambda-block ,name ,ll ,@mbody)) ;;a variable to hold a pointer to the function itself. ;; so we don't have to cons up more than one copy of itself. (setq var (makevar (gensym "flet") nil)) (push var *walk-variable-bindings*) (push (list name fun nil var) new-binds)) (if (eq sform 'labels) (setf *walk-functions* (append new-binds *walk-functions*))) (dolist (v new-binds) (setq var (fourth v)) (setq ans(b1-lambda-block (second v) sform 'clb )) (setq fdat (second ans)) (setf (third v) ans) (cond ((setq tem (fdata-closure-vars fdat)) (cond ((and (null (cdr tem)) (eq (car tem) var)) ;; if the only reason for it being a closure is the self reference var ;; forget it. (setf (fdata-closure-vars fdat) nil)) (t (setf (fdata-closure-self fdat) var) (push (list var nil) let-binds) (push `(pointer-to-funobj ,fdat) let-sets) (push var let-sets)))) (t (setf (fourth v) nil) ))) (if (eq sform 'flet) (setf *walk-functions* (append new-binds *walk-functions*))) (setq body (mapcar2 'b1-walk body sform where)) (setq ans `(flet ,(make-desk (result-type (car (last body)))) ,(reverse new-binds) ,body)) (if let-binds `(let ,(second ans) ,let-binds ((setq ,*default-desk* ,@ let-sets) ,ans)) ans)) (defun b1-symbol-macrolet (x where &aux sform binds body expansion decls tem new-binds name ) (desetq (sform binds . body) x) (desetq (decls body) (grab-declares body t)) (do ((v binds (cdr v))) ((atom v)) (desetq ((name expansion)) v) (if (member name (car decls)) (error "special declaration of symbol-macrolet var ~a" name)) (when (setq tem (assoc name (second decls))) (setf expansion `(the , (cdr tem) ,expansion))) (push (list name 'symbol-macro expansion) new-binds)) (let ((*walk-variable-bindings* (nconc new-binds *walk-variable-bindings*))) (b1-progn (cons 'progn body) where))) (defun b1-let (form where &optional compiler-let &aux sform var vars body val (*function-decls* *function-decls*) (*walk-variable-bindings* *walk-variable-bindings*) (*control-stack* *control-stack*) decls binds) (desetq (sform vars . body) form) (do ((v vars (cdr v))) ((atom v)) (cond ((consp (car v)) (setq var (caar v)) (setq val (cdar v)) (and (not compiler-let) (setq val (b1-walk (car val) sform)))) (t (setq var (car v) val nil))) (push (list var val) binds)) (setq binds (nreverse binds)) (if compiler-let (return-from b1-let (progv (mapcar 'car binds) (mapcar 'cadr binds) (b1-progn (cons 'progn body) where)))) (desetq (decls body) (grab-declares body nil)) (dolist-safe (v binds) (wbind (car v) decls)) (add-remaining-special-decls decls) (cond ((null vars) (b1-progn (cons 'progn body) where)) (t (setq body (mapcar2 'b1-walk body sform where)) (check-used binds 0) `(let ,(make-desk (result-type (car (last body)))) ,binds, body)))) (defun b1-compiler-let (form where) (b1-let form where t)) (defun b1-let* (form where &aux sform var val binds (*function-decls* *function-decls*) (*control-stack* *control-stack*) (*walk-variable-bindings* *walk-variable-bindings*) vars body decls) (desetq (sform vars . body) form) (desetq (decls body) (grab-declares body nil)) (do ((v vars (cdr v))) ((atom v)) (cond ((consp (car v)) (setq var (caar v)) (setq val (cdar v)) (and (consp val) (setq val (b1-walk (car val) sform)))) (t (setq var (car v) val nil))) (push (list var val) binds) (wbind (caar binds) decls) ) (add-remaining-special-decls decls) (setq binds (nreverse binds)) (cond ((null vars) (b1-progn (cons 'progn body) where)) (t (setq body (mapcar2 'b1-walk body sform where)) (check-used binds 0) `(let* ,(make-desk (result-type (car (last body)))) ,binds, body))) ) ;; Scope of declarations: ;; Note Xrj13 voted that for ;; (let ((x 0)) (declare (fixnum x)) ;; .. (let ((x 5))(declare (type t x)) ..)) ;; then the inner declaration of x is also (and fixnum t) ie fixnum. ;; We DO NOT take advantage of this declaration, since it is very easy ;; for users to slip up on this, and since it is contrary to CltlI. The ;; Compiler has license to ignore type decls if it wants, and we do so here. ;; They explicitly say for ;; (let ((x 0)) (declare (special x)) ;; .. (let ((x 5)) ..)) ;; then the inner binding of x is NOT special unless there is another decl. ;; We do this. (defun grab-declares (form doc-allowed &aux (dec t) decls doc tem) doc-allowed ;; return (cons form decls) ;; decls == (list specials type-decls ..) (if (stringp (car form)) (setq doc (car form) form (cdr form))) (sloop while dec do (setq tem (car form)) (cond ((and (consp tem) (eq (car tem) 'declare)) (setq form (cdr form)) (dolist-safe (v (cdr tem)) (setq decls (grab-1-decl v decls)))) ((eq tem (car form))(setq dec nil)) (t (setq form (cons tem (car form)))))) ; (if (and doc (not decls)) (setq form (cons doc form))) ;decls= (((v1 . type1) (v2 . type2) ..)(special-var1 special-var2 ..)) (list decls form doc)) (defun get-back-some-decls (decls vars &aux specials types tem) ;; build up a declare to restore the decls. (setq specials(sloop for v in vars when (member v (second decls)) collect v )) (setq types(sloop for v in vars when (setq tem (assoc v (car decls))) collect `(type ,(cdr tem) ,v))) (cond (specials (push (cons 'special specials) types))) (if types `((declare ,@ types))nil)) (defun b1-declare (form where &aux type vars) where (dolist (v (cdr form)) (desetq (type . vars) v) (cond ((eq type'special) (sloop for w in-list vars do (push (list v 'special (makevar v t)) *walk-variable-bindings*))) ((member type '(ftype optimize function ignore declaration dynamic-extent)) nil) ((member type '(inline notinline)) (dolist-safe (v vars) (push (cons v (increment-function-decl type (function-declaration v))) *function-decls*))) ((eq type 'type) (desetq (type . vars) vars) ;; do nothing. ))) nil) (defun b1-the (form where &aux sform type val tem) ;; note this takes away the checking (desetq (sform type val) form) (setq val (b1-walk val where)) (setq type (comp-type type)) (cond ((and (consp val) (typep (setq tem (second val)) 'desk)) (setf (second val) (set-desk-type tem type)) ; (unless (and (consp type) (eq (car type )'values) ; (consp (cdr type)) (consp (cddr type))) ; (setf (desk-single-value (second val)) t)) val) (t (setq tem (result-type val)) (setq type (type-and tem type)) `(the ,(make-desk type) ,val)))) (defun b1function-object (object where) ;; this might be called by b1-funcall, b1-mapcar and others ;; to avoid getting closure varialbes. They must promise to inline ;; this, since the closure vars are not set up, for cross closure stuff. (cond ((matches object '(function (lambda . tem))) `(inline-function ,(b1-lambda-block (second object) 'function nil))) (t (b1-walk object where )))) (defun b1-function (form where &aux sform body tem) where (desetq (sform body) form) (cond ((symbolp body) (cond ((setq tem (assoc body *walk-functions*)) (cons 'pointer-to-funobj (cddr tem))) (t (b1-walk `(symbol-function ',body) where)))) ((and (consp body) (eq (car body) 'lambda)) (b1-lambda-block body 'function 'clb)) ;`(lambda-block ,(b1-lambda-block body 'function t)) (t (error "unrecognized function ~a" body)))) (defun b1-go (form where &aux sform label clb result ) where (desetq (sform label) form) (sloop for v in *control-stack* when (eq v 'clb) do (setq clb t) else when (and (typep v 'label) (eql (label-identifier v) label)) do(setq result v) (when clb (setq clb (label-clb-reference v)) (or (car clb) (setf (car clb) (incf (cadr clb)))) (let ((tem (or (var-clb (third clb)) 0))) (incf tem) (setf (var-clb (third clb) ) tem))) (return nil) finally (comp-error "~a label is not found " label)) (cond (clb (b1-walk `(progn (call-set-mv ,(car clb)) (do-throw (done-b1 . ,(third clb))) nil) 'go)) (t (setf (label-referred result) t) (list 'go result)))) ;(defun b1-unwind-protect (x where &aux form cleanup ; (var (gensym)) ; ) ; (desetq (nil form . cleanup) x) ; (bound-variables-volatile) ; (b1-walk ; `(let ((,var (function (lambda () ,@ cleanup)))) ; (declare (dynamic-extent ,var)) ; (push-unwind-protect ,var) ; (multiple-value-prog1 ; ,form ; (pop-control-stack) ; (funcall ,var))) ; where)) (defun simple-b1 (x where &aux sform form) (desetq (sform form) x) `(,sform ,(b1-walk form where))) (setf (get 'let-control-stack 'b1) 'simple-b1) (defun b1-unwind-protect (x where &aux form cleanup (var (gensym)) ) (desetq (nil form . cleanup) x) (bound-variables-volatile) (b1-walk `(let ((,var (function (lambda () ,@ cleanup)))) (declare (dynamic-extent ,var)) (let-control-stack (progn (push-unwind-protect ,var) ,form))) where)) (defun b1-progv (x where &aux vars vals body bind) (desetq (vars vals . body) (cdr x)) (setq bind (b1-walk `(the fixnum (progv-bind ,vars ,vals)) 'progv)) (let ((*control-stack* (cons 'progv *control-stack*))) (setq body (mapcar2 'b1-walk body 'progv where)) `(progv ,(make-desk (result-type (car (last body)))) ,bind ,body))) (defun b1-catch (x where &aux tag bod ) where (desetq (tag . bod) (cdr x)) (bound-variables-volatile) `(let-control-stack ,(b1-walk `(if (control-jumped-back ,tag) (progn (nlj-active-off)(pass-values)) (progn ,@ bod)) 'catch))) (defun b1-throw (x where &aux tag bod form) where (desetq ( tag form . bod ) (cdr x)) (or (null bod) (comp-error "too many args to throw ~a" x)) (let (sym) (b1-walk `(let ,(cond ((and (consp tag)(eq (car tag) 'quote))(setq sym tag) nil) (t (setq sym (gensym)) `((,sym ,tag)))) (call-set-mv ,form) (do-throw ,sym) nil) 'throw))) ;(defun b1-throw (x where &aux tag bod form) where ; (desetq ( tag form . bod ) (cdr x)) ; (or (null bod) (comp-error "too many args to throw ~a" x)) ; `(throw ,*default-desk* ,tag ,(b1-walk form 'throw))) (defun b1-multiple-value-prog1 (x where &aux first bod) (desetq (nil first . bod) x) `(multiple-value-prog1 ,*default-desk* ,(b1-walk first where) ,(mapcar2 'b1-walk bod 'progn))) (defun b1-block (x where &aux sform tag bod ( *control-stack* *control-stack*) (*walk-variable-bindings* *walk-variable-bindings*) block ans var) (desetq (sform tag . bod) x) (setq block (make-block (make-label :identifier tag :clb-reference (setq var (makevar nil nil)) ))) (push var *walk-variable-bindings*) (push block *control-stack*) (or bod (setq bod '(nil))) (setq bod (mapcar2 'b1-walk bod sform where)) (setq ans `(,sform ,(make-desk (result-type (car (last bod)))) ,block ,bod)) (cond ((var-clb var) (bound-variables-volatile) (setq ans `(let-control-stack (let ,(second ans) , `((,var ,(b1-walk '(unique-id) 'let-var))) (,(b1-walk `(if (control-jumped-back (done-b1 . ,var)) (progn (nlj-active-off) (pass-values)) (done-b1 . ,ans)) where)))))) (t (setf (label-clb-reference (block-label block)) nil))) ans ) (defun b1-return-from (x where &aux clb tag block form bod) where (desetq (nil tag . bod) x) (cond ((null bod) (setq form nil)) ((consp bod) (setq form (car bod)) (or (null (cdr bod)) (comp-error "Too many values for return-from ~a"x))) (t (comp-error "Bad return from ~a" x))) (sloop for v in *control-stack* when (eq v 'clb) do (setq clb t) else when (and (typep v 'block) (eql (label-identifier (block-label v)) tag)) do (setq block v) (when clb (setq clb (label-clb-reference (block-label v))) (cond ((var-clb clb) (incf (var-clb clb))) (t (setf (var-clb clb) 1)))) (return nil) finally (comp-error "Could not find ~a tag to return from" block)) (cond (clb (b1-walk `(progn (call-set-mv ,form) (do-throw ,(cons 'done-b1 clb)) nil ) 'return-from)) (t (setq form (b1-walk form 'return-from)) `(return-from ,(make-desk (result-type form)) ,block ,form)))) (defun b1-values (x where) (let ((argl (mapcar2 'b1-walk (cdr x) where))) `(values , (make-desk (if argl (result-type (car argl)) t)) ,argl))) ;; Several WL functions for Walk to fix Line-info, and ;; make it more sensible for special forms. (do ((v '(let wl-let let* wl-let compiler-let wl-let cond wl-cond ) (cddr v))) ((null v)) (setf (get (car v) 'wl) (second v))) (defun wl-let (form &aux sform vars bod) (desetq (sform vars . bod) form) (dolist (v vars) (if (consp v) (transfer-line-info v (second v) nil)))) (defun wl-cond (form &aux clauses) (desetq (nil . clauses) form) (dolist (v clauses) (or (consp v) (error "bad cond clause")) (transfer-line-info v (if (consp (car v)) (car v) (second v)) nil))) (defun use-expansion (do) (if do (setf si::lambda-block-expanded (symbol-function 'si::expand-fun)) (setf si::lambda-block-expanded nil))) (defmacro switch (test &body body &aux tem (tes (gensym ))) (sloop for v in-list body when (and (consp v) (eq (car v) 'case) (consp (cdr v)) (null (cddr v))) collect (setq tem (make-symbol (format nil "case~a_" (cadr v)))) into bod and collect (cons (cadr v) tem) into cases else collect v into bod finally (return `(tagbody (let ((,tes ,test)) (declare (fixnum ,tes)) (cond ,@ (sloop for v in cases when (typep (car v) 'fixnum) collect `((eql ,tes ,(car v))(go ,(cdr v))) else collect `(t (go ,(cdr v)))))) ,@ bod)))) ;(switch n (case 0) 3) ;; ;;- Local variables: ;;- mode:lisp ;;- version-control:t ;;- End: gcl/comp/wr.lsp000077500000000000000000000323661242227143400137470ustar00rootroot00000000000000(in-package "BCOMP") (defmacro wr (&rest l) `(progn ,@ (mapcar #'(lambda (x) (if (stringp x) `(princ ,x *c-output*) `(wr1 ,x))) l ))) (defmacro wr-nl (&rest l) `(wr " " ,@l)) (defmacro wr-h (&rest l) `(progn (princ " " *h-output*) ,@ (mapcar #'(lambda (x) (if (stringp x) `(princ ,x *h-output*) `(wr1-h ,x))) l))) (defun wr1 (x ) (cond ((or (typep x 'fixnum)(stringp x)) (princ x *c-output*)) ((consp x) (or (symbolp (car x)) (wfs-error)) (let ((fd (get (car x) 'wr))) (or fd (wfs-error)) (funcall fd x))) ((typep x 'var) (cond ((var-clb x) (wr "ClosRef(" (list 'closure-var-loc x) ")")) ((var-special-p x) (or (var-ind x) (wfs-error)) (cond ((= *safety* 0) (wr "("(var-ind x)")->s.Bind" )) (t (wr "symbol_value("(var-ind x)")" )))) (t (or (var-ind x) (next-cvar x)) (cond ((stringp (var-ind x)) (wr (var-ind x))) (t (wr "V" (var-ind x))))))) ((eq t x)(wr "Ct")) ((eq nil x)(wr "Cnil")) ((typep x 'label) (or (label-ind x) (setf (label-ind x) (next-label))) (wr (label-ind x))) ((typep x 'fdata) (let ((i (fdata-ind x))) (if (stringp i) (wr i) (wr "L" i)))) (t (wfs-error)))) (defun wr1-h (x &aux (*c-output* *h-output*)) (wr1 x)) (setf (get 'dv 'wr) 'wr-dv) (setf (get 'd_eval 'wr) 'wr-dv) (defun add-data (x &aux tem) (or (and (consp x) (or (eq (car x) 'dv) (eq (car x) 'd_eval))) (wfs-error)) (let ((item (third x))) (unless (second x) (cond ((and (symbolp item) (setq tem (get item 'dv))) (setf (second x) tem)) ((and (typep item 'fixnum) (eql 0 (logand #. (lognot 1023) (the fixnum item)))) (setf (cadr x) (format nil "small_fixnum(~a)" item))) (t (setf (second x) *next-data*) (push-data (car x) (third x))))) x)) ;; Some things namely the keyword mechanism REQUIRES a constant which ;; has an index. This means that named ones will have to get an index ;; We could smash this place (defun get-dv-index (x) ;; a (dv which may have a string. We put an index in the fourth place.) (cond ((typep (second x) 'fixnum) (second x)) ((cdddr x) (fourth x)) (t (setq x (nconc x (list *next-data*))) (push-data (car x) (third x))))) (defun wr-dv (x) (let ((tem (second x))) (cond (tem (cond ((typep tem 'fixnum) (wr "VV[" tem"]")) (t (wr tem)))) (t (add-data x) (wr-dv x))))) (setf (get 'var 'wr) 'wr-var) (defun wr-var (x) (cond ((and (consp x) (eq (car x) 'var)) (wr-vind (second x))) (t (wfs-error)))) (defun wr-vind (x) (if (stringp x) (wr x) (wr "V" x))) (setf (get 'closure-var-loc 'wr) 'wr-closure-var-loc) (defun wr-closure-var-loc (x &aux (var (second x))) (cond ((member var *closure-vars*) (wr "CLvars->") (or (and (consp (var-ind var)) (eq (car (var-ind var)) 'kw)) (wfs-error)) (wr-vind (second (var-ind var)))) (t (wr-vind (var-ind var))))) (setf (get 'key-var 'wr) 'wr-key-var) (defun wr-key-var (x &aux (v (second x)) tem) (or (typep v 'var) (wfs-error)) (cond ((setq tem (var-special-p v)) (wr tem)) (t (wr-vind (var-ind v))))) (setf (get 'vcs 'wr) 'wr-vcs) (defun wr-vcs(x) (wr "cs[" (second x)"]")) (setf (get 'kw 'wr) 'wr-kw) (defun wr-kw(x) (wr "k.") (wr-vind (second x))) (setf (get 'vk 'wr) 'wr-vk) (defun wr-vk (x) (wr "&VK" (second x) "key")) (defun wr-comment (message &optional (symbol nil)) (wr " /* " message) (and symbol (wr (mangle symbol))) (wr " */ ") nil) (setf (get 'label 'wr) 'wr-label) (defun wr-label (n &aux) (when (consp n) (or (eq (car n) 'label) (wfs-error)) (setq n (second n))) (wr " LA" n ": ")) (defun wr-go (n) (if (typep n 'label) (or (label-ind n) (setq n (setf (label-ind n) (next-label))))) (wr "goto LA" n ";")) (defun wr-list (l) (do ((v l (cdr v))) ((null v)) (wr (car v)) (or (null (cdr v)) (wr ",")))) (setf (get 'next-var-arg 'wr) 'wr-next-var-arg) (defun wr-next-var-arg (x) x (wr "va_arg(Iap,object)")) (setf (get 'call 'wr) 'wr-call) (defun wr-call (x) (let* ((cdat (second x)) (fname (call-data-fname cdat)) (name (if (symbolp fname) (symbol-name fname) (format nil "L~a" (fdata-ind fname))))) (wr "CA_" name "(") (wr-list (third x)) (wr ")")) ) (defmacro var-implementation-type (x) `(cond ((and (plain-var-p ,x) (not (and (consp (var-ind ,x)) (eq (car (var-ind ,x)) 'kw)))) (var-type ,x)) (t t))) (defun wr-set-inline-loc (a b &aux type) (cond ((eq a b) (wr ";")(return-from wr-set-inline-loc nil))) (cond((atom a) (or (typep a 'var) (wfs-error)) (cond ((var-special-p a) (setq type 'special) (wr-nl "(" (var-ind a) ")->s.Bind = ")) (t (setq type (var-implementation-type a))))) ((and (consp a) (eq (car a) 'var)) (setq type (third a))) (t (wfs-error))) (cond ((eq type 'integer) (let ((val-type (value-type b))) (case val-type (fixnum (wr-nl "ISETQ_FIX(") ) (integer (wr-nl "SETQ_II(") ) (otherwise (wr-nl "SETQ_IO(") (setq val-type t))) (setq b (list 'inline-loc val-type b)) (wr a","a"__alloc," b ");") (return-from wr-set-inline-loc nil))) ((eq type 'special) (setq type t)) (t (wr-nl a "="))) (case type (fixnum (wr-fixnum-loc b)) (character (wr-character-loc b)) (gen (wr-integer-loc b)) (double-float (wr-double-float-loc b)) (double_ptr (wr-double_ptr-loc b)) (short-float (wr-short-float-loc b)) (boolean (wr-boolean-loc b)) (t (wr-obj-loc b))) (wr ";") ) (defun wr-integer-loc (x) (cond ((and (dv-p x) (typep (third x) 'fixnum)) (setq x (list 'inline-loc 'fixnum x)))) (case (value-type x) (integer (wr x)) (fixnum (wr "stoi(" x ")")) (t (wr "otoi(" x ")")))) (defun value-type (x &aux tem) ;; returns the representation type of form x (setq tem (cond ((consp x) (cond ((eq (car x) 'dv) t) ((eq (car x) 'var) (or (third x) t)) ((eq (car x) 'inline-call) (nth 3 x)) ((eq (car x) 'inline-loc) (nth 1 x)) ((eq (car x) 'let-control-stack) (value-type (second x))) ((eq (car x) 'next-var-arg) t) )) ((typep x 'var) (var-implementation-type x)))) (unless tem (comp-warn "Don't know type of ~a. Assuming type t" x)) (or (memq tem '(fixnum integer short-float double-float character boolean double_ptr)) (setq tem t)) tem) (setf (get 'inline-loc 'wr) 'wr-inline-loc) (defun wr-inline-loc (x &aux (y (third x)) (type (second x))) (case type (fixnum (wr-fixnum-loc y)) (short-float (wr-short-float-loc y)) (double-float (wr-double-float-loc y)) (double_ptr (wr-double_ptr-loc y)) (character (wr-character-loc y)) ((gen integer) (wr-integer-loc y)) (boolean (wr-boolean-loc y)) (t (wr-obj-loc y)))) (setf (get 'fixnum 'loc) 'wr-fixnum) (defun wr-boolean-loc (x) (let ((type (value-type x))) (case type (boolean (wr x)) ((short-float double_ptr character long-float integer) (wr "1")) (t (wr "(" x ")!=sLnil" ))))) (defun wr-fixnum-loc (b) (case (value-type b) (fixnum (wr b)) ((short-float long-float) (wr "(int)(" b")" )) (double_ptr (wr "(int)(*(" b "))")) (integer (wr "itos(" b")")) (t (cond ((and (consp b) (eq (car b) 'dv)) (cond ((typep (third b) 'fixnum) (wr (third b)) (return-from wr-fixnum-loc nil)) (t (comp-warn "Not a fixnum ~a "(third b)))))) (wr "fix(" b ")")))) (defun wr-character-loc (b) (case (value-type b) (character (wr b)) ((short-float long-float) (comp-error "Cant coerce float to character") (wr "(int)(" b")" )) (integer (wfs-todo)) (t (cond ((and (consp b) (eq (car b) 'dv)) (cond ((typep (third b) 'character) (wr (char-code (third b))) (return-from wr-character-loc nil)) (t (comp-warn "Not a character ~a "(third b)))))) (wr "char_code(" b ")")))) (defun wr-double-float-loc (b) (case (value-type b) ((short-float fixnum) (wr "(double)(" b ")")) (double-float (wr b)) (double_ptr (wr "*(" b ")")) (integer (wfs-todo)) (t (wr "DFloat(" b ")")))) (defun wr-short-float-loc (b) (case (value-type b) ((short-float fixnum double-float) (wr "(float)(" b ")")) (double_ptr (wr "(float)(*(" b "))")) (integer (wfs-todo)) (t (wr "SFloat(" b ")")))) (defun wr-double_ptr-loc (b &aux tem) (case (value-type b) ((short-float fixnum) (setq tem (get-temp 'double_ptr)) (wr "*"tem" = (double)(" b ")") ) (double (wr "*("b")")) (integer (wfs-todo)) (t ;;wrong (object (wr "&(DFloat(" b "))"))))) (defun wr-obj-loc (x) (case (value-type x) (short-float (wr "make_shortfloat(" x ")")) (double-float (wr "Imake_doublefloat(" x ")")) (double_ptr (wr "Imake_doublefloat(*(" x "))")) (fixnum (wr "make_fixnum(" x ")")) (integer (wr "make_integer(" x ")")) (character (wr "code_char(" x ")")) (boolean (wr "(" x "? sLt : sLnil)")) (t (wr x)))) (setf (get 'inline-call 'wr) 'wr-inline-call) (defun wr-inline-call (x ) ; (desetq (sform iargs arg-types res flags fstring) x) (wr-inline-call1 (cadr x) (opt template (cddr x)))) (defun wr-link-call (lnk iargs &aux nochange) (let* ((argd (link-argd lnk)) (n (length iargs))) (declare (fixnum argd )) (cond ((< n (argd-minargs argd)) (setf (argd-minargs argd) n)) ((> n (argd-maxargs argd)) (setf (argd-maxargs argd) n)) (t (setq nochange t)) (setf (argd-minargs (link-argd lnk)))) (unless nochange (setf (link-argd lnk) argd)) (or (link-ind lnk) (setf (link-ind lnk) (mangle-name (link-fname lnk) 'function))) (cond ((argd-flag-p argd requires-nargs) (wr "(VFUN_NARGS=" n ","))) (wr "(*LnK" (link-ind lnk) ")(") (wr-list iargs) (wr ")") (cond ((argd-flag-p argd requires-nargs) (wr ")"))))) (defun wr-inline-call1 (iargs fstring &aux (leng 0) wrote-paren (ch #\space) (ind 0) (start 0) (out *c-output*)) ;; $@i : write out all (nthcdr i args) in a comma separated list. ;; $i : write out arg i ( 0<= i < 10) ;; $# : write out (length iargs) ;; @i,j,..; i,j,.. are multiple eval'd. ;; $*i : push args starting at the ith onto value stack and pass the pointer ;; to the place where you start. (declare (character ch) (fixnum ind leng start) (string fstring)) (cond ((stringp fstring)) ((typep fstring 'link) (wr-link-call fstring iargs) (return-from wr-inline-call1 nil)) (t (return-from wr-inline-call1 (funcall fstring iargs)))) (setq leng (length fstring)) ;; save multiple eval'd args. @0,3; means args 0 and 3 need temps. (cond ((eql (aref fstring 0) #\@) (sloop for i from 1 below leng until (eql (setq ch (aref fstring i)) #\;) when (digit-char-p ch) do (let ((tem (nth (setq ind (- (char-code ch )(char-code #\0))) iargs))) (unless (or (typep tem 'var) (and (consp tem) (or (eq (car tem) 'dv) (eq (car tem) 'var)))) (let ((v (get-temp (value-type (nth ind iargs))))) (setf (nth ind iargs) v) (unless wrote-paren (setq wrote-paren t) (wr "(")) (wr v "= " tem ",")))) finally (setq start (+ 1 i))))) ;; write out the template. (sloop for i from start below leng with l = (length iargs) declare (fixnum l) do (setq ch (aref (the string fstring) i)) (cond ((or (eql ch #\$) (eql ch #\#);; compatibility with akcl ) (setq i (+ i 1)) (setq ch (aref (the string fstring) i)) (setq ind (- (char-code ch) (char-code #\0))) (cond ((and (< ind 10) (>= ind 0)) (if (>= ind l) (comp-error "Bad inline template ~a" fstring)) (wr (nth ind iargs))) ((eql ch #\@) (setq i (+ i 1)) (let ((n (- (char-code (aref fstring i)) (char-code #\0)))) (declare (fixnum n)) (wr-list (nthcdr n iargs)))) ((eql ch #\*) (setq i (+ i 1)) (let* ((n (- (char-code (aref fstring i)) (char-code #\0))) (m (- (length iargs) n)) (p (get-temp "object *"))) (declare (fixnum n m)) (wr "(" p "= (vs_top+=" m"),") (sloop for v in (reverse (nthcdr n iargs)) do (wr "*--"p" =" v",")) (wr p ")"))) ((eql ch #\# ) (wr (length iargs))) (t (comp-error "Bad inline string ~s" fstring)))) (t (write-char ch out)))) ; (if wrote-paren (wr ")")) ) (defun write-out-links( &aux lnk) (dolist (v *file-inline-templates*) (or (typep (setq lnk (nth 4 v)) 'link) (wfs-error)) (let ((ind (link-ind lnk)) (rett (rep-type (third v)))) (wr " static " rett "LnKT" ind "(va_alist)va_dcl {va_list Iap; va_start(Iap); return ("rett ")Icall_proc" (if (eq (third v) 'short-float) "_float(" "(") (get-object (link-fname lnk)) "," (link-argd lnk) ",&LnK" (link-ind lnk ) ",Iap);}") (wr-h "static "rett "LnKT"ind"(),(*LnK" ind ")()=LnKT" ind ";") ) )) (defun write-out-address-and-data () (let ((*c-output* *h-output*)) (wr" static object VV[" (max 1 (length *address-vector*) *next-data*) "]={") (let ((l (length *address-vector*)) (i 0)) (declare (fixnum i l)) (sloop while (< i l) do (wr-nl "(void *)" (aref *address-vector* i)) when (< (setq i (+ i 1)) l) do (wr ",")) (if (eql i 0) (wr 0)) (wr "};"))) (wt-data-file)) (setf (get 'address 'wr) 'wr-address) (defun wr-address (x) (wr "&" (second x)))gcl/config.guess000077500000000000000000001235501242227143400141520ustar00rootroot00000000000000#! /bin/sh # Attempt to guess a canonical system name. # Copyright 1992-2014 Free Software Foundation, Inc. timestamp='2014-03-23' # This file 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 . # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that # program. This Exception is an additional permission under section 7 # of the GNU General Public License, version 3 ("GPLv3"). # # Originally written by Per Bothner. # # You can get the latest version of this script from: # http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD # # Please send patches with a ChangeLog entry to config-patches@gnu.org. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] Output the configuration name of the system \`$me' is run on. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. Copyright 1992-2014 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" >&2 exit 1 ;; * ) break ;; esac done if test $# != 0; then echo "$me: too many arguments$help" >&2 exit 1 fi trap 'exit 1' 1 2 15 # CC_FOR_BUILD -- compiler used by this script. Note that the use of a # compiler to aid in system detection is discouraged as it requires # temporary files to be created and, as you can see below, it is a # headache to deal with in a portable fashion. # Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still # use `HOST_CC' if defined, but it is deprecated. # Portable tmp directory creation inspired by the Autoconf team. set_cc_for_build=' trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; : ${TMPDIR=/tmp} ; { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; dummy=$tmp/dummy ; tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; case $CC_FOR_BUILD,$HOST_CC,$CC in ,,) echo "int x;" > $dummy.c ; for c in cc gcc c89 c99 ; do if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then CC_FOR_BUILD="$c"; break ; fi ; done ; if test x"$CC_FOR_BUILD" = x ; then CC_FOR_BUILD=no_compiler_found ; fi ;; ,,*) CC_FOR_BUILD=$CC ;; ,*,*) CC_FOR_BUILD=$HOST_CC ;; esac ; set_cc_for_build= ;' # This is needed to find uname on a Pyramid OSx when run in the BSD universe. # (ghazi@noc.rutgers.edu 1994-08-24) if (test -f /.attbin/uname) >/dev/null 2>&1 ; then PATH=$PATH:/.attbin ; export PATH fi UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown case "${UNAME_SYSTEM}" in Linux|GNU|GNU/*) # If the system lacks a compiler, then just pick glibc. # We could probably try harder. LIBC=gnu eval $set_cc_for_build cat <<-EOF > $dummy.c #include #if defined(__UCLIBC__) LIBC=uclibc #elif defined(__dietlibc__) LIBC=dietlibc #else LIBC=gnu #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC' | sed 's, ,,g'` ;; esac # Note: order is significant - the case branches are not exclusive. case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in *:NetBSD:*:*) # NetBSD (nbsd) targets should (where applicable) match one or # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*, # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently # switched to ELF, *-*-netbsd* would select the old # object file format. This provides both forward # compatibility and a consistent mechanism for selecting the # object file format. # # Note: NetBSD doesn't particularly care about the vendor # portion of the name. We always set it to "unknown". sysctl="sysctl -n hw.machine_arch" UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ /usr/sbin/$sysctl 2>/dev/null || echo unknown)` case "${UNAME_MACHINE_ARCH}" in armeb) machine=armeb-unknown ;; arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; sh5el) machine=sh5le-unknown ;; *) machine=${UNAME_MACHINE_ARCH}-unknown ;; esac # The Operating System including object format, if it has switched # to ELF recently, or will in the future. case "${UNAME_MACHINE_ARCH}" in arm*|i386|m68k|ns32k|sh3*|sparc|vax) eval $set_cc_for_build if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ELF__ then # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). # Return netbsd for either. FIX? os=netbsd else os=netbsdelf fi ;; *) os=netbsd ;; esac # The OS release # Debian GNU/NetBSD machines have a different userland, and # thus, need a distinct triplet. However, they do not need # kernel version information, so it can be replaced with a # suitable tag, in the style of linux-gnu. case "${UNAME_VERSION}" in Debian*) release='-gnu' ;; *) release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` ;; esac # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: # contains redundant information, the shorter form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. echo "${machine}-${os}${release}" exit ;; *:Bitrig:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_RELEASE} exit ;; *:OpenBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} exit ;; *:ekkoBSD:*:*) echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} exit ;; *:SolidBSD:*:*) echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} exit ;; macppc:MirBSD:*:*) echo powerpc-unknown-mirbsd${UNAME_RELEASE} exit ;; *:MirBSD:*:*) echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} exit ;; alpha:OSF1:*:*) case $UNAME_RELEASE in *4.0) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` ;; *5.*) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` ;; esac # According to Compaq, /usr/sbin/psrinfo has been available on # OSF/1 and Tru64 systems produced since 1995. I hope that # covers most systems running today. This code pipes the CPU # types through head -n 1, so we only detect the type of CPU 0. ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` case "$ALPHA_CPU_TYPE" in "EV4 (21064)") UNAME_MACHINE="alpha" ;; "EV4.5 (21064)") UNAME_MACHINE="alpha" ;; "LCA4 (21066/21068)") UNAME_MACHINE="alpha" ;; "EV5 (21164)") UNAME_MACHINE="alphaev5" ;; "EV5.6 (21164A)") UNAME_MACHINE="alphaev56" ;; "EV5.6 (21164PC)") UNAME_MACHINE="alphapca56" ;; "EV5.7 (21164PC)") UNAME_MACHINE="alphapca57" ;; "EV6 (21264)") UNAME_MACHINE="alphaev6" ;; "EV6.7 (21264A)") UNAME_MACHINE="alphaev67" ;; "EV6.8CB (21264C)") UNAME_MACHINE="alphaev68" ;; "EV6.8AL (21264B)") UNAME_MACHINE="alphaev68" ;; "EV6.8CX (21264D)") UNAME_MACHINE="alphaev68" ;; "EV6.9A (21264/EV69A)") UNAME_MACHINE="alphaev69" ;; "EV7 (21364)") UNAME_MACHINE="alphaev7" ;; "EV7.9 (21364A)") UNAME_MACHINE="alphaev79" ;; esac # A Pn.n version is a patched version. # A Vn.n version is a released version. # A Tn.n version is a released field test version. # A Xn.n version is an unreleased experimental baselevel. # 1.2 uses "1.2" for uname -r. echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` # Reset EXIT trap before exiting to avoid spurious non-zero exit code. exitcode=$? trap '' 0 exit $exitcode ;; Alpha\ *:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # Should we change UNAME_MACHINE based on the output of uname instead # of the specific Alpha model? echo alpha-pc-interix exit ;; 21064:Windows_NT:50:3) echo alpha-dec-winnt3.5 exit ;; Amiga*:UNIX_System_V:4.0:*) echo m68k-unknown-sysv4 exit ;; *:[Aa]miga[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-amigaos exit ;; *:[Mm]orph[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-morphos exit ;; *:OS/390:*:*) echo i370-ibm-openedition exit ;; *:z/VM:*:*) echo s390-ibm-zvmoe exit ;; *:OS400:*:*) echo powerpc-ibm-os400 exit ;; arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) echo arm-acorn-riscix${UNAME_RELEASE} exit ;; arm*:riscos:*:*|arm*:RISCOS:*:*) echo arm-unknown-riscos exit ;; SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) echo hppa1.1-hitachi-hiuxmpp exit ;; Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. if test "`(/bin/universe) 2>/dev/null`" = att ; then echo pyramid-pyramid-sysv3 else echo pyramid-pyramid-bsd fi exit ;; NILE*:*:*:dcosx) echo pyramid-pyramid-svr4 exit ;; DRS?6000:unix:4.0:6*) echo sparc-icl-nx6 exit ;; DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) case `/usr/bin/uname -p` in sparc) echo sparc-icl-nx7; exit ;; esac ;; s390x:SunOS:*:*) echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4H:SunOS:5.*:*) echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) echo i386-pc-auroraux${UNAME_RELEASE} exit ;; i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) eval $set_cc_for_build SUN_ARCH="i386" # If there is a compiler, see if it is configured for 64-bit objects. # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. # This test works for both compilers. if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then SUN_ARCH="x86_64" fi fi echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:6*:*) # According to config.sub, this is the proper way to canonicalize # SunOS6. Hard to guess exactly what SunOS6 will be like, but # it's likely to be more like Solaris than SunOS4. echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:*:*) case "`/usr/bin/arch -k`" in Series*|S4*) UNAME_RELEASE=`uname -v` ;; esac # Japanese Language versions have a version number like `4.1.3-JL'. echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` exit ;; sun3*:SunOS:*:*) echo m68k-sun-sunos${UNAME_RELEASE} exit ;; sun*:*:4.2BSD:*) UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 case "`/bin/arch`" in sun3) echo m68k-sun-sunos${UNAME_RELEASE} ;; sun4) echo sparc-sun-sunos${UNAME_RELEASE} ;; esac exit ;; aushp:SunOS:*:*) echo sparc-auspex-sunos${UNAME_RELEASE} exit ;; # The situation for MiNT is a little confusing. The machine name # can be virtually everything (everything which is not # "atarist" or "atariste" at least should have a processor # > m68000). The system name ranges from "MiNT" over "FreeMiNT" # to the lowercase version "mint" (or "freemint"). Finally # the system name "TOS" denotes a system which is actually not # MiNT. But MiNT is downward compatible to TOS, so this should # be no problem. atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) echo m68k-milan-mint${UNAME_RELEASE} exit ;; hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) echo m68k-hades-mint${UNAME_RELEASE} exit ;; *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) echo m68k-unknown-mint${UNAME_RELEASE} exit ;; m68k:machten:*:*) echo m68k-apple-machten${UNAME_RELEASE} exit ;; powerpc:machten:*:*) echo powerpc-apple-machten${UNAME_RELEASE} exit ;; RISC*:Mach:*:*) echo mips-dec-mach_bsd4.3 exit ;; RISC*:ULTRIX:*:*) echo mips-dec-ultrix${UNAME_RELEASE} exit ;; VAX*:ULTRIX*:*:*) echo vax-dec-ultrix${UNAME_RELEASE} exit ;; 2020:CLIX:*:* | 2430:CLIX:*:*) echo clipper-intergraph-clix${UNAME_RELEASE} exit ;; mips:*:*:UMIPS | mips:*:*:RISCos) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #ifdef __cplusplus #include /* for printf() prototype */ int main (int argc, char *argv[]) { #else int main (argc, argv) int argc; char *argv[]; { #endif #if defined (host_mips) && defined (MIPSEB) #if defined (SYSTYPE_SYSV) printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_SVR4) printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); #endif #endif exit (-1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && SYSTEM_NAME=`$dummy $dummyarg` && { echo "$SYSTEM_NAME"; exit; } echo mips-mips-riscos${UNAME_RELEASE} exit ;; Motorola:PowerMAX_OS:*:*) echo powerpc-motorola-powermax exit ;; Motorola:*:4.3:PL8-*) echo powerpc-harris-powermax exit ;; Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) echo powerpc-harris-powermax exit ;; Night_Hawk:Power_UNIX:*:*) echo powerpc-harris-powerunix exit ;; m88k:CX/UX:7*:*) echo m88k-harris-cxux7 exit ;; m88k:*:4*:R4*) echo m88k-motorola-sysv4 exit ;; m88k:*:3*:R3*) echo m88k-motorola-sysv3 exit ;; AViiON:dgux:*:*) # DG/UX returns AViiON for all architectures UNAME_PROCESSOR=`/usr/bin/uname -p` if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] then if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ [ ${TARGET_BINARY_INTERFACE}x = x ] then echo m88k-dg-dgux${UNAME_RELEASE} else echo m88k-dg-dguxbcs${UNAME_RELEASE} fi else echo i586-dg-dgux${UNAME_RELEASE} fi exit ;; M88*:DolphinOS:*:*) # DolphinOS (SVR3) echo m88k-dolphin-sysv3 exit ;; M88*:*:R3*:*) # Delta 88k system running SVR3 echo m88k-motorola-sysv3 exit ;; XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) echo m88k-tektronix-sysv3 exit ;; Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) echo m68k-tektronix-bsd exit ;; *:IRIX*:*:*) echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` exit ;; ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' i*86:AIX:*:*) echo i386-ibm-aix exit ;; ia64:AIX:*:*) if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} exit ;; *:AIX:2:3) if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include main() { if (!__power_pc()) exit(1); puts("powerpc-ibm-aix3.2.5"); exit(0); } EOF if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` then echo "$SYSTEM_NAME" else echo rs6000-ibm-aix3.2.5 fi elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then echo rs6000-ibm-aix3.2.4 else echo rs6000-ibm-aix3.2 fi exit ;; *:AIX:*:[4567]) IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then IBM_ARCH=rs6000 else IBM_ARCH=powerpc fi if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${IBM_ARCH}-ibm-aix${IBM_REV} exit ;; *:AIX:*:*) echo rs6000-ibm-aix exit ;; ibmrt:4.4BSD:*|romp-ibm:BSD:*) echo romp-ibm-bsd4.4 exit ;; ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to exit ;; # report: romp-ibm BSD 4.3 *:BOSX:*:*) echo rs6000-bull-bosx exit ;; DPX/2?00:B.O.S.:*:*) echo m68k-bull-sysv3 exit ;; 9000/[34]??:4.3bsd:1.*:*) echo m68k-hp-bsd exit ;; hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) echo m68k-hp-bsd4.4 exit ;; 9000/[34678]??:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` case "${UNAME_MACHINE}" in 9000/31? ) HP_ARCH=m68000 ;; 9000/[34]?? ) HP_ARCH=m68k ;; 9000/[678][0-9][0-9]) if [ -x /usr/bin/getconf ]; then sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` case "${sc_cpu_version}" in 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 532) # CPU_PA_RISC2_0 case "${sc_kernel_bits}" in 32) HP_ARCH="hppa2.0n" ;; 64) HP_ARCH="hppa2.0w" ;; '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 esac ;; esac fi if [ "${HP_ARCH}" = "" ]; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #define _HPUX_SOURCE #include #include int main () { #if defined(_SC_KERNEL_BITS) long bits = sysconf(_SC_KERNEL_BITS); #endif long cpu = sysconf (_SC_CPU_VERSION); switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0"); break; case CPU_PA_RISC1_1: puts ("hppa1.1"); break; case CPU_PA_RISC2_0: #if defined(_SC_KERNEL_BITS) switch (bits) { case 64: puts ("hppa2.0w"); break; case 32: puts ("hppa2.0n"); break; default: puts ("hppa2.0"); break; } break; #else /* !defined(_SC_KERNEL_BITS) */ puts ("hppa2.0"); break; #endif default: puts ("hppa1.0"); break; } exit (0); } EOF (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` test -z "$HP_ARCH" && HP_ARCH=hppa fi ;; esac if [ ${HP_ARCH} = "hppa2.0w" ] then eval $set_cc_for_build # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler # generating 64-bit code. GNU and HP use different nomenclature: # # $ CC_FOR_BUILD=cc ./config.guess # => hppa2.0w-hp-hpux11.23 # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess # => hppa64-hp-hpux11.23 if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | grep -q __LP64__ then HP_ARCH="hppa2.0w" else HP_ARCH="hppa64" fi fi echo ${HP_ARCH}-hp-hpux${HPUX_REV} exit ;; ia64:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` echo ia64-hp-hpux${HPUX_REV} exit ;; 3050*:HI-UX:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include int main () { long cpu = sysconf (_SC_CPU_VERSION); /* The order matters, because CPU_IS_HP_MC68K erroneously returns true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct results, however. */ if (CPU_IS_PA_RISC (cpu)) { switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; default: puts ("hppa-hitachi-hiuxwe2"); break; } } else if (CPU_IS_HP_MC68K (cpu)) puts ("m68k-hitachi-hiuxwe2"); else puts ("unknown-hitachi-hiuxwe2"); exit (0); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } echo unknown-hitachi-hiuxwe2 exit ;; 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) echo hppa1.1-hp-bsd exit ;; 9000/8??:4.3bsd:*:*) echo hppa1.0-hp-bsd exit ;; *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) echo hppa1.0-hp-mpeix exit ;; hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) echo hppa1.1-hp-osf exit ;; hp8??:OSF1:*:*) echo hppa1.0-hp-osf exit ;; i*86:OSF1:*:*) if [ -x /usr/sbin/sysversion ] ; then echo ${UNAME_MACHINE}-unknown-osf1mk else echo ${UNAME_MACHINE}-unknown-osf1 fi exit ;; parisc*:Lites*:*:*) echo hppa1.1-hp-lites exit ;; C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) echo c1-convex-bsd exit ;; C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) echo c34-convex-bsd exit ;; C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) echo c38-convex-bsd exit ;; C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) echo c4-convex-bsd exit ;; CRAY*Y-MP:*:*:*) echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*[A-Z]90:*:*:*) echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ -e 's/\.[^.]*$/.X/' exit ;; CRAY*TS:*:*:*) echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*T3E:*:*:*) echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*SV1:*:*:*) echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; *:UNICOS/mp:*:*) echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; 5000:UNIX_System_V:4.*:*) FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} exit ;; sparc*:BSD/OS:*:*) echo sparc-unknown-bsdi${UNAME_RELEASE} exit ;; *:BSD/OS:*:*) echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} exit ;; *:FreeBSD:*:*) UNAME_PROCESSOR=`/usr/bin/uname -p` case ${UNAME_PROCESSOR} in amd64) echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; *) echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; esac exit ;; i*:CYGWIN*:*) echo ${UNAME_MACHINE}-pc-cygwin exit ;; *:MINGW64*:*) echo ${UNAME_MACHINE}-pc-mingw64 exit ;; *:MINGW*:*) echo ${UNAME_MACHINE}-pc-mingw32 exit ;; *:MSYS*:*) echo ${UNAME_MACHINE}-pc-msys exit ;; i*:windows32*:*) # uname -m includes "-pc" on this system. echo ${UNAME_MACHINE}-mingw32 exit ;; i*:PW*:*) echo ${UNAME_MACHINE}-pc-pw32 exit ;; *:Interix*:*) case ${UNAME_MACHINE} in x86) echo i586-pc-interix${UNAME_RELEASE} exit ;; authenticamd | genuineintel | EM64T) echo x86_64-unknown-interix${UNAME_RELEASE} exit ;; IA64) echo ia64-unknown-interix${UNAME_RELEASE} exit ;; esac ;; [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) echo i${UNAME_MACHINE}-pc-mks exit ;; 8664:Windows_NT:*) echo x86_64-pc-mks exit ;; i*:Windows_NT*:* | Pentium*:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we # UNAME_MACHINE based on the output of uname instead of i386? echo i586-pc-interix exit ;; i*:UWIN*:*) echo ${UNAME_MACHINE}-pc-uwin exit ;; amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) echo x86_64-unknown-cygwin exit ;; p*:CYGWIN*:*) echo powerpcle-unknown-cygwin exit ;; prep*:SunOS:5.*:*) echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; *:GNU:*:*) # the GNU system echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-${LIBC}`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` exit ;; *:GNU/*:*:*) # other systems with GNU libc and userland echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC} exit ;; i*86:Minix:*:*) echo ${UNAME_MACHINE}-pc-minix exit ;; aarch64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; aarch64_be:Linux:*:*) UNAME_MACHINE=aarch64_be echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; alpha:Linux:*:*) case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in EV5) UNAME_MACHINE=alphaev5 ;; EV56) UNAME_MACHINE=alphaev56 ;; PCA56) UNAME_MACHINE=alphapca56 ;; PCA57) UNAME_MACHINE=alphapca56 ;; EV6) UNAME_MACHINE=alphaev6 ;; EV67) UNAME_MACHINE=alphaev67 ;; EV68*) UNAME_MACHINE=alphaev68 ;; esac objdump --private-headers /bin/sh | grep -q ld.so.1 if test "$?" = 0 ; then LIBC="gnulibc1" ; fi echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; arc:Linux:*:* | arceb:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; arm*:Linux:*:*) eval $set_cc_for_build if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_EABI__ then echo ${UNAME_MACHINE}-unknown-linux-${LIBC} else if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_PCS_VFP then echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabi else echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabihf fi fi exit ;; avr32*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; cris:Linux:*:*) echo ${UNAME_MACHINE}-axis-linux-${LIBC} exit ;; crisv32:Linux:*:*) echo ${UNAME_MACHINE}-axis-linux-${LIBC} exit ;; frv:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; hexagon:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; i*86:Linux:*:*) echo ${UNAME_MACHINE}-pc-linux-${LIBC} exit ;; ia64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; m32r*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; m68*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; mips:Linux:*:* | mips64:Linux:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #undef CPU #undef ${UNAME_MACHINE} #undef ${UNAME_MACHINE}el #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) CPU=${UNAME_MACHINE}el #else #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) CPU=${UNAME_MACHINE} #else CPU= #endif #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } ;; openrisc*:Linux:*:*) echo or1k-unknown-linux-${LIBC} exit ;; or32:Linux:*:* | or1k*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; padre:Linux:*:*) echo sparc-unknown-linux-${LIBC} exit ;; parisc64:Linux:*:* | hppa64:Linux:*:*) echo hppa64-unknown-linux-${LIBC} exit ;; parisc:Linux:*:* | hppa:Linux:*:*) # Look for CPU level case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in PA7*) echo hppa1.1-unknown-linux-${LIBC} ;; PA8*) echo hppa2.0-unknown-linux-${LIBC} ;; *) echo hppa-unknown-linux-${LIBC} ;; esac exit ;; ppc64:Linux:*:*) echo powerpc64-unknown-linux-${LIBC} exit ;; ppc:Linux:*:*) echo powerpc-unknown-linux-${LIBC} exit ;; ppc64le:Linux:*:*) echo powerpc64le-unknown-linux-${LIBC} exit ;; ppcle:Linux:*:*) echo powerpcle-unknown-linux-${LIBC} exit ;; s390:Linux:*:* | s390x:Linux:*:*) echo ${UNAME_MACHINE}-ibm-linux-${LIBC} exit ;; sh64*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; sh*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; sparc:Linux:*:* | sparc64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; tile*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; vax:Linux:*:*) echo ${UNAME_MACHINE}-dec-linux-${LIBC} exit ;; x86_64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; xtensa*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; i*86:DYNIX/ptx:4*:*) # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. # earlier versions are messed up and put the nodename in both # sysname and nodename. echo i386-sequent-sysv4 exit ;; i*86:UNIX_SV:4.2MP:2.*) # Unixware is an offshoot of SVR4, but it has its own version # number series starting with 2... # I am not positive that other SVR4 systems won't match this, # I just have to hope. -- rms. # Use sysv4.2uw... so that sysv4* matches it. echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} exit ;; i*86:OS/2:*:*) # If we were able to find `uname', then EMX Unix compatibility # is probably installed. echo ${UNAME_MACHINE}-pc-os2-emx exit ;; i*86:XTS-300:*:STOP) echo ${UNAME_MACHINE}-unknown-stop exit ;; i*86:atheos:*:*) echo ${UNAME_MACHINE}-unknown-atheos exit ;; i*86:syllable:*:*) echo ${UNAME_MACHINE}-pc-syllable exit ;; i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) echo i386-unknown-lynxos${UNAME_RELEASE} exit ;; i*86:*DOS:*:*) echo ${UNAME_MACHINE}-pc-msdosdjgpp exit ;; i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} else echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} fi exit ;; i*86:*:5:[678]*) # UnixWare 7.x, OpenUNIX and OpenServer 6. case `/bin/uname -X | grep "^Machine"` in *486*) UNAME_MACHINE=i486 ;; *Pentium) UNAME_MACHINE=i586 ;; *Pent*|*Celeron) UNAME_MACHINE=i686 ;; esac echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} exit ;; i*86:*:3.2:*) if test -f /usr/options/cb.name; then UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ && UNAME_MACHINE=i586 (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ && UNAME_MACHINE=i686 (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ && UNAME_MACHINE=i686 echo ${UNAME_MACHINE}-pc-sco$UNAME_REL else echo ${UNAME_MACHINE}-pc-sysv32 fi exit ;; pc:*:*:*) # Left here for compatibility: # uname -m prints for DJGPP always 'pc', but it prints nothing about # the processor, so we play safe by assuming i586. # Note: whatever this is, it MUST be the same as what config.sub # prints for the "djgpp" host, or else GDB configury will decide that # this is a cross-build. echo i586-pc-msdosdjgpp exit ;; Intel:Mach:3*:*) echo i386-pc-mach3 exit ;; paragon:*:*:*) echo i860-intel-osf1 exit ;; i860:*:4.*:*) # i860-SVR4 if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 else # Add other i860-SVR4 vendors below as they are discovered. echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 fi exit ;; mini*:CTIX:SYS*5:*) # "miniframe" echo m68010-convergent-sysv exit ;; mc68k:UNIX:SYSTEM5:3.51m) echo m68k-convergent-sysv exit ;; M680?0:D-NIX:5.3:*) echo m68k-diab-dnix exit ;; M68*:*:R3V[5678]*:*) test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) OS_REL='' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4; exit; } ;; NCR*:*:4.2:* | MPRAS*:*:4.2:*) OS_REL='.3' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) echo m68k-unknown-lynxos${UNAME_RELEASE} exit ;; mc68030:UNIX_System_V:4.*:*) echo m68k-atari-sysv4 exit ;; TSUNAMI:LynxOS:2.*:*) echo sparc-unknown-lynxos${UNAME_RELEASE} exit ;; rs6000:LynxOS:2.*:*) echo rs6000-unknown-lynxos${UNAME_RELEASE} exit ;; PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) echo powerpc-unknown-lynxos${UNAME_RELEASE} exit ;; SM[BE]S:UNIX_SV:*:*) echo mips-dde-sysv${UNAME_RELEASE} exit ;; RM*:ReliantUNIX-*:*:*) echo mips-sni-sysv4 exit ;; RM*:SINIX-*:*:*) echo mips-sni-sysv4 exit ;; *:SINIX-*:*:*) if uname -p 2>/dev/null >/dev/null ; then UNAME_MACHINE=`(uname -p) 2>/dev/null` echo ${UNAME_MACHINE}-sni-sysv4 else echo ns32k-sni-sysv fi exit ;; PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort # says echo i586-unisys-sysv4 exit ;; *:UNIX_System_V:4*:FTX*) # From Gerald Hewes . # How about differentiating between stratus architectures? -djm echo hppa1.1-stratus-sysv4 exit ;; *:*:*:FTX*) # From seanf@swdc.stratus.com. echo i860-stratus-sysv4 exit ;; i*86:VOS:*:*) # From Paul.Green@stratus.com. echo ${UNAME_MACHINE}-stratus-vos exit ;; *:VOS:*:*) # From Paul.Green@stratus.com. echo hppa1.1-stratus-vos exit ;; mc68*:A/UX:*:*) echo m68k-apple-aux${UNAME_RELEASE} exit ;; news*:NEWS-OS:6*:*) echo mips-sony-newsos6 exit ;; R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) if [ -d /usr/nec ]; then echo mips-nec-sysv${UNAME_RELEASE} else echo mips-unknown-sysv${UNAME_RELEASE} fi exit ;; BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. echo powerpc-be-beos exit ;; BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. echo powerpc-apple-beos exit ;; BePC:BeOS:*:*) # BeOS running on Intel PC compatible. echo i586-pc-beos exit ;; BePC:Haiku:*:*) # Haiku running on Intel PC compatible. echo i586-pc-haiku exit ;; x86_64:Haiku:*:*) echo x86_64-unknown-haiku exit ;; SX-4:SUPER-UX:*:*) echo sx4-nec-superux${UNAME_RELEASE} exit ;; SX-5:SUPER-UX:*:*) echo sx5-nec-superux${UNAME_RELEASE} exit ;; SX-6:SUPER-UX:*:*) echo sx6-nec-superux${UNAME_RELEASE} exit ;; SX-7:SUPER-UX:*:*) echo sx7-nec-superux${UNAME_RELEASE} exit ;; SX-8:SUPER-UX:*:*) echo sx8-nec-superux${UNAME_RELEASE} exit ;; SX-8R:SUPER-UX:*:*) echo sx8r-nec-superux${UNAME_RELEASE} exit ;; Power*:Rhapsody:*:*) echo powerpc-apple-rhapsody${UNAME_RELEASE} exit ;; *:Rhapsody:*:*) echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} exit ;; *:Darwin:*:*) UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown eval $set_cc_for_build if test "$UNAME_PROCESSOR" = unknown ; then UNAME_PROCESSOR=powerpc fi if test `echo "$UNAME_RELEASE" | sed -e 's/\..*//'` -le 10 ; then if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then case $UNAME_PROCESSOR in i386) UNAME_PROCESSOR=x86_64 ;; powerpc) UNAME_PROCESSOR=powerpc64 ;; esac fi fi elif test "$UNAME_PROCESSOR" = i386 ; then # Avoid executing cc on OS X 10.9, as it ships with a stub # that puts up a graphical alert prompting to install # developer tools. Any system running Mac OS X 10.7 or # later (Darwin 11 and later) is required to have a 64-bit # processor. This is not true of the ARM version of Darwin # that Apple uses in portable devices. UNAME_PROCESSOR=x86_64 fi echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} exit ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) UNAME_PROCESSOR=`uname -p` if test "$UNAME_PROCESSOR" = "x86"; then UNAME_PROCESSOR=i386 UNAME_MACHINE=pc fi echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} exit ;; *:QNX:*:4*) echo i386-pc-qnx exit ;; NEO-?:NONSTOP_KERNEL:*:*) echo neo-tandem-nsk${UNAME_RELEASE} exit ;; NSE-*:NONSTOP_KERNEL:*:*) echo nse-tandem-nsk${UNAME_RELEASE} exit ;; NSR-?:NONSTOP_KERNEL:*:*) echo nsr-tandem-nsk${UNAME_RELEASE} exit ;; *:NonStop-UX:*:*) echo mips-compaq-nonstopux exit ;; BS2000:POSIX*:*:*) echo bs2000-siemens-sysv exit ;; DS/*:UNIX_System_V:*:*) echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} exit ;; *:Plan9:*:*) # "uname -m" is not consistent, so use $cputype instead. 386 # is converted to i386 for consistency with other x86 # operating systems. if test "$cputype" = "386"; then UNAME_MACHINE=i386 else UNAME_MACHINE="$cputype" fi echo ${UNAME_MACHINE}-unknown-plan9 exit ;; *:TOPS-10:*:*) echo pdp10-unknown-tops10 exit ;; *:TENEX:*:*) echo pdp10-unknown-tenex exit ;; KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) echo pdp10-dec-tops20 exit ;; XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) echo pdp10-xkl-tops20 exit ;; *:TOPS-20:*:*) echo pdp10-unknown-tops20 exit ;; *:ITS:*:*) echo pdp10-unknown-its exit ;; SEI:*:*:SEIUX) echo mips-sei-seiux${UNAME_RELEASE} exit ;; *:DragonFly:*:*) echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` exit ;; *:*VMS:*:*) UNAME_MACHINE=`(uname -p) 2>/dev/null` case "${UNAME_MACHINE}" in A*) echo alpha-dec-vms ; exit ;; I*) echo ia64-dec-vms ; exit ;; V*) echo vax-dec-vms ; exit ;; esac ;; *:XENIX:*:SysV) echo i386-pc-xenix exit ;; i*86:skyos:*:*) echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' exit ;; i*86:rdos:*:*) echo ${UNAME_MACHINE}-pc-rdos exit ;; i*86:AROS:*:*) echo ${UNAME_MACHINE}-pc-aros exit ;; x86_64:VMkernel:*:*) echo ${UNAME_MACHINE}-unknown-esx exit ;; esac cat >&2 < in order to provide the needed information to handle your system. config.guess timestamp = $timestamp uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` /bin/uname -X = `(/bin/uname -X) 2>/dev/null` hostinfo = `(hostinfo) 2>/dev/null` /bin/universe = `(/bin/universe) 2>/dev/null` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` /bin/arch = `(/bin/arch) 2>/dev/null` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` UNAME_MACHINE = ${UNAME_MACHINE} UNAME_RELEASE = ${UNAME_RELEASE} UNAME_SYSTEM = ${UNAME_SYSTEM} UNAME_VERSION = ${UNAME_VERSION} EOF exit 1 # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: gcl/config.sub000077500000000000000000001056341242227143400136200ustar00rootroot00000000000000#! /bin/sh # Configuration validation subroutine script. # Copyright 1992-2014 Free Software Foundation, Inc. timestamp='2014-05-01' # This file 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 . # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that # program. This Exception is an additional permission under section 7 # of the GNU General Public License, version 3 ("GPLv3"). # Please send patches with a ChangeLog entry to config-patches@gnu.org. # # Configuration subroutine to validate and canonicalize a configuration type. # Supply the specified configuration type as an argument. # If it is invalid, we print an error message on stderr and exit with code 1. # Otherwise, we print the canonical config type on stdout and succeed. # You can get the latest version of this script from: # http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD # This file is supposed to be the same for all GNU packages # and recognize all the CPU types, system types and aliases # that are meaningful with *any* GNU software. # Each package is responsible for reporting which valid configurations # it does not support. The user should be able to distinguish # a failure to support a valid configuration from a meaningless # configuration. # The goal of this file is to map all the various variations of a given # machine specification into a single specification in the form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM # or in some cases, the newer four-part form: # CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM # It is wrong to echo any other type of specification. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] CPU-MFR-OPSYS $0 [OPTION] ALIAS Canonicalize a configuration name. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.sub ($timestamp) Copyright 1992-2014 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" exit 1 ;; *local*) # First pass through any local machine types. echo $1 exit ;; * ) break ;; esac done case $# in 0) echo "$me: missing argument$help" >&2 exit 1;; 1) ;; *) echo "$me: too many arguments$help" >&2 exit 1;; esac # Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). # Here we must recognize all the valid KERNEL-OS combinations. maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` case $maybe_os in nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ knetbsd*-gnu* | netbsd*-gnu* | \ kopensolaris*-gnu* | \ storm-chaos* | os2-emx* | rtmk-nova*) os=-$maybe_os basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` ;; android-linux) os=-linux-android basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown ;; *) basic_machine=`echo $1 | sed 's/-[^-]*$//'` if [ $basic_machine != $1 ] then os=`echo $1 | sed 's/.*-/-/'` else os=; fi ;; esac ### Let's recognize common machines as not being operating systems so ### that things like config.sub decstation-3100 work. We also ### recognize some manufacturers as not being operating systems, so we ### can provide default operating systems below. case $os in -sun*os*) # Prevent following clause from handling this invalid input. ;; -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ -apple | -axis | -knuth | -cray | -microblaze*) os= basic_machine=$1 ;; -bluegene*) os=-cnk ;; -sim | -cisco | -oki | -wec | -winbond) os= basic_machine=$1 ;; -scout) ;; -wrs) os=-vxworks basic_machine=$1 ;; -chorusos*) os=-chorusos basic_machine=$1 ;; -chorusrdb) os=-chorusrdb basic_machine=$1 ;; -hiux*) os=-hiuxwe2 ;; -sco6) os=-sco5v6 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco5) os=-sco3.2v5 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco4) os=-sco3.2v4 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2.[4-9]*) os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2v[4-9]*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco5v6*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco*) os=-sco3.2v2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -udk*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -isc) os=-isc2.2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -clix*) basic_machine=clipper-intergraph ;; -isc*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -lynx*178) os=-lynxos178 ;; -lynx*5) os=-lynxos5 ;; -lynx*) os=-lynxos ;; -ptx*) basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` ;; -windowsnt*) os=`echo $os | sed -e 's/windowsnt/winnt/'` ;; -psos*) os=-psos ;; -mint | -mint[0-9]*) basic_machine=m68k-atari os=-mint ;; esac # Decode aliases for certain CPU-COMPANY combinations. case $basic_machine in # Recognize the basic CPU types without company name. # Some are omitted here because they have special meanings below. 1750a | 580 \ | a29k \ | aarch64 | aarch64_be \ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ | am33_2.0 \ | arc | arceb \ | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \ | avr | avr32 \ | be32 | be64 \ | bfin \ | c4x | c8051 | clipper \ | d10v | d30v | dlx | dsp16xx \ | epiphany \ | fido | fr30 | frv \ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ | hexagon \ | i370 | i860 | i960 | ia64 \ | ip2k | iq2000 \ | k1om \ | le32 | le64 \ | lm32 \ | m32c | m32r | m32rle | m68000 | m68k | m88k \ | maxq | mb | microblaze | microblazeel | mcore | mep | metag \ | mips | mipsbe | mipseb | mipsel | mipsle \ | mips16 \ | mips64 | mips64el \ | mips64octeon | mips64octeonel \ | mips64orion | mips64orionel \ | mips64r5900 | mips64r5900el \ | mips64vr | mips64vrel \ | mips64vr4100 | mips64vr4100el \ | mips64vr4300 | mips64vr4300el \ | mips64vr5000 | mips64vr5000el \ | mips64vr5900 | mips64vr5900el \ | mipsisa32 | mipsisa32el \ | mipsisa32r2 | mipsisa32r2el \ | mipsisa32r6 | mipsisa32r6el \ | mipsisa64 | mipsisa64el \ | mipsisa64r2 | mipsisa64r2el \ | mipsisa64r6 | mipsisa64r6el \ | mipsisa64sb1 | mipsisa64sb1el \ | mipsisa64sr71k | mipsisa64sr71kel \ | mipsr5900 | mipsr5900el \ | mipstx39 | mipstx39el \ | mn10200 | mn10300 \ | moxie \ | mt \ | msp430 \ | nds32 | nds32le | nds32be \ | nios | nios2 | nios2eb | nios2el \ | ns16k | ns32k \ | open8 | or1k | or1knd | or32 \ | pdp10 | pdp11 | pj | pjl \ | powerpc | powerpc64 | powerpc64le | powerpcle \ | pyramid \ | rl78 | rx \ | score \ | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ | sh64 | sh64le \ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ | spu \ | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ | ubicom32 \ | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ | we32k \ | x86 | xc16x | xstormy16 | xtensa \ | z8k | z80) basic_machine=$basic_machine-unknown ;; c54x) basic_machine=tic54x-unknown ;; c55x) basic_machine=tic55x-unknown ;; c6x) basic_machine=tic6x-unknown ;; m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip) basic_machine=$basic_machine-unknown os=-none ;; m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) ;; ms1) basic_machine=mt-unknown ;; strongarm | thumb | xscale) basic_machine=arm-unknown ;; xgate) basic_machine=$basic_machine-unknown os=-none ;; xscaleeb) basic_machine=armeb-unknown ;; xscaleel) basic_machine=armel-unknown ;; # We use `pc' rather than `unknown' # because (1) that's what they normally are, and # (2) the word "unknown" tends to confuse beginning users. i*86 | x86_64) basic_machine=$basic_machine-pc ;; # Object if more than one company name word. *-*-*) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; # Recognize the basic CPU types with company name. 580-* \ | a29k-* \ | aarch64-* | aarch64_be-* \ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ | avr-* | avr32-* \ | be32-* | be64-* \ | bfin-* | bs2000-* \ | c[123]* | c30-* | [cjt]90-* | c4x-* \ | c8051-* | clipper-* | craynv-* | cydra-* \ | d10v-* | d30v-* | dlx-* \ | elxsi-* \ | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ | h8300-* | h8500-* \ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ | hexagon-* \ | i*86-* | i860-* | i960-* | ia64-* \ | ip2k-* | iq2000-* \ | k1om-* \ | le32-* | le64-* \ | lm32-* \ | m32c-* | m32r-* | m32rle-* \ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \ | microblaze-* | microblazeel-* \ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ | mips16-* \ | mips64-* | mips64el-* \ | mips64octeon-* | mips64octeonel-* \ | mips64orion-* | mips64orionel-* \ | mips64r5900-* | mips64r5900el-* \ | mips64vr-* | mips64vrel-* \ | mips64vr4100-* | mips64vr4100el-* \ | mips64vr4300-* | mips64vr4300el-* \ | mips64vr5000-* | mips64vr5000el-* \ | mips64vr5900-* | mips64vr5900el-* \ | mipsisa32-* | mipsisa32el-* \ | mipsisa32r2-* | mipsisa32r2el-* \ | mipsisa32r6-* | mipsisa32r6el-* \ | mipsisa64-* | mipsisa64el-* \ | mipsisa64r2-* | mipsisa64r2el-* \ | mipsisa64r6-* | mipsisa64r6el-* \ | mipsisa64sb1-* | mipsisa64sb1el-* \ | mipsisa64sr71k-* | mipsisa64sr71kel-* \ | mipsr5900-* | mipsr5900el-* \ | mipstx39-* | mipstx39el-* \ | mmix-* \ | mt-* \ | msp430-* \ | nds32-* | nds32le-* | nds32be-* \ | nios-* | nios2-* | nios2eb-* | nios2el-* \ | none-* | np1-* | ns16k-* | ns32k-* \ | open8-* \ | or1k*-* \ | orion-* \ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ | pyramid-* \ | rl78-* | romp-* | rs6000-* | rx-* \ | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ | sparclite-* \ | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx?-* \ | tahoe-* \ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ | tile*-* \ | tron-* \ | ubicom32-* \ | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ | vax-* \ | we32k-* \ | x86-* | x86_64-* | xc16x-* | xps100-* \ | xstormy16-* | xtensa*-* \ | ymp-* \ | z8k-* | z80-*) ;; # Recognize the basic CPU types without company name, with glob match. xtensa*) basic_machine=$basic_machine-unknown ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. 386bsd) basic_machine=i386-unknown os=-bsd ;; 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) basic_machine=m68000-att ;; 3b*) basic_machine=we32k-att ;; a29khif) basic_machine=a29k-amd os=-udi ;; abacus) basic_machine=abacus-unknown ;; adobe68k) basic_machine=m68010-adobe os=-scout ;; alliant | fx80) basic_machine=fx80-alliant ;; altos | altos3068) basic_machine=m68k-altos ;; am29k) basic_machine=a29k-none os=-bsd ;; amd64) basic_machine=x86_64-pc ;; amd64-*) basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; amdahl) basic_machine=580-amdahl os=-sysv ;; amiga | amiga-*) basic_machine=m68k-unknown ;; amigaos | amigados) basic_machine=m68k-unknown os=-amigaos ;; amigaunix | amix) basic_machine=m68k-unknown os=-sysv4 ;; apollo68) basic_machine=m68k-apollo os=-sysv ;; apollo68bsd) basic_machine=m68k-apollo os=-bsd ;; aros) basic_machine=i386-pc os=-aros ;; aux) basic_machine=m68k-apple os=-aux ;; balance) basic_machine=ns32k-sequent os=-dynix ;; blackfin) basic_machine=bfin-unknown os=-linux ;; blackfin-*) basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; bluegene*) basic_machine=powerpc-ibm os=-cnk ;; c54x-*) basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` ;; c55x-*) basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` ;; c6x-*) basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` ;; c90) basic_machine=c90-cray os=-unicos ;; cegcc) basic_machine=arm-unknown os=-cegcc ;; convex-c1) basic_machine=c1-convex os=-bsd ;; convex-c2) basic_machine=c2-convex os=-bsd ;; convex-c32) basic_machine=c32-convex os=-bsd ;; convex-c34) basic_machine=c34-convex os=-bsd ;; convex-c38) basic_machine=c38-convex os=-bsd ;; cray | j90) basic_machine=j90-cray os=-unicos ;; craynv) basic_machine=craynv-cray os=-unicosmp ;; cr16 | cr16-*) basic_machine=cr16-unknown os=-elf ;; crds | unos) basic_machine=m68k-crds ;; crisv32 | crisv32-* | etraxfs*) basic_machine=crisv32-axis ;; cris | cris-* | etrax*) basic_machine=cris-axis ;; crx) basic_machine=crx-unknown os=-elf ;; da30 | da30-*) basic_machine=m68k-da30 ;; decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) basic_machine=mips-dec ;; decsystem10* | dec10*) basic_machine=pdp10-dec os=-tops10 ;; decsystem20* | dec20*) basic_machine=pdp10-dec os=-tops20 ;; delta | 3300 | motorola-3300 | motorola-delta \ | 3300-motorola | delta-motorola) basic_machine=m68k-motorola ;; delta88) basic_machine=m88k-motorola os=-sysv3 ;; dicos) basic_machine=i686-pc os=-dicos ;; djgpp) basic_machine=i586-pc os=-msdosdjgpp ;; dpx20 | dpx20-*) basic_machine=rs6000-bull os=-bosx ;; dpx2* | dpx2*-bull) basic_machine=m68k-bull os=-sysv3 ;; ebmon29k) basic_machine=a29k-amd os=-ebmon ;; elxsi) basic_machine=elxsi-elxsi os=-bsd ;; encore | umax | mmax) basic_machine=ns32k-encore ;; es1800 | OSE68k | ose68k | ose | OSE) basic_machine=m68k-ericsson os=-ose ;; fx2800) basic_machine=i860-alliant ;; genix) basic_machine=ns32k-ns ;; gmicro) basic_machine=tron-gmicro os=-sysv ;; go32) basic_machine=i386-pc os=-go32 ;; h3050r* | hiux*) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; h8300hms) basic_machine=h8300-hitachi os=-hms ;; h8300xray) basic_machine=h8300-hitachi os=-xray ;; h8500hms) basic_machine=h8500-hitachi os=-hms ;; harris) basic_machine=m88k-harris os=-sysv3 ;; hp300-*) basic_machine=m68k-hp ;; hp300bsd) basic_machine=m68k-hp os=-bsd ;; hp300hpux) basic_machine=m68k-hp os=-hpux ;; hp3k9[0-9][0-9] | hp9[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k2[0-9][0-9] | hp9k31[0-9]) basic_machine=m68000-hp ;; hp9k3[2-9][0-9]) basic_machine=m68k-hp ;; hp9k6[0-9][0-9] | hp6[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k7[0-79][0-9] | hp7[0-79][0-9]) basic_machine=hppa1.1-hp ;; hp9k78[0-9] | hp78[0-9]) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[0-9][13679] | hp8[0-9][13679]) basic_machine=hppa1.1-hp ;; hp9k8[0-9][0-9] | hp8[0-9][0-9]) basic_machine=hppa1.0-hp ;; hppa-next) os=-nextstep3 ;; hppaosf) basic_machine=hppa1.1-hp os=-osf ;; hppro) basic_machine=hppa1.1-hp os=-proelf ;; i370-ibm* | ibm*) basic_machine=i370-ibm ;; i*86v32) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv32 ;; i*86v4*) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv4 ;; i*86v) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv ;; i*86sol2) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-solaris2 ;; i386mach) basic_machine=i386-mach os=-mach ;; i386-vsta | vsta) basic_machine=i386-unknown os=-vsta ;; iris | iris4d) basic_machine=mips-sgi case $os in -irix*) ;; *) os=-irix4 ;; esac ;; isi68 | isi) basic_machine=m68k-isi os=-sysv ;; m68knommu) basic_machine=m68k-unknown os=-linux ;; m68knommu-*) basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; m88k-omron*) basic_machine=m88k-omron ;; magnum | m3230) basic_machine=mips-mips os=-sysv ;; merlin) basic_machine=ns32k-utek os=-sysv ;; microblaze*) basic_machine=microblaze-xilinx ;; mingw64) basic_machine=x86_64-pc os=-mingw64 ;; mingw32) basic_machine=i686-pc os=-mingw32 ;; mingw32ce) basic_machine=arm-unknown os=-mingw32ce ;; miniframe) basic_machine=m68000-convergent ;; *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) basic_machine=m68k-atari os=-mint ;; mips3*-*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` ;; mips3*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown ;; monitor) basic_machine=m68k-rom68k os=-coff ;; morphos) basic_machine=powerpc-unknown os=-morphos ;; msdos) basic_machine=i386-pc os=-msdos ;; ms1-*) basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` ;; msys) basic_machine=i686-pc os=-msys ;; mvs) basic_machine=i370-ibm os=-mvs ;; nacl) basic_machine=le32-unknown os=-nacl ;; ncr3000) basic_machine=i486-ncr os=-sysv4 ;; netbsd386) basic_machine=i386-unknown os=-netbsd ;; netwinder) basic_machine=armv4l-rebel os=-linux ;; news | news700 | news800 | news900) basic_machine=m68k-sony os=-newsos ;; news1000) basic_machine=m68030-sony os=-newsos ;; news-3600 | risc-news) basic_machine=mips-sony os=-newsos ;; necv70) basic_machine=v70-nec os=-sysv ;; next | m*-next ) basic_machine=m68k-next case $os in -nextstep* ) ;; -ns2*) os=-nextstep2 ;; *) os=-nextstep3 ;; esac ;; nh3000) basic_machine=m68k-harris os=-cxux ;; nh[45]000) basic_machine=m88k-harris os=-cxux ;; nindy960) basic_machine=i960-intel os=-nindy ;; mon960) basic_machine=i960-intel os=-mon960 ;; nonstopux) basic_machine=mips-compaq os=-nonstopux ;; np1) basic_machine=np1-gould ;; neo-tandem) basic_machine=neo-tandem ;; nse-tandem) basic_machine=nse-tandem ;; nsr-tandem) basic_machine=nsr-tandem ;; op50n-* | op60c-*) basic_machine=hppa1.1-oki os=-proelf ;; openrisc | openrisc-*) basic_machine=or32-unknown ;; os400) basic_machine=powerpc-ibm os=-os400 ;; OSE68000 | ose68000) basic_machine=m68000-ericsson os=-ose ;; os68k) basic_machine=m68k-none os=-os68k ;; pa-hitachi) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; paragon) basic_machine=i860-intel os=-osf ;; parisc) basic_machine=hppa-unknown os=-linux ;; parisc-*) basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; pbd) basic_machine=sparc-tti ;; pbb) basic_machine=m68k-tti ;; pc532 | pc532-*) basic_machine=ns32k-pc532 ;; pc98) basic_machine=i386-pc ;; pc98-*) basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentium | p5 | k5 | k6 | nexgen | viac3) basic_machine=i586-pc ;; pentiumpro | p6 | 6x86 | athlon | athlon_*) basic_machine=i686-pc ;; pentiumii | pentium2 | pentiumiii | pentium3) basic_machine=i686-pc ;; pentium4) basic_machine=i786-pc ;; pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumpro-* | p6-* | 6x86-* | athlon-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentium4-*) basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pn) basic_machine=pn-gould ;; power) basic_machine=power-ibm ;; ppc | ppcbe) basic_machine=powerpc-unknown ;; ppc-* | ppcbe-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppcle | powerpclittle | ppc-le | powerpc-little) basic_machine=powerpcle-unknown ;; ppcle-* | powerpclittle-*) basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64) basic_machine=powerpc64-unknown ;; ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64le | powerpc64little | ppc64-le | powerpc64-little) basic_machine=powerpc64le-unknown ;; ppc64le-* | powerpc64little-*) basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ps2) basic_machine=i386-ibm ;; pw32) basic_machine=i586-unknown os=-pw32 ;; rdos | rdos64) basic_machine=x86_64-pc os=-rdos ;; rdos32) basic_machine=i386-pc os=-rdos ;; rom68k) basic_machine=m68k-rom68k os=-coff ;; rm[46]00) basic_machine=mips-siemens ;; rtpc | rtpc-*) basic_machine=romp-ibm ;; s390 | s390-*) basic_machine=s390-ibm ;; s390x | s390x-*) basic_machine=s390x-ibm ;; sa29200) basic_machine=a29k-amd os=-udi ;; sb1) basic_machine=mipsisa64sb1-unknown ;; sb1el) basic_machine=mipsisa64sb1el-unknown ;; sde) basic_machine=mipsisa32-sde os=-elf ;; sei) basic_machine=mips-sei os=-seiux ;; sequent) basic_machine=i386-sequent ;; sh) basic_machine=sh-hitachi os=-hms ;; sh5el) basic_machine=sh5le-unknown ;; sh64) basic_machine=sh64-unknown ;; sparclite-wrs | simso-wrs) basic_machine=sparclite-wrs os=-vxworks ;; sps7) basic_machine=m68k-bull os=-sysv2 ;; spur) basic_machine=spur-unknown ;; st2000) basic_machine=m68k-tandem ;; stratus) basic_machine=i860-stratus os=-sysv4 ;; strongarm-* | thumb-*) basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` ;; sun2) basic_machine=m68000-sun ;; sun2os3) basic_machine=m68000-sun os=-sunos3 ;; sun2os4) basic_machine=m68000-sun os=-sunos4 ;; sun3os3) basic_machine=m68k-sun os=-sunos3 ;; sun3os4) basic_machine=m68k-sun os=-sunos4 ;; sun4os3) basic_machine=sparc-sun os=-sunos3 ;; sun4os4) basic_machine=sparc-sun os=-sunos4 ;; sun4sol2) basic_machine=sparc-sun os=-solaris2 ;; sun3 | sun3-*) basic_machine=m68k-sun ;; sun4) basic_machine=sparc-sun ;; sun386 | sun386i | roadrunner) basic_machine=i386-sun ;; sv1) basic_machine=sv1-cray os=-unicos ;; symmetry) basic_machine=i386-sequent os=-dynix ;; t3e) basic_machine=alphaev5-cray os=-unicos ;; t90) basic_machine=t90-cray os=-unicos ;; tile*) basic_machine=$basic_machine-unknown os=-linux-gnu ;; tx39) basic_machine=mipstx39-unknown ;; tx39el) basic_machine=mipstx39el-unknown ;; toad1) basic_machine=pdp10-xkl os=-tops20 ;; tower | tower-32) basic_machine=m68k-ncr ;; tpf) basic_machine=s390x-ibm os=-tpf ;; udi29k) basic_machine=a29k-amd os=-udi ;; ultra3) basic_machine=a29k-nyu os=-sym1 ;; v810 | necv810) basic_machine=v810-nec os=-none ;; vaxv) basic_machine=vax-dec os=-sysv ;; vms) basic_machine=vax-dec os=-vms ;; vpp*|vx|vx-*) basic_machine=f301-fujitsu ;; vxworks960) basic_machine=i960-wrs os=-vxworks ;; vxworks68) basic_machine=m68k-wrs os=-vxworks ;; vxworks29k) basic_machine=a29k-wrs os=-vxworks ;; w65*) basic_machine=w65-wdc os=-none ;; w89k-*) basic_machine=hppa1.1-winbond os=-proelf ;; xbox) basic_machine=i686-pc os=-mingw32 ;; xps | xps100) basic_machine=xps100-honeywell ;; xscale-* | xscalee[bl]-*) basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` ;; ymp) basic_machine=ymp-cray os=-unicos ;; z8k-*-coff) basic_machine=z8k-unknown os=-sim ;; z80-*-coff) basic_machine=z80-unknown os=-sim ;; none) basic_machine=none-none os=-none ;; # Here we handle the default manufacturer of certain CPU types. It is in # some cases the only manufacturer, in others, it is the most popular. w89k) basic_machine=hppa1.1-winbond ;; op50n) basic_machine=hppa1.1-oki ;; op60c) basic_machine=hppa1.1-oki ;; romp) basic_machine=romp-ibm ;; mmix) basic_machine=mmix-knuth ;; rs6000) basic_machine=rs6000-ibm ;; vax) basic_machine=vax-dec ;; pdp10) # there are many clones, so DEC is not a safe bet basic_machine=pdp10-unknown ;; pdp11) basic_machine=pdp11-dec ;; we32k) basic_machine=we32k-att ;; sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) basic_machine=sh-unknown ;; sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) basic_machine=sparc-sun ;; cydra) basic_machine=cydra-cydrome ;; orion) basic_machine=orion-highlevel ;; orion105) basic_machine=clipper-highlevel ;; mac | mpw | mac-mpw) basic_machine=m68k-apple ;; pmac | pmac-mpw) basic_machine=powerpc-apple ;; *-unknown) # Make sure to match an already-canonicalized machine name. ;; *) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; esac # Here we canonicalize certain aliases for manufacturers. case $basic_machine in *-digital*) basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` ;; *-commodore*) basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` ;; *) ;; esac # Decode manufacturer-specific aliases for certain operating systems. if [ x"$os" != x"" ] then case $os in # First match some system type aliases # that might get confused with valid system types. # -solaris* is a basic system type, with this one exception. -auroraux) os=-auroraux ;; -solaris1 | -solaris1.*) os=`echo $os | sed -e 's|solaris1|sunos4|'` ;; -solaris) os=-solaris2 ;; -svr4*) os=-sysv4 ;; -unixware*) os=-sysv4.2uw ;; -gnu/linux*) os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` ;; # First accept the basic system types. # The portable systems comes first. # Each alternative MUST END IN A *, to match a version number. # -sysv* is not here because it comes later, after sysvr4. -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ | -sym* | -kopensolaris* | -plan9* \ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ | -aos* | -aros* \ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ | -bitrig* | -openbsd* | -solidbsd* \ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ | -chorusos* | -chorusrdb* | -cegcc* \ | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ | -linux-newlib* | -linux-musl* | -linux-uclibc* \ | -uxpv* | -beos* | -mpeix* | -udk* \ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es* | -tirtos*) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*) case $basic_machine in x86-* | i*86-*) ;; *) os=-nto$os ;; esac ;; -nto-qnx*) ;; -nto*) os=`echo $os | sed -e 's|nto|nto-qnx|'` ;; -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) ;; -mac*) os=`echo $os | sed -e 's|mac|macos|'` ;; -linux-dietlibc) os=-linux-dietlibc ;; -linux*) os=`echo $os | sed -e 's|linux|linux-gnu|'` ;; -sunos5*) os=`echo $os | sed -e 's|sunos5|solaris2|'` ;; -sunos6*) os=`echo $os | sed -e 's|sunos6|solaris3|'` ;; -opened*) os=-openedition ;; -os400*) os=-os400 ;; -wince*) os=-wince ;; -osfrose*) os=-osfrose ;; -osf*) os=-osf ;; -utek*) os=-bsd ;; -dynix*) os=-bsd ;; -acis*) os=-aos ;; -atheos*) os=-atheos ;; -syllable*) os=-syllable ;; -386bsd) os=-bsd ;; -ctix* | -uts*) os=-sysv ;; -nova*) os=-rtmk-nova ;; -ns2 ) os=-nextstep2 ;; -nsk*) os=-nsk ;; # Preserve the version number of sinix5. -sinix5.*) os=`echo $os | sed -e 's|sinix|sysv|'` ;; -sinix*) os=-sysv4 ;; -tpf*) os=-tpf ;; -triton*) os=-sysv3 ;; -oss*) os=-sysv3 ;; -svr4) os=-sysv4 ;; -svr3) os=-sysv3 ;; -sysvr4) os=-sysv4 ;; # This must come after -sysvr4. -sysv*) ;; -ose*) os=-ose ;; -es1800*) os=-ose ;; -xenix) os=-xenix ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) os=-mint ;; -aros*) os=-aros ;; -zvmoe) os=-zvmoe ;; -dicos*) os=-dicos ;; -nacl*) ;; -none) ;; *) # Get rid of the `-' at the beginning of $os. os=`echo $os | sed 's/[^-]*-//'` echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 exit 1 ;; esac else # Here we handle the default operating systems that come with various machines. # The value should be what the vendor currently ships out the door with their # machine or put another way, the most popular os provided with the machine. # Note that if you're going to try to match "-MANUFACTURER" here (say, # "-sun"), then you have to tell the case statement up towards the top # that MANUFACTURER isn't an operating system. Otherwise, code above # will signal an error saying that MANUFACTURER isn't an operating # system, and we'll never get to this point. case $basic_machine in score-*) os=-elf ;; spu-*) os=-elf ;; *-acorn) os=-riscix1.2 ;; arm*-rebel) os=-linux ;; arm*-semi) os=-aout ;; c4x-* | tic4x-*) os=-coff ;; c8051-*) os=-elf ;; hexagon-*) os=-elf ;; tic54x-*) os=-coff ;; tic55x-*) os=-coff ;; tic6x-*) os=-coff ;; # This must come before the *-dec entry. pdp10-*) os=-tops20 ;; pdp11-*) os=-none ;; *-dec | vax-*) os=-ultrix4.2 ;; m68*-apollo) os=-domain ;; i386-sun) os=-sunos4.0.2 ;; m68000-sun) os=-sunos3 ;; m68*-cisco) os=-aout ;; mep-*) os=-elf ;; mips*-cisco) os=-elf ;; mips*-*) os=-elf ;; or32-*) os=-coff ;; *-tti) # must be before sparc entry or we get the wrong os. os=-sysv3 ;; sparc-* | *-sun) os=-sunos4.1.1 ;; *-be) os=-beos ;; *-haiku) os=-haiku ;; *-ibm) os=-aix ;; *-knuth) os=-mmixware ;; *-wec) os=-proelf ;; *-winbond) os=-proelf ;; *-oki) os=-proelf ;; *-hp) os=-hpux ;; *-hitachi) os=-hiux ;; i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) os=-sysv ;; *-cbm) os=-amigaos ;; *-dg) os=-dgux ;; *-dolphin) os=-sysv3 ;; m68k-ccur) os=-rtu ;; m88k-omron*) os=-luna ;; *-next ) os=-nextstep ;; *-sequent) os=-ptx ;; *-crds) os=-unos ;; *-ns) os=-genix ;; i370-*) os=-mvs ;; *-next) os=-nextstep3 ;; *-gould) os=-sysv ;; *-highlevel) os=-bsd ;; *-encore) os=-bsd ;; *-sgi) os=-irix ;; *-siemens) os=-sysv4 ;; *-masscomp) os=-rtu ;; f30[01]-fujitsu | f700-fujitsu) os=-uxpv ;; *-rom68k) os=-coff ;; *-*bug) os=-coff ;; *-apple) os=-macos ;; *-atari*) os=-mint ;; *) os=-none ;; esac fi # Here we handle the case where we know the os, and the CPU type, but not the # manufacturer. We pick the logical manufacturer. vendor=unknown case $basic_machine in *-unknown) case $os in -riscix*) vendor=acorn ;; -sunos*) vendor=sun ;; -cnk*|-aix*) vendor=ibm ;; -beos*) vendor=be ;; -hpux*) vendor=hp ;; -mpeix*) vendor=hp ;; -hiux*) vendor=hitachi ;; -unos*) vendor=crds ;; -dgux*) vendor=dg ;; -luna*) vendor=omron ;; -genix*) vendor=ns ;; -mvs* | -opened*) vendor=ibm ;; -os400*) vendor=ibm ;; -ptx*) vendor=sequent ;; -tpf*) vendor=ibm ;; -vxsim* | -vxworks* | -windiss*) vendor=wrs ;; -aux*) vendor=apple ;; -hms*) vendor=hitachi ;; -mpw* | -macos*) vendor=apple ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) vendor=atari ;; -vos*) vendor=stratus ;; esac basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` ;; esac echo $basic_machine$os exit # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: gcl/configure000077500000000000000000010641541242227143400135460ustar00rootroot00000000000000#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 test \$(( 1 + 1 )) = 2 || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME= PACKAGE_TARNAME= PACKAGE_VERSION= PACKAGE_STRING= PACKAGE_BUGREPORT= PACKAGE_URL= # Factoring default headers for most tests. ac_includes_default="\ #include #ifdef HAVE_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef STDC_HEADERS # include # include #else # ifdef HAVE_STDLIB_H # include # endif #endif #ifdef HAVE_STRING_H # if !defined STDC_HEADERS && defined HAVE_MEMORY_H # include # endif # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif" ac_subst_vars='LTLIBOBJS LIBOBJS use GNU_LD LEADING_UNDERSCORE EXTRA_LOBJS PRELINK_CHECK O2FLAGS O3FLAGS NIFLAGS FINAL_CFLAGS ALLOCA NOTIFY TCL_LIBS TCL_DL_LIBS TCL_LIB_SPEC TK_XLIBSW TK_BUILD_LIB_SPEC TK_LIB_SPEC TCL_INCLUDE TK_INCLUDE TK_XINCLUDES TCL_LIBRARY TK_LIBRARY TK_CONFIG_PREFIX TCLSH INFO_DIR EMACS_DEFAULT_EL EMACS_SITE_LISP EMACS HAVE_SIGEMT HAVE_SIGSYS HAVE_SV_ONSTACK USE_CLEANUP HAVE_PUTENV HAVE_SETENV NO_PROFILE RL_LIB RL_OBJS CLSTANDARD SYSTEM FLISP HAVE_LONG_LONG PAGEWIDTH DOUBLE_BIGENDIAN WORDS_BIGENDIAN LIBIBERTY LIBBFD BUILD_BFD HAVE_OUTPUT_BFD X_CFLAGS X_LIBS XMKMF GMPDIR GMP HAVE_MALLOC_ZONE_MEMALIGN EGREP GREP MAKEINFO AWK CPP OBJEXT EXEEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC PROCESSOR_FLAGS host_os host_vendor host_cpu host build_os build_vendor build_cpu build VERSION target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking enable_widecons enable_safecdr enable_safecdrdbg enable_prelink enable_fastimmfix enable_holepage enable_vssize enable_bdssize enable_ihssize enable_frssize enable_machine enable_immfix enable_notify enable_tcltk enable_tkconfig enable_tclconfig enable_infodir enable_emacsdir enable_common_binary enable_japi enable_xdr enable_xgcl enable_dlopen enable_statsysbfd enable_dynsysbfd enable_custreloc enable_debug enable_gprof enable_static enable_pic enable_oldgmp enable_dynsysgmp with_x enable_readline enable_ansi ' ac_precious_vars='build_alias host_alias target_alias CC CFLAGS LDFLAGS LIBS CPPFLAGS CPP XMKMF' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures this package to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF X features: --x-includes=DIR X include files are in DIR --x-libraries=DIR X library files are in DIR System types: --build=BUILD configure for building on BUILD [guessed] --host=HOST cross-compile to build programs to run on HOST [BUILD] _ACEOF fi if test -n "$ac_init_help"; then cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] use a three word cons with simplified typing protect cdr from immfix and speed up type processing debug safecdr code --enable-prelink will insist that the produced images may be prelinked --enable-fastimmfix=XXXX will reject low immediate fixnums unless 1< if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor XMKMF Path to xmkmf, Makefile generator for X Window System Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to the package provider. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for guested configure. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF configure generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## # ac_fn_c_try_compile LINENO # -------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_compile # ac_fn_c_try_cpp LINENO # ---------------------- # Try to preprocess conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_cpp () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } > conftest.i && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_cpp # ac_fn_c_try_run LINENO # ---------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. Assumes # that executables *can* be run. ac_fn_c_try_run () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then : ac_retval=0 else $as_echo "$as_me: program exited with status $ac_status" >&5 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=$ac_status fi rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_run # ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists, giving a warning if it cannot be compiled using # the include files in INCLUDES and setting the cache variable VAR # accordingly. ac_fn_c_check_header_mongrel () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if eval \${$3+:} false; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 $as_echo_n "checking $2 usability... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_header_compiler=yes else ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 $as_echo_n "checking $2 presence... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include <$2> _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : ac_header_preproc=yes else ac_header_preproc=no fi rm -f conftest.err conftest.i conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( yes:no: ) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ;; no:yes:* ) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=\$ac_header_compiler" fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_mongrel # ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists and can be compiled using the include files in # INCLUDES, setting the cache variable VAR accordingly. ac_fn_c_check_header_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$3=yes" else eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_compile # ac_fn_c_check_member LINENO AGGR MEMBER VAR INCLUDES # ---------------------------------------------------- # Tries to find if the field MEMBER exists in type AGGR, after including # INCLUDES, setting cache variable VAR accordingly. ac_fn_c_check_member () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2.$3" >&5 $as_echo_n "checking for $2.$3... " >&6; } if eval \${$4+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $5 int main () { static $2 ac_aggr; if (ac_aggr.$3) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$4=yes" else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $5 int main () { static $2 ac_aggr; if (sizeof ac_aggr.$3) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$4=yes" else eval "$4=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$4 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_member # ac_fn_c_check_func LINENO FUNC VAR # ---------------------------------- # Tests whether FUNC exists, setting the cache variable VAR accordingly ac_fn_c_check_func () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Define $2 to an innocuous variant, in case declares $2. For example, HP-UX 11i declares gettimeofday. */ #define $2 innocuous_$2 /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $2 (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $2 /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $2 (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$2 || defined __stub___$2 choke me #endif int main () { return $2 (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : eval "$3=yes" else eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_func # ac_fn_c_compute_int LINENO EXPR VAR INCLUDES # -------------------------------------------- # Tries to find the compile-time value of EXPR in a program that includes # INCLUDES, setting VAR accordingly. Returns whether the value could be # computed ac_fn_c_compute_int () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if test "$cross_compiling" = yes; then # Depending upon the size, compute the lo and hi bounds. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) >= 0)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_lo=0 ac_mid=0 while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_hi=$ac_mid; break else as_fn_arith $ac_mid + 1 && ac_lo=$as_val if test $ac_lo -le $ac_mid; then ac_lo= ac_hi= break fi as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext done else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) < 0)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_hi=-1 ac_mid=-1 while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) >= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_lo=$ac_mid; break else as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val if test $ac_mid -le $ac_hi; then ac_lo= ac_hi= break fi as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext done else ac_lo= ac_hi= fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext # Binary search between lo and hi bounds. while test "x$ac_lo" != "x$ac_hi"; do as_fn_arith '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo && ac_mid=$as_val cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_hi=$ac_mid else as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext done case $ac_lo in #(( ?*) eval "$3=\$ac_lo"; ac_retval=0 ;; '') ac_retval=1 ;; esac else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 static long int longval () { return $2; } static unsigned long int ulongval () { return $2; } #include #include int main () { FILE *f = fopen ("conftest.val", "w"); if (! f) return 1; if (($2) < 0) { long int i = longval (); if (i != ($2)) return 1; fprintf (f, "%ld", i); } else { unsigned long int i = ulongval (); if (i != ($2)) return 1; fprintf (f, "%lu", i); } /* Do not output a trailing newline, as this causes \r\n confusion on some platforms. */ return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : echo >>conftest.val; read $3 &5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=no" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { if (sizeof ($2)) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { if (sizeof (($2))) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else eval "$3=yes" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_type cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_config_headers="$ac_config_headers h/gclincl.h" VERSION=`cat majvers`.`cat minvers` # some parts of this configure script are taken from the tcl configure.in # # Arguments # # Check whether --enable-widecons was given. if test "${enable_widecons+set}" = set; then : enableval=$enable_widecons; $as_echo "#define WIDE_CONS 1" >>confdefs.h fi # Check whether --enable-safecdr was given. if test "${enable_safecdr+set}" = set; then : enableval=$enable_safecdr; else enable_safecdr="no" fi if test "$enable_safecdr" = "yes" ; then $as_echo "#define USE_SAFE_CDR 1" >>confdefs.h fi # Check whether --enable-safecdrdbg was given. if test "${enable_safecdrdbg+set}" = set; then : enableval=$enable_safecdrdbg; $as_echo "#define DEBUG_SAFE_CDR 1" >>confdefs.h fi # Check whether --enable-prelink was given. if test "${enable_prelink+set}" = set; then : enableval=$enable_prelink; PRELINK_CHECK=t else PRELINK_CHECK= fi # Check whether --enable-fastimmfix was given. if test "${enable_fastimmfix+set}" = set; then : enableval=$enable_fastimmfix; else enable_fastimmfix=64 fi # Check whether --enable-holepage was given. if test "${enable_holepage+set}" = set; then : enableval=$enable_holepage; cat >>confdefs.h <<_ACEOF #define HOLEPAGE $enable_holepage _ACEOF fi # Check whether --enable-vssize was given. if test "${enable_vssize+set}" = set; then : enableval=$enable_vssize; else enable_vssize=262144 fi cat >>confdefs.h <<_ACEOF #define VSSIZE $enable_vssize _ACEOF # Check whether --enable-bdssize was given. if test "${enable_bdssize+set}" = set; then : enableval=$enable_bdssize; else enable_bdssize=2048 fi cat >>confdefs.h <<_ACEOF #define BDSSIZE $enable_bdssize _ACEOF # Check whether --enable-ihssize was given. if test "${enable_ihssize+set}" = set; then : enableval=$enable_ihssize; else enable_ihssize=4096 fi cat >>confdefs.h <<_ACEOF #define IHSSIZE $enable_ihssize _ACEOF # Check whether --enable-frssize was given. if test "${enable_frssize+set}" = set; then : enableval=$enable_frssize; else enable_frssize=4096 fi cat >>confdefs.h <<_ACEOF #define FRSSIZE $enable_frssize _ACEOF # Check whether --enable-machine was given. if test "${enable_machine+set}" = set; then : enableval=$enable_machine; enable_machine=$enableval else enable_machine="" fi # Check whether --enable-immfix was given. if test "${enable_immfix+set}" = set; then : enableval=$enable_immfix; else enable_immfix=yes fi #AC_ARG_ENABLE(gmp,[ --enable-gmp=no will disable use of GMP gnu multiprecision arithmetic, (default is =yes)] , #[use_gmp=$enableval],[use_gmp="yes"]) use_gmp="yes" # Check whether --enable-notify was given. if test "${enable_notify+set}" = set; then : enableval=$enable_notify; enable_notify=$enableval else enable_notify="yes" fi # Check whether --enable-tcltk was given. if test "${enable_tcltk+set}" = set; then : enableval=$enable_tcltk; enable_tcltk=$enableval else enable_tcltk="yes" fi # Check whether --enable-tkconfig was given. if test "${enable_tkconfig+set}" = set; then : enableval=$enable_tkconfig; TK_CONFIG_PREFIX=$enableval else TK_CONFIG_PREFIX="unknown" fi # Check whether --enable-tclconfig was given. if test "${enable_tclconfig+set}" = set; then : enableval=$enable_tclconfig; TCL_CONFIG_PREFIX=$enableval else TCL_CONFIG_PREFIX="unknown" fi # Check whether --enable-infodir was given. if test "${enable_infodir+set}" = set; then : enableval=$enable_infodir; INFO_DIR=$enableval else INFO_DIR=$prefix/share/info fi INFO_DIR=`eval echo $INFO_DIR/` # Check whether --enable-emacsdir was given. if test "${enable_emacsdir+set}" = set; then : enableval=$enable_emacsdir; EMACS_SITE_LISP=$enableval else EMACS_SITE_LISP=$prefix/share/emacs/site-lisp fi EMACS_SITE_LISP=`eval echo $EMACS_SITE_LISP/` # Check whether --enable-common-binary was given. if test "${enable_common_binary+set}" = set; then : enableval=$enable_common_binary; use_common_binary=$enableval else use_common_binary="yes" fi # Check whether --enable-japi was given. if test "${enable_japi+set}" = set; then : enableval=$enable_japi; try_japi=$enableval else try_japi="no" fi # Check whether --enable-xdr was given. if test "${enable_xdr+set}" = set; then : enableval=$enable_xdr; enable_xdr=$enableval else enable_xdr="yes" fi # Check whether --enable-xgcl was given. if test "${enable_xgcl+set}" = set; then : enableval=$enable_xgcl; enable_xgcl=$enableval else enable_xgcl="yes" fi # # Host information # ac_aux_dir= for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do if test -f "$ac_dir/install-sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install-sh -c" break elif test -f "$ac_dir/install.sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install.sh -c" break elif test -f "$ac_dir/shtool"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/shtool install -c" break fi done if test -z "$ac_aux_dir"; then as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 fi # These three variables are undocumented and unsupported, # and are intended to be withdrawn in a future Autoconf release. # They can cause serious problems if a builder's source tree is in a directory # whose full name contains unusual characters. ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. # Make sure we can run config.sub. $SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 { $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 $as_echo_n "checking build system type... " >&6; } if ${ac_cv_build+:} false; then : $as_echo_n "(cached) " >&6 else ac_build_alias=$build_alias test "x$ac_build_alias" = x && ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` test "x$ac_build_alias" = x && as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 $as_echo "$ac_cv_build" >&6; } case $ac_cv_build in *-*-*) ;; *) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;; esac build=$ac_cv_build ac_save_IFS=$IFS; IFS='-' set x $ac_cv_build shift build_cpu=$1 build_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: build_os=$* IFS=$ac_save_IFS case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 $as_echo_n "checking host system type... " >&6; } if ${ac_cv_host+:} false; then : $as_echo_n "(cached) " >&6 else if test "x$host_alias" = x; then ac_cv_host=$ac_cv_build else ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || as_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 $as_echo "$ac_cv_host" >&6; } case $ac_cv_host in *-*-*) ;; *) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;; esac host=$ac_cv_host ac_save_IFS=$IFS; IFS='-' set x $ac_cv_host shift host_cpu=$1 host_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: host_os=$* IFS=$ac_save_IFS case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac canonical=$host my_host_kernel=`echo $host_os | awk '{j=split($1,A,"-");print A[1]}'` my_host_system=`echo $host_os | awk '{j=split($1,A,"-");if (j>=2) print A[2]}'` cat >>confdefs.h <<_ACEOF #define HOST_CPU "`echo $host_cpu | awk '{print toupper($0)}'`" _ACEOF cat >>confdefs.h <<_ACEOF #define HOST_KERNEL "`echo $my_host_kernel | awk '{print toupper($0)}'`" _ACEOF if test "$my_host_system" != "" ; then cat >>confdefs.h <<_ACEOF #define HOST_SYSTEM "`echo $my_host_system | awk '{print toupper($0)}'`" _ACEOF fi ## host=CPU-COMPANY-SYSTEM { $as_echo "$as_me:${as_lineno-$LINENO}: result: host=$host" >&5 $as_echo "host=$host" >&6; } PROCESSOR_FLAGS=${PROCESSOR_FLAGS:-""} use=unknown TLDFLAGS="" case $canonical in older) use=386-bsd;; sh4*linux*) use=sh4-linux;; *x86_64*linux*) use=amd64-linux;; *x86_64*kfreebsd*) use=amd64-kfreebsd;; *86*linux*) use=386-linux;; *86*kfreebsd*) use=386-kfreebsd;; *86*gnu*) use=386-gnu;; # m6800 not working with gcc-3.2 m68k*linux*) if test "$use_common_binary" = "yes"; then host=m68020-unknown-linux-gnu echo "The host is canonicalised to $host" fi use=m68k-linux;; alpha*linux*) use=alpha-linux;; mips*linux*) use=mips-linux;; mipsel*linux*) use=mipsel-linux;; sparc*linux*) use=sparc-linux;; aarch64*linux*) use=aarch64-linux;; arm*linux*) use=arm-linux;; s390*linux*) use=s390-linux;; ia64*linux*) use=ia64-linux;; hppa*linux*) use=hppa-linux;; powerpc*linux*) use=powerpc-linux;; powerpc-*-darwin*) use=powerpc-macosx;; *86*darwin*) use=386-macosx if test "$build_cpu" = "x86_64" ; then CFLAGS="-m64 $CFLAGS"; LDFLAGS="-m64 -Wl,-headerpad,72 $LDFLAGS"; else CFLAGS="-m32 $CFLAGS"; LDFLAGS="-m32 -Wl,-headerpad,56 $LDFLAGS"; fi;; alpha-dec-osf) use=alpha-osf1;; mips-dec-ultrix) use=dec3100;; old) use=dos-go32;; *86*-freebsd*) use=FreeBSD;; hp3*-*hpux*) use=hp300;; hp3*-*-*bsd*) use=hp300-bsd;; hppa*-*hpux*) use=hp800;; mips-sgi-irix) case $system in IRIX5*) use=irix5;; IRIX6*) use=irix6;; IRIX3*) use=sgi4d;; esac ;; m68k-apple-aux*) use=mac2;; old) use=mp386;; *86-ncr-sysv4) use=ncr;; *3-986-*netbsd*) use=NetBSD;; old) use=NeXT;; old) use=NeXT30-m68k;; *86-*nextstep*) use=NeXT32-i386;; *m68*-*nextstep*) use=NeXT32-m68k;; *rs6000-*-aix4*) use=rios;; *rs6000-*-aix3*) use=rios-aix3;; old) use=rt_aix;; old) use=sgi;; sparc-sun-solaris*) use=solaris;; i?86-pc-solaris*) use=solaris-i386;; old) use=sun2r3;; old) use=sun3;; m68*-sunos*) use=sun3-os4;; old) use=sun386i;; sparc*sunos*) use=sun4;; *86-sequent-dynix) use=symmetry;; u370*aix) use=u370_aix;; old) use=vax;; i*mingw*) if test "$use_common_binary" = "yes"; then host=i386-pc-mingw32 PROCESSOR_FLAGS="-march=i386 " echo "The host is canonicalised to $host" fi use=mingw;; i*cygwin*) if $CC -v 2>&1 | fgrep ming > /dev/null ; then use=mingw else use=gnuwin95 fi;; *openbsd*) # 'ld -Z' means disable W^X TLDFLAGS="$TLDFLAGS -Z" use=FreeBSD;; esac echo enable_machine=$enable_machine if test "x$enable_machine" != "x" ; then use=$enable_machine fi def_dlopen="no" def_statsysbfd="no" def_custreloc="yes" #def_statsysbfd="yes" #def_custreloc="no" def_locbfd="no" def_oldgmp="no" def_pic="no"; def_static="no"; def_debug="no"; case $use in *kfreebsd) ln -snf linux.defs h/$use.defs;; *gnu) ln -snf linux.defs h/$use.defs;; *linux) ln -snf linux.defs h/$use.defs; case $use in # def_static -- Function descriptors are currently realized at runtime in a non-reproducible fashion # on these architectures -- CM powerpc*) # if test "$host_cpu" = "powerpc64" ; then def_dlopen="yes" ; def_custreloc="no" ; fi ;; ia64*) def_dlopen="yes" ; def_custreloc="no" ;; hppa*) def_pic="yes" ;; # def_dlopen="yes" ; def_custreloc="no" ; def_pic="yes" ;; esac;; esac # Check whether --enable-dlopen was given. if test "${enable_dlopen+set}" = set; then : enableval=$enable_dlopen; else enable_dlopen="$def_dlopen" fi # Check whether --enable-statsysbfd was given. if test "${enable_statsysbfd+set}" = set; then : enableval=$enable_statsysbfd; else enable_statsysbfd="$def_statsysbfd" fi # Check whether --enable-dynsysbfd was given. if test "${enable_dynsysbfd+set}" = set; then : enableval=$enable_dynsysbfd; else enable_dynsysbfd="no" fi #AC_ARG_ENABLE(locbfd, # [ --enable-locbfd uses a static bfd library built from this source tree for loading and relocationing object files ] # ,,enable_locbfd="$def_locbfd") # Check whether --enable-custreloc was given. if test "${enable_custreloc+set}" = set; then : enableval=$enable_custreloc; else enable_custreloc="$def_custreloc" fi # Check whether --enable-debug was given. if test "${enable_debug+set}" = set; then : enableval=$enable_debug; else enable_debug="$def_debug" fi # Check whether --enable-gprof was given. if test "${enable_gprof+set}" = set; then : enableval=$enable_gprof; else enable_gprof="no" fi # Check whether --enable-static was given. if test "${enable_static+set}" = set; then : enableval=$enable_static; enable_static=$enableval else enable_static="$def_static" fi # Check whether --enable-pic was given. if test "${enable_pic+set}" = set; then : enableval=$enable_pic; else enable_pic="$def_pic" fi # Check whether --enable-oldgmp was given. if test "${enable_oldgmp+set}" = set; then : enableval=$enable_oldgmp; else enable_oldgmp="$def_oldgmp" fi # Check whether --enable-dynsysgmp was given. if test "${enable_dynsysgmp+set}" = set; then : enableval=$enable_dynsysgmp; else enable_dynsysgmp="yes" fi load_opt="0" if test "$enable_dlopen" = "yes" ; then load_opt=1 fi if test "$enable_statsysbfd" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; esac fi if test "$enable_dynsysbfd" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; 2) load_opt=3;; esac fi if test "$enable_locbfd" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; 2) load_opt=3;; 3) load_opt=4;; esac fi if test "$enable_custreloc" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; 2) load_opt=3;; 3) load_opt=4;; 4) load_opt=5;; esac fi if test "$load_opt" != "1" ; then echo "Exactly one loader option must be chosen: dlopen=$enable_dlopen statsysbfd=$enable_statsysbfd dynsysbfd=$enable_dynsysbfd locbfd=$enable_locbfd custreloc=$enable_custreloc" exit 1 fi TLDFLAGS="" if test "$enable_static" = "yes" ; then TLDFLAGS="-static -Wl,-zmuldefs $TLDFLAGS"; #FIXME should be in unixport/makefile $as_echo "#define STATIC_LINKING 1" >>confdefs.h fi case $use in *gnuwin*) TLDFLAGS="$TLDFLAGS -Wl,--stack,8000000";; esac ## finally warn if we did not find a recognized machine.s ## #if test "$use" = "unknown" ; then #types=`echo h/*.defs` | sed -e "s:h/::g" -e "s:\.defs:g"` #echo got canonical=$canonical, but was not recognized. #echo Unable to guess type to use. Try one of #exit(1) #fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: use=$use" >&5 $as_echo "use=$use" >&6; } # # System programs # # We set the default CFLAGS below, and don't want the autoconf default # CM 20040106 if test "$CFLAGS" = "" ; then CFLAGS=" " fi if test "$LDFLAGS" = "" ; then LDFLAGS=" " fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" fi fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl.exe do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl.exe do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH See \`config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 $as_echo_n "checking whether the C compiler works... " >&6; } ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { { ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. # So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an `-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else ac_file='' fi if test -z "$ac_file"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables See \`config.log' for more details" "$LINENO" 5; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 $as_echo_n "checking for C compiler default output file name... " >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 $as_echo "$ac_file" >&6; } ac_exeext=$ac_cv_exeext rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 $as_echo_n "checking for suffix of executables... " >&6; } if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest conftest$ac_cv_exeext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 $as_echo "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { FILE *f = fopen ("conftest.out", "w"); return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF ac_clean_files="$ac_clean_files conftest.out" # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 $as_echo_n "checking whether we are cross compiling... " >&6; } if test "$cross_compiling" != yes; then { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if { ac_try='./conftest$ac_cv_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details" "$LINENO" 5; } fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 $as_echo "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; } if ${ac_cv_objext+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 $as_echo "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } if ${ac_cv_c_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_compiler_gnu=yes else ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 $as_echo "$ac_cv_c_compiler_gnu" >&6; } if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } if ${ac_cv_prog_cc_g+:} false; then : $as_echo_n "(cached) " >&6 else ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes else CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 $as_echo "$ac_cv_prog_cc_g" >&6; } if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } if ${ac_cv_prog_cc_c89+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include struct stat; /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) 'x' int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int main () { return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c89=$ac_arg fi rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac if test "x$ac_cv_prog_cc_c89" != xno; then : fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 $as_echo_n "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if ${ac_cv_prog_CPP+:} false; then : $as_echo_n "(cached) " >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 $as_echo "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details" "$LINENO" 5; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # can only test for numbers -- CM # if test "${GCC}" -eq "yes" ; then #if [[ "${GCC}" = "yes" ]] ; then # Allog for environment variable overrides on compiler selection -- CM #GCC=$CC #else #GCC="" #fi # subst GCC not only under 386-linux, but where available -- CM if test "$GCC" = "yes" ; then TCFLAGS="-Wall -fsigned-char" #FIXME -Wno-unused-but-set-variable when time TMPF=-Wno-unused-but-set-variable { $as_echo "$as_me:${as_lineno-$LINENO}: checking for CFLAG $TMPF" >&5 $as_echo_n "checking for CFLAG $TMPF... " >&6; } CFLAGS_ORI=$CFLAGS CFLAGS="$CFLAGS $TMPF" if test "$cross_compiling" = yes; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main() {return 0;} _ACEOF if ac_fn_c_try_run "$LINENO"; then : TCFLAGS="$TCFLAGS $TMPF";{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi CFLAGS=$CFLAGS_ORI else TCFLAGS="-fsigned-char" fi if test "$GCC" = "yes" ; then TCFLAGS="$TCFLAGS -pipe" case $use in *mingw*|*gnuwin*) # echo "WARNING: Remove -fno-zero-initialized-in-bss from makedefs if gcc less than 3.3.1." # echo " It is otherwise needed for the Unexec stuff to work." # if test "$enable_debug" = "yes" ; then TCFLAGS="$TCFLAGS -gstabs" ; fi TCFLAGS="$TCFLAGS -fno-zero-initialized-in-bss -mms-bitfields";; esac fi #if test -f /proc/sys/kernel/exec-shield ; then # exec_stat=`cat /proc/sys/kernel/exec-shield` # if test "$exec_stat" != "0" ; then # # CFLAGS here to hopefully cover the DBEGIN routine below # CFLAGS="$CFLAGS -Wa,--execstack" # fi #fi TO3FLAGS="" TO2FLAGS="" #TFPFLAG="-fomit-frame-pointer" # FIXME -- remove when mingw compiler issues are fixed case "$use" in *mingw*) TFPFLAG="";; m68k*)#FIXME gcc 4.x bug workaround TFPFLAG="";; *) TFPFLAG="-fomit-frame-pointer";; esac for ac_prog in gawk nawk awk do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_AWK+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$AWK"; then ac_cv_prog_AWK="$AWK" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_AWK="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi AWK=$ac_cv_prog_AWK if test -n "$AWK"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AWK" >&5 $as_echo "$AWK" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$AWK" && break done # Work around system/gprof mips/hppa hang { $as_echo "$as_me:${as_lineno-$LINENO}: checking working gprof" >&5 $as_echo_n "checking working gprof... " >&6; } old_enable_gprof=$enable_gprof case $use in powerpc*) if test "$host_cpu" = "powerpc64le" ; then enable_gprof="no"; fi;; sh4*) enable_gprof="no";; ia64*) enable_gprof="no";; # mips*) enable_gprof="no";; hppa*) enable_gprof="no";; arm*) enable_gprof="no";;#FIXME mcount compiled as a 24/22 bit reloc even with -mlong-calls, marginally accessible *gnu) enable_gprof="no";; esac if test "$enable_gprof" = "$old_enable_gprof" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: disabled" >&5 $as_echo "disabled" >&6; } fi if test "$enable_gprof" = "yes" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for text start" >&5 $as_echo_n "checking for text start... " >&6; } echo 'int main () {return(0);}' >foo.c $CC foo.c -o foo GCL_GPROF_START=`nm foo | $AWK '/ *[TD] *__*start$/ {print $NF}'` # D for ppc64 -- FIXME custreloc rm -f foo.c foo if test "$GCL_GPROF_START" != "" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GCL_GPROF_START" >&5 $as_echo "$GCL_GPROF_START" >&6; } cat >>confdefs.h <<_ACEOF #define GCL_GPROF_START $GCL_GPROF_START _ACEOF case "$use" in arm*) #FIXME report and remove this when done { $as_echo "$as_me:${as_lineno-$LINENO}: result: Reducing optimization on profiling arm build to workaround gcc bug" >&5 $as_echo "Reducing optimization on profiling arm build to workaround gcc bug" >&6; } enable_debug=yes;; esac TCFLAGS="$TCFLAGS -pg"; TLIBS="$TLIBS -pg"; TFPFLAG="" $as_echo "#define GCL_GPROF 1" >>confdefs.h else enable_gprof="no"; fi fi if $CC -v 2>&1 | tail -1 | grep "gcc version 4.6.1" >/dev/null ; then case "$use" in arm*) #FIXME report and remove this when done { $as_echo "$as_me:${as_lineno-$LINENO}: result: Reducing optimization on arm build to workaround gcc 4.6 bug" >&5 $as_echo "Reducing optimization on arm build to workaround gcc 4.6 bug" >&6; } enable_debug=yes;; esac fi if test "$enable_debug" = "yes" ; then TCFLAGS="$TCFLAGS -g" # for subconfigurations CFLAGS="$CFLAGS -g" else TO3FLAGS="-O3 $TFPFLAG" TO2FLAGS="-O" fi # gcc on ppc cannot compile our new_init.c with full opts --CM TONIFLAGS="" case $use in powerpc*macosx) TCFLAGS="$TCFLAGS -mlongcall";; *linux) case $use in # amd64*) # stack-boundary option does not work # TCFLAGS="$TCFLAGS -m64 -mpreferred-stack-boundary=8";; alpha*) TCFLAGS="$TCFLAGS -mieee" if test "$enable_debug" != "yes" ; then TO3FLAGS="-O0" ; fi #FIXME needed asof gcc 4.8.1 ;; # m68k*) # TCFLAGS="$TCFLAGS -ffloat-store";; aarch64*) TLIBS="$TLIBS -lgcc_s";; hppa*) TCFLAGS="$TCFLAGS -mlong-calls " TLIBS="$TLIBS -lgcc_s" # workaround hppa __moddi3 local func symbols with default linker flags if test "$enable_debug" != "yes" ; then TO3FLAGS="-O2" ; TFPFLAG=""; fi #FIXME needed asof gcc 4.8.1 # TCFLAGS="$TCFLAGS -ffunction-sections" # if test "$enable_debug" != "yes" ; then TO3FLAGS="-O $TFPFLAG" ; fi # if test "$enable_debug" != "yes" ; then TO2FLAGS="-O" ; fi ;; mips*) # if test "$enable_debug" != "yes" ; then TO3FLAGS="-O0" ; fi #FIXME needed asof gcc 4.6.2 ;; ia64*) if test "$enable_debug" != "yes" ; then TO3FLAGS="-O" ; fi #FIXME needed asof gcc 4.8.1 ;; arm*) TCFLAGS="$TCFLAGS -mlong-calls -fdollars-in-identifiers -g " # if test "$enable_debug" != "yes" ; then TO3FLAGS="-O" ; fi #FIXME needed asof gcc 4.6.2 # if test "$enable_debug" != "yes" ; then TO2FLAGS="-O" ; fi ;; powerpc*) TCFLAGS="$TCFLAGS -mlongcall" ;; # if $CC -v 2>&1 | grep -q "gcc version 3.2" ; then # echo Reducing optimization for buggy gcc-3.2 # if test "$enable_debug" != "yes" ; then TONIFLAGS="-O $TFPFLAG" ; fi # fi; # echo Probing for longcall # if ! $CC -v 2>&1 | $AWK '/^gcc version / {split($3,A,".");if (A[[1]]+0>3 || (A[[1]]+0>=3 && A[[2]]+0>=3)) exit 1;}'; then # echo Enabling longcall on gcc 3.3 or later # TCFLAGS="$TCFLAGS -mlongcall" # echo Reducing optimization for buggy gcc 3.3 or later # if test "$enable_debug" != "yes" ; then TONIFLAGS="-O $TFPFLAG" ; fi # fi;; esac;; esac if test "$enable_pic" = "yes" ; then TCFLAGS="$TCFLAGS -fPIC" fi FDEBUG=`echo $CFLAGS | tr ' ' '\012' |grep "^\-g$"|tr '\012' ' '` #CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-g$"` FOMITF=`echo $CFLAGS | tr ' ' '\012' |grep "^\-fomit-frame-pointer$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-fomit-frame-pointer$"|tr '\012' ' '` FOOPT3=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O3$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O3$"|tr '\012' ' '` FOOPT2=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O2$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O2$"|tr '\012' ' '` FOOPT1=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O1$"|tr '\012' ' '` TMPF=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O$"|tr '\012' ' '` FOOPT1="$FOOPT1$TMPF" CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O1$"|grep -v "^\-O$"|tr '\012' ' '` FOOPT0=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O0$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O0$"|tr '\012' ' '` if test "$FOOPT0" != "" ; then TO3FLAGS=`echo $TO3FLAGS | sed 's,\-O[123 ],-O0 ,g' | sed 's,\-O$,-O0 ,g'` TO2FLAGS=`echo $TO2FLAGS | sed 's,\-O[123 ],-O0 ,g' | sed 's,\-O$,-O0 ,g'` else if test "$FOOPT1" != "" ; then TO3FLAGS=`echo $TO3FLAGS | sed 's,\-O[2-3],-O1,g'` TO2FLAGS=`echo $TO2FLAGS | sed 's,\-O[2-3],-O1,g'` else if test "$FOOPT2" != "" ; then TO3FLAGS=`echo "$TO3FLAGS" | sed 's,\-O3,-O2,g'` TO2FLAGS=`echo "$TO2FLAGS" | sed 's,\-O3,-O2,g'` fi fi fi if test "$FDEBUG" != "" ; then TO3FLAGS=`echo $TO3FLAGS | sed 's,\-fomit-frame-pointer,,g'` TO2FLAGS=`echo $TO2FLAGS | sed 's,\-fomit-frame-pointer,,g'` fi if test "$FOMITF" != "" ; then TO3FLAGS="$TO3FLAGS $FOMITF" fi # Step 1: set the variable "system" to hold the name and version number # for the system. This can usually be done via the "uname" command, but # there are a few systems, like Next, where this doesn't work. { $as_echo "$as_me:${as_lineno-$LINENO}: checking system version (for dynamic loading)" >&5 $as_echo_n "checking system version (for dynamic loading)... " >&6; } if machine=`uname -m` ; then true; else machine=unknown ; fi for ac_prog in makeinfo do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_MAKEINFO+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$MAKEINFO"; then ac_cv_prog_MAKEINFO="$MAKEINFO" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_MAKEINFO="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi MAKEINFO=$ac_cv_prog_MAKEINFO if test -n "$MAKEINFO"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MAKEINFO" >&5 $as_echo "$MAKEINFO" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$MAKEINFO" && break done test -n "$MAKEINFO" || MAKEINFO=""false"" if test -f /usr/lib/NextStep/software_version; then system=NEXTSTEP-`${AWK} '/3/,/3/' /usr/lib/NextStep/software_version` else system=`uname -s`-`uname -r` if test "$?" -ne 0 ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: unknown (can't find uname command)" >&5 $as_echo "unknown (can't find uname command)" >&6; } system=unknown else # Special check for weird MP-RAS system (uname returns weird # results, and the version is kept in special file). if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then system="MP-RAS-`${AWK} '{print $3}' '/etc/.relid'`" fi if test "`uname -s`" = "AIX" ; then system=AIX-`uname -v`.`uname -r` fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $system" >&5 $as_echo "$system" >&6; } fi fi case $use in *macosx) { $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; } if ${ac_cv_path_GREP+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$GREP"; then ac_path_GREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in grep ggrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_GREP" || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in *GNU*) ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'GREP' >> "conftest.nl" "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_GREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_GREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_GREP"; then as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_GREP=$GREP fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 $as_echo "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 $as_echo_n "checking for egrep... " >&6; } if ${ac_cv_path_EGREP+:} false; then : $as_echo_n "(cached) " >&6 else if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 then ac_cv_path_EGREP="$GREP -E" else if test -z "$EGREP"; then ac_path_EGREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in egrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_EGREP" || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP case `"$ac_path_EGREP" --version 2>&1` in *GNU*) ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'EGREP' >> "conftest.nl" "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_EGREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_EGREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_EGREP"; then as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_EGREP=$EGREP fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 $as_echo "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if ${ac_cv_header_stdc+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdc=yes else ac_cv_header_stdc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : : else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) return 2; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : else ac_cv_header_stdc=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then $as_echo "#define STDC_HEADERS 1" >>confdefs.h fi # On IRIX 5.3, sys/types and inttypes.h are conflicting. for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default " if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in malloc/malloc.h do : ac_fn_c_check_header_mongrel "$LINENO" "malloc/malloc.h" "ac_cv_header_malloc_malloc_h" "$ac_includes_default" if test "x$ac_cv_header_malloc_malloc_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_MALLOC_MALLOC_H 1 _ACEOF else as_fn_error $? "need malloc.h on macosx" "$LINENO" 5 fi done ac_fn_c_check_member "$LINENO" "struct _malloc_zone_t" "memalign" "ac_cv_member_struct__malloc_zone_t_memalign" " #include " if test "x$ac_cv_member_struct__malloc_zone_t_memalign" = xyes; then : $as_echo "#define HAVE_MALLOC_ZONE_MEMALIGN 1" >>confdefs.h fi ;; esac for ac_header in setjmp.h do : ac_fn_c_check_header_mongrel "$LINENO" "setjmp.h" "ac_cv_header_setjmp_h" "$ac_includes_default" if test "x$ac_cv_header_setjmp_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SETJMP_H 1 _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking sizeof jmp_buf" >&5 $as_echo_n "checking sizeof jmp_buf... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main() { FILE *fp=fopen("conftest1","w"); fprintf(fp,"%lu\n",sizeof(jmp_buf)); fclose(fp); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : sizeof_jmp_buf=`cat conftest1` { $as_echo "$as_me:${as_lineno-$LINENO}: result: $sizeof_jmp_buf" >&5 $as_echo "$sizeof_jmp_buf" >&6; } cat >>confdefs.h <<_ACEOF #define SIZEOF_JMP_BUF $sizeof_jmp_buf _ACEOF else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi done # sysconf for ac_header in unistd.h do : ac_fn_c_check_header_mongrel "$LINENO" "unistd.h" "ac_cv_header_unistd_h" "$ac_includes_default" if test "x$ac_cv_header_unistd_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_UNISTD_H 1 _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sysconf in -lc" >&5 $as_echo_n "checking for sysconf in -lc... " >&6; } if ${ac_cv_lib_c_sysconf+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lc $LIBS" # ac_fn_c_try_link LINENO # ----------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_link () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest$ac_exeext if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || test -x conftest$ac_exeext }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would # interfere with the next link command; also delete a directory that is # left behind by Apple's compiler. We do this before executing the actions. rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_link cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char sysconf (); int main () { return sysconf (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_c_sysconf=yes else ac_cv_lib_c_sysconf=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_sysconf" >&5 $as_echo "$ac_cv_lib_c_sysconf" >&6; } if test "x$ac_cv_lib_c_sysconf" = xyes; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking _SC_CLK_TCK" >&5 $as_echo_n "checking _SC_CLK_TCK... " >&6; } if test "$cross_compiling" = yes; then : hz=0 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main() { FILE *fp=fopen("conftest1","w"); fprintf(fp,"%lu\n",sysconf(_SC_CLK_TCK)); fclose(fp); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : hz=`cat conftest1` cat >>confdefs.h <<_ACEOF #define HZ $hz _ACEOF else hz=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $hz" >&5 $as_echo "$hz" >&6; } fi fi done #MY_SUBDIRS= # # GMP # rm -f makedefsafter MP_INCLUDE="" if test $use_gmp = yes ; then PATCHED_SYMBOLS="" if test "$enable_dynsysgmp" = "yes" ; then for ac_header in gmp.h do : ac_fn_c_check_header_mongrel "$LINENO" "gmp.h" "ac_cv_header_gmp_h" "$ac_includes_default" if test "x$ac_cv_header_gmp_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_GMP_H 1 _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking for __gmpz_init in -lgmp" >&5 $as_echo_n "checking for __gmpz_init in -lgmp... " >&6; } if ${ac_cv_lib_gmp___gmpz_init+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgmp $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char __gmpz_init (); int main () { return __gmpz_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_gmp___gmpz_init=yes else ac_cv_lib_gmp___gmpz_init=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gmp___gmpz_init" >&5 $as_echo "$ac_cv_lib_gmp___gmpz_init" >&6; } if test "x$ac_cv_lib_gmp___gmpz_init" = xyes; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking \"for external gmp version\"" >&5 $as_echo_n "checking \"for external gmp version\"... " >&6; } if test "$cross_compiling" = yes; then : echo "Cannot use dynamic gmp lib" else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main() { #if __GNU_MP_VERSION > 3 return 0; #else return -1; #endif } _ACEOF if ac_fn_c_try_run "$LINENO"; then : # MPFILES=$GMPDIR/mpn/mul_n.o # PATCHED_SYMBOLS=__gmpn_toom3_mul_n MPFILES= PATCHED_SYMBOLS= # if test "$use" = "m68k-linux" ; then # MPFILES="$MPFILES $GMPDIR/mpn/lshift.o $GMPDIR/mpn/rshift.o" # PATCHED_SYMBOLS="$PATCHED_SYMBOLS __gmpn_lshift __gmpn_rshift" # fi TLIBS="$TLIBS -lgmp" echo "#include \"gmp.h\"" >foo.c echo "int main() {return 0;}" >>foo.c MP_INCLUDE=`cpp foo.c | $AWK '/(\/|\\\\)gmp.h/ {if (!i) print $3;i=1}' | tr -d '"'` rm -f foo.c else echo "Cannot use dynamic gmp lib" fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi else echo "Cannot use dynamic gmp lib" fi else echo "Cannot use dynamic gmp lib" fi done fi NEED_LOCAL_GMP='' if test "$MP_INCLUDE" = "" ; then NEED_LOCAL_GMP=1; fi if test "$PATCHED_SYMBOLS" != "" ; then NEED_LOCAL_GMP=1; fi if test "$NEED_LOCAL_GMP" != "" ; then GMPDIR=gmp4 { $as_echo "$as_me:${as_lineno-$LINENO}: checking use_gmp=yes, doing configure in gmp directory" >&5 $as_echo_n "checking use_gmp=yes, doing configure in gmp directory... " >&6; } echo echo "#" echo "#" echo "# -------------------" echo "# Subconfigure of GMP" echo "#" echo "#" if test "$use_common_binary" = "yes"; then cd $GMPDIR && ./configure --build=$host && cd .. else cd $GMPDIR && ./configure && cd .. fi #MY_SUBDIRS="$MY_SUBDIRS $GMPDIR" echo "#" echo "#" echo "#" echo "# Subconfigure of GMP done" echo "# ------------------------" echo "#" if test "$MP_INCLUDE" = "" ; then cp $GMPDIR/gmp.h h/gmp.h MP_INCLUDE=h/gmp.h MPFILES=gmp_all fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking \"for leading underscore in object symbols\"" >&5 $as_echo_n "checking \"for leading underscore in object symbols\"... " >&6; } cat>foo.c < #include int main() {FILE *f;double d=0.0;getc(f);cos(d);return 0;} EOFF $CC -c foo.c -o foo.o if nm foo.o |grep " U " | grep "_cos" >/dev/null || nm foo.o |grep " U " | grep " _getc" >/dev/null ; then LEADING_UNDERSCORE=1 $as_echo "#define LEADING_UNDERSCORE 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: \"yes\"" >&5 $as_echo "\"yes\"" >&6; } else LEADING_UNDERSCORE="" { $as_echo "$as_me:${as_lineno-$LINENO}: result: \"no\"" >&5 $as_echo "\"no\"" >&6; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking \"for GNU ld option -Map\"" >&5 $as_echo_n "checking \"for GNU ld option -Map\"... " >&6; } touch map $CC -o foo -Wl,-Map map foo.o >/dev/null 2>&1 if test `cat map | wc -l` != "0" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: \"yes\"" >&5 $as_echo "\"yes\"" >&6; } $as_echo "#define HAVE_GNU_LD 1" >>confdefs.h GNU_LD=1 else { $as_echo "$as_me:${as_lineno-$LINENO}: result: \"no\"" >&5 $as_echo "\"no\"" >&6; } GNU_LD= fi rm -f foo.c foo.o foo map { $as_echo "$as_me:${as_lineno-$LINENO}: checking for size of gmp limbs" >&5 $as_echo_n "checking for size of gmp limbs... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include "$MP_INCLUDE" int main () { FILE *fp=fopen("conftest1","w"); fprintf(fp,"%u",sizeof(mp_limb_t)); fclose(fp); return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : mpsize=`cat conftest1` else as_fn_error $? "Cannot determine mpsize" "$LINENO" 5 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi cat >>confdefs.h <<_ACEOF #define MP_LIMB_BYTES $mpsize _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: result: $mpsize" >&5 $as_echo "$mpsize" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking _SHORT_LIMB" >&5 $as_echo_n "checking _SHORT_LIMB... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include "$MP_INCLUDE" int main () { #ifdef _SHORT_LIMB return 0; #else return 1; #endif ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : $as_echo "#define __SHORT_LIMB 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking _LONG_LONG_LIMB" >&5 $as_echo_n "checking _LONG_LONG_LIMB... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include "$MP_INCLUDE" int main () { #ifdef _LONG_LONG_LIMB return 0; #else return 1; #endif ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : $as_echo "#define __LONG_LONG_LIMB 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi GMP=1 $as_echo "#define GMP 1" >>confdefs.h echo > makedefsafter echo "MPFILES=$MPFILES" >> makedefsafter echo "PATCHED_SYMBOLS=$PATCHED_SYMBOLS" >> makedefsafter echo >> makedefsafter fi # # X windows # if test "$enable_xgcl" = "yes" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for X" >&5 $as_echo_n "checking for X... " >&6; } # Check whether --with-x was given. if test "${with_x+set}" = set; then : withval=$with_x; fi # $have_x is `yes', `no', `disabled', or empty when we do not yet know. if test "x$with_x" = xno; then # The user explicitly disabled X. have_x=disabled else case $x_includes,$x_libraries in #( *\'*) as_fn_error $? "cannot use X directory names containing '" "$LINENO" 5;; #( *,NONE | NONE,*) if ${ac_cv_have_x+:} false; then : $as_echo_n "(cached) " >&6 else # One or both of the vars are not set, and there is no cached value. ac_x_includes=no ac_x_libraries=no rm -f -r conftest.dir if mkdir conftest.dir; then cd conftest.dir cat >Imakefile <<'_ACEOF' incroot: @echo incroot='${INCROOT}' usrlibdir: @echo usrlibdir='${USRLIBDIR}' libdir: @echo libdir='${LIBDIR}' _ACEOF if (export CC; ${XMKMF-xmkmf}) >/dev/null 2>/dev/null && test -f Makefile; then # GNU make sometimes prints "make[1]: Entering ...", which would confuse us. for ac_var in incroot usrlibdir libdir; do eval "ac_im_$ac_var=\`\${MAKE-make} $ac_var 2>/dev/null | sed -n 's/^$ac_var=//p'\`" done # Open Windows xmkmf reportedly sets LIBDIR instead of USRLIBDIR. for ac_extension in a so sl dylib la dll; do if test ! -f "$ac_im_usrlibdir/libX11.$ac_extension" && test -f "$ac_im_libdir/libX11.$ac_extension"; then ac_im_usrlibdir=$ac_im_libdir; break fi done # Screen out bogus values from the imake configuration. They are # bogus both because they are the default anyway, and because # using them would break gcc on systems where it needs fixed includes. case $ac_im_incroot in /usr/include) ac_x_includes= ;; *) test -f "$ac_im_incroot/X11/Xos.h" && ac_x_includes=$ac_im_incroot;; esac case $ac_im_usrlibdir in /usr/lib | /usr/lib64 | /lib | /lib64) ;; *) test -d "$ac_im_usrlibdir" && ac_x_libraries=$ac_im_usrlibdir ;; esac fi cd .. rm -f -r conftest.dir fi # Standard set of common directories for X headers. # Check X11 before X11Rn because it is often a symlink to the current release. ac_x_header_dirs=' /usr/X11/include /usr/X11R7/include /usr/X11R6/include /usr/X11R5/include /usr/X11R4/include /usr/include/X11 /usr/include/X11R7 /usr/include/X11R6 /usr/include/X11R5 /usr/include/X11R4 /usr/local/X11/include /usr/local/X11R7/include /usr/local/X11R6/include /usr/local/X11R5/include /usr/local/X11R4/include /usr/local/include/X11 /usr/local/include/X11R7 /usr/local/include/X11R6 /usr/local/include/X11R5 /usr/local/include/X11R4 /usr/X386/include /usr/x386/include /usr/XFree86/include/X11 /usr/include /usr/local/include /usr/unsupported/include /usr/athena/include /usr/local/x11r5/include /usr/lpp/Xamples/include /usr/openwin/include /usr/openwin/share/include' if test "$ac_x_includes" = no; then # Guess where to find include files, by looking for Xlib.h. # First, try using that file with no special directory specified. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # We can compile using X headers with no special include directory. ac_x_includes= else for ac_dir in $ac_x_header_dirs; do if test -r "$ac_dir/X11/Xlib.h"; then ac_x_includes=$ac_dir break fi done fi rm -f conftest.err conftest.i conftest.$ac_ext fi # $ac_x_includes = no if test "$ac_x_libraries" = no; then # Check for the libraries. # See if we find them without any special options. # Don't add to $LIBS permanently. ac_save_LIBS=$LIBS LIBS="-lX11 $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { XrmInitialize () ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : LIBS=$ac_save_LIBS # We can link X programs with no special library path. ac_x_libraries= else LIBS=$ac_save_LIBS for ac_dir in `$as_echo "$ac_x_includes $ac_x_header_dirs" | sed s/include/lib/g` do # Don't even attempt the hair of trying to link an X program! for ac_extension in a so sl dylib la dll; do if test -r "$ac_dir/libX11.$ac_extension"; then ac_x_libraries=$ac_dir break 2 fi done done fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi # $ac_x_libraries = no case $ac_x_includes,$ac_x_libraries in #( no,* | *,no | *\'*) # Didn't find X, or a directory has "'" in its name. ac_cv_have_x="have_x=no";; #( *) # Record where we found X for the cache. ac_cv_have_x="have_x=yes\ ac_x_includes='$ac_x_includes'\ ac_x_libraries='$ac_x_libraries'" esac fi ;; #( *) have_x=yes;; esac eval "$ac_cv_have_x" fi # $with_x != no if test "$have_x" != yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $have_x" >&5 $as_echo "$have_x" >&6; } no_x=yes else # If each of the values was on the command line, it overrides each guess. test "x$x_includes" = xNONE && x_includes=$ac_x_includes test "x$x_libraries" = xNONE && x_libraries=$ac_x_libraries # Update the cache value to reflect the command line values. ac_cv_have_x="have_x=yes\ ac_x_includes='$x_includes'\ ac_x_libraries='$x_libraries'" { $as_echo "$as_me:${as_lineno-$LINENO}: result: libraries $x_libraries, headers $x_includes" >&5 $as_echo "libraries $x_libraries, headers $x_includes" >&6; } fi # AC_PATH_XTRA # echo $X_CFLAGS # echo $X_LIBS # echo $X_EXTRA_LIBS # echo $X_PRE_LIBS miss=0 # AC_CHECK_LIB(Xmu,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS)#FIXME remove these # AC_CHECK_LIB(Xt,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS) # AC_CHECK_LIB(Xext,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS) # AC_CHECK_LIB(Xaw,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS)#until here { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lX11" >&5 $as_echo_n "checking for main in -lX11... " >&6; } if ${ac_cv_lib_X11_main+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lX11 $X_LIBS $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_X11_main=yes else ac_cv_lib_X11_main=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_X11_main" >&5 $as_echo "$ac_cv_lib_X11_main" >&6; } if test "x$ac_cv_lib_X11_main" = xyes; then : X_LIBS="$X_LIBS -lX11" else miss=1 fi if test "$miss" = "1" ; then X_CFLAGS= X_LIBS= X_EXTRA_LIBS= X_PRE_LIBS= echo missing x libraries -- cannot compile xgcl else $as_echo "#define HAVE_XGCL 1" >>confdefs.h fi fi # # Dynamic loading # if test "$enable_dlopen" = "yes" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 $as_echo_n "checking for dlopen in -ldl... " >&6; } if ${ac_cv_lib_dl_dlopen+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dl_dlopen=yes else ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 $as_echo "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = xyes; then : have_dl=1 else have_dl=0 fi if test "$have_dl" = "0" ; then echo "Cannot find dlopen in -dl" exit 1 fi TLIBS="$TLIBS -ldl -rdynamic" TCFLAGS="-fPIC $TCFLAGS" $as_echo "#define USE_DLOPEN 1" >>confdefs.h fi if test "$enable_statsysbfd" = "yes" || test "$enable_dynsysbfd" = "yes" ; then for ac_header in bfd.h do : ac_fn_c_check_header_mongrel "$LINENO" "bfd.h" "ac_cv_header_bfd_h" "$ac_includes_default" if test "x$ac_cv_header_bfd_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_BFD_H 1 _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_init in -lbfd" >&5 $as_echo_n "checking for bfd_init in -lbfd... " >&6; } if ${ac_cv_lib_bfd_bfd_init+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lbfd -liberty $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char bfd_init (); int main () { return bfd_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_bfd_bfd_init=yes else ac_cv_lib_bfd_bfd_init=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_init" >&5 $as_echo "$ac_cv_lib_bfd_bfd_init" >&6; } if test "x$ac_cv_lib_bfd_bfd_init" = xyes; then : # # Old binutils appear to need CONST defined to const # { $as_echo "$as_me:${as_lineno-$LINENO}: checking if need to define CONST for bfd" >&5 $as_echo_n "checking if need to define CONST for bfd... " >&6; } if test "$cross_compiling" = yes; then : as_fn_error $? "cannot use bfd" "$LINENO" 5 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define IN_GCC #include int main() { symbol_info t; return 0;} _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } else if test "$cross_compiling" = yes; then : as_fn_error $? "cannot use bfd" "$LINENO" 5 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define CONST const #define IN_GCC #include int main() {symbol_info t; return 0;} _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } $as_echo "#define NEED_CONST 1" >>confdefs.h else as_fn_error $? "cannot use bfd" "$LINENO" 5 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi done $as_echo "#define HAVE_LIBBFD 1" >>confdefs.h # # BFD boolean syntax # { $as_echo "$as_me:${as_lineno-$LINENO}: checking for useable bfd_boolean" >&5 $as_echo_n "checking for useable bfd_boolean... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define IN_GCC #include bfd_boolean foo() {return FALSE;} int main () { return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } $as_echo "#define HAVE_BFD_BOOLEAN 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi # # bfd_link_info.output_bfd minimal configure change check # ac_fn_c_check_member "$LINENO" "struct bfd_link_info" "output_bfd" "ac_cv_member_struct_bfd_link_info_output_bfd" " #include #include " if test "x$ac_cv_member_struct_bfd_link_info_output_bfd" = xyes; then : $as_echo "#define HAVE_OUTPUT_BFD 1" >>confdefs.h fi # # FIXME: Need to workaround mingw before this point -- CM # if test "$enable_statsysbfd" = "yes" && ! $CC -v 2>&1 | fgrep ming > /dev/null ; then echo 'int main() {bfd_init();bfd_openr("/dev/null",0);return 0;}' >foo.c MP=`$CC -Wl,-M -static -o foo foo.c -lbfd -liberty -ldl 2>&1 | grep -v : | tr '()' '\012\012' | $AWK '{print $NF}' | sort | uniq` rm -f foo.c foo if echo $MP | tr ' ' '\012' | grep libbfd.a >/dev/null; then LIBBFD="`echo $MP | tr ' ' '\012' | grep libbfd.a | $AWK '{i=split($1,A,"/");for (j=1;j<=i;j++) if (j>1 && A[j]=="..") {j--;i-=2;for (k=j;k<=i;k++) A[k]=A[k+2];j--;}} END {for (j=1;j<=i;j++) printf("%s%s",A[j],j!=i ? "/" : "")}'`" else as_fn_error $? "cannot locate external libbfd.a" "$LINENO" 5 fi if echo $MP | tr ' ' '\012' | grep libiberty.a >/dev/null ; then LIBIBERTY="`echo $MP | tr ' ' '\012' | grep libiberty.a | $AWK '{i=split($1,A,"/");for (j=1;j<=i;j++) if (j>1 && A[j]=="..") {j--;i-=2;for (k=j;k<=i;k++) A[k]=A[k+2];j--;}} END {for (j=1;j<=i;j++) printf("%s%s",A[j],j!=i ? "/" : "")}'`" else as_fn_error $? "cannot locate external libiberty.a" "$LINENO" 5 fi BUILD_BFD=copy_bfd { $as_echo "$as_me:${as_lineno-$LINENO}: checking for inflate in -lz" >&5 $as_echo_n "checking for inflate in -lz... " >&6; } if ${ac_cv_lib_z_inflate+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lz $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char inflate (); int main () { return inflate (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_z_inflate=yes else ac_cv_lib_z_inflate=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_z_inflate" >&5 $as_echo "$ac_cv_lib_z_inflate" >&6; } if test "x$ac_cv_lib_z_inflate" = xyes; then : TLIBS="$TLIBS -lz" else as_fn_error $? "Need zlib for bfd linking" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlsym in -ldl" >&5 $as_echo_n "checking for dlsym in -ldl... " >&6; } if ${ac_cv_lib_dl_dlsym+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlsym (); int main () { return dlsym (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dl_dlsym=yes else ac_cv_lib_dl_dlsym=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlsym" >&5 $as_echo "$ac_cv_lib_dl_dlsym" >&6; } if test "x$ac_cv_lib_dl_dlsym" = xyes; then : TLIBS="$TLIBS -ldl" else as_fn_error $? "Need libdl for bfd linking" "$LINENO" 5 fi else TLIBS="$TLIBS -lbfd -liberty -ldl" fi fi if test "$enable_locbfd" = "yes" ; then # check for gettext. It is part of glibc, but others # need GNU gettext separately. # AC_CHECK_HEADERS(libintl.h, true, # AC_MSG_ERROR(libintl.h (gettext) not found)) # AC_SEARCH_LIBS(dgettext, intl, true, AC_MSG_ERROR(gettext library not found)) echo "#" echo "#" echo "# -------------------------" echo "# Subconfigure of LIBINTL" echo "#" echo "#" cd binutils/intl && chmod +x configure && ./configure --disable-nls && cd ../.. # MY_SUBDIRS="$MY_SUBDIRS binutils/libiberty " echo "#" echo "#" echo "#" echo "# Subconfigure of LIBINTL done" echo "# ------------------------------" echo "#" echo "#" echo "#" echo "# -------------------------" echo "# Subconfigure of LIBIBERTY" echo "#" echo "#" cd binutils/libiberty && chmod +x configure && ./configure --disable-nls && cd ../.. # MY_SUBDIRS="$MY_SUBDIRS binutils/libiberty " echo "#" echo "#" echo "#" echo "# Subconfigure of LIBIBERTY done" echo "# ------------------------------" echo "#" echo "#" echo "#" echo "# -------------------" echo "# Subconfigure of BFD" echo "#" echo "#" cd binutils/bfd && chmod +x configure && ./configure --with-included-gettext --disable-nls && cd ../.. # MY_SUBDIRS="$MY_SUBDIRS binutils/bfd " echo "#" echo "#" echo "#" echo "# Subconfigure of BFD done" echo "# ------------------------" echo "#" # TLIBS="$TLIBS `pwd`/binutils/bfd/libbfd.a `pwd`/binutils/libiberty/libiberty.a" $as_echo "#define HAVE_LIBBFD 1" >>confdefs.h BUILD_BFD="h/bfd.h h/bfdlink.h h/ansidecl.h h/symcat.h" fi if test "$enable_xdr" = "yes" ; then ac_fn_c_check_func "$LINENO" "xdr_double" "ac_cv_func_xdr_double" if test "x$ac_cv_func_xdr_double" = xyes; then : $as_echo "#define HAVE_XDR 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -ltirpc" >&5 $as_echo_n "checking for xdr_double in -ltirpc... " >&6; } if ${ac_cv_lib_tirpc_xdr_double+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ltirpc $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char xdr_double (); int main () { return xdr_double (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_tirpc_xdr_double=yes else ac_cv_lib_tirpc_xdr_double=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tirpc_xdr_double" >&5 $as_echo "$ac_cv_lib_tirpc_xdr_double" >&6; } if test "x$ac_cv_lib_tirpc_xdr_double" = xyes; then : $as_echo "#define HAVE_XDR 1" >>confdefs.h TLIBS="$TLIBS -ltirpc" else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -lrpc" >&5 $as_echo_n "checking for xdr_double in -lrpc... " >&6; } if ${ac_cv_lib_rpc_xdr_double+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lrpc $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char xdr_double (); int main () { return xdr_double (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_rpc_xdr_double=yes else ac_cv_lib_rpc_xdr_double=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_rpc_xdr_double" >&5 $as_echo "$ac_cv_lib_rpc_xdr_double" >&6; } if test "x$ac_cv_lib_rpc_xdr_double" = xyes; then : $as_echo "#define HAVE_XDR 1" >>confdefs.h TLIBS="$TLIBS -lrpc" else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -loncrpc" >&5 $as_echo_n "checking for xdr_double in -loncrpc... " >&6; } if ${ac_cv_lib_oncrpc_xdr_double+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-loncrpc $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char xdr_double (); int main () { return xdr_double (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_oncrpc_xdr_double=yes else ac_cv_lib_oncrpc_xdr_double=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_oncrpc_xdr_double" >&5 $as_echo "$ac_cv_lib_oncrpc_xdr_double" >&6; } if test "x$ac_cv_lib_oncrpc_xdr_double" = xyes; then : $as_echo "#define HAVE_XDR 1" >>confdefs.h TLIBS="$TLIBS -loncrpc" fi fi fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking __builtin_clzl" >&5 $as_echo_n "checking __builtin_clzl... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main() { unsigned long u; long j; if (__builtin_clzl(0)!=sizeof(long)*8) return -1; for (u=1,j=sizeof(long)*8-1;j>=0;j--,u<<=1) if (__builtin_clzl(u)!=j) return -1; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } $as_echo "#define HAVE_CLZL 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking __builtin_ctzl" >&5 $as_echo_n "checking __builtin_ctzl... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main() { unsigned long u; long j; if (__builtin_ctzl(0)!=sizeof(long)*8) return -1; for (u=1,j=0;j&5 $as_echo "yes" >&6; } $as_echo "#define HAVE_CTZL 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi case $use in sh4*) ;; #FIXME, these exceptions needed as of gcc 4.7 hppa*) ;; #FIXME powerpc*) ;; #FIXME alpha*) ;; #FIXME ia64*) ;; #FIXME *) { $as_echo "$as_me:${as_lineno-$LINENO}: checking __builtin___clear_cache" >&5 $as_echo_n "checking __builtin___clear_cache... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { void *v,*ve; __builtin___clear_cache(v,ve); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : $as_echo "#define HAVE_BUILTIN_CLEAR_CACHE 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi ;; esac #AC_CONFIG_SUBDIRS($MY_SUBDIRS) # Find where Data begins. This is used by the storage allocation # mechanism, in the PAGE macro. This offset is subtracted from # addresses, in calculating a page for an address in the heap. # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of long" >&5 $as_echo_n "checking size of long... " >&6; } if ${ac_cv_sizeof_long+:} false; then : $as_echo_n "(cached) " >&6 else if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default"; then : else if test "$ac_cv_type_long" = yes; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (long) See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_long=0 fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long" >&5 $as_echo "$ac_cv_sizeof_long" >&6; } cat >>confdefs.h <<_ACEOF #define SIZEOF_LONG $ac_cv_sizeof_long _ACEOF #### Memory areas and alignment { $as_echo "$as_me:${as_lineno-$LINENO}: checking for byte order" >&5 $as_echo_n "checking for byte order... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { /* Are we little or big endian? Adapted from Harbison&Steele. */ union {long l;char c[sizeof(long)];} u; u.l = 1; return u.c[sizeof(long)-1] ? 1 : 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: little" >&5 $as_echo "little" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: big" >&5 $as_echo "big" >&6; } $as_echo "#define WORDS_BIGENDIAN 1" >>confdefs.h fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for word order" >&5 $as_echo_n "checking for word order... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { /* Are we little or big endian? Adapted from Harbison&Steele. */ union {double d;int l[sizeof(double)/sizeof(int)];} u; u.d = 1.0; return u.l[sizeof(double)/sizeof(int)-1] ? 0 : 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: little" >&5 $as_echo "little" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: big" >&5 $as_echo "big" >&6; } $as_echo "#define DOUBLE_BIGENDIAN 1" >>confdefs.h fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi # pagewidth { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pagewidth" >&5 $as_echo_n "checking for pagewidth... " >&6; } case $use in mips*) min_pagewidth=14;; *) min_pagewidth=12;; esac if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #ifdef __CYGWIN__ #define getpagesize() 4096 #endif int main () { size_t i=getpagesize(),j; FILE *fp=fopen("conftest1","w"); for (j=0;i>>=1;j++); j=j<$min_pagewidth ? $min_pagewidth : j; fprintf(fp,"%u",j); return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : PAGEWIDTH=`cat conftest1` else PAGEWIDTH=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $PAGEWIDTH" >&5 $as_echo "$PAGEWIDTH" >&6; } cat >>confdefs.h <<_ACEOF #define PAGEWIDTH $PAGEWIDTH _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking for required object alignment" >&5 $as_echo_n "checking for required object alignment... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #define EXTER #include "$MP_INCLUDE" #include "./h/enum.h" #define OBJ_ALIGN #include "./h/type.h" #include "./h/lu.h" #include "./h/object.h" int main () { unsigned long i; FILE *fp=fopen("conftest1","w"); for (i=1;i && NOT_OBJECT_ALIGNED(i); i<<=1); if (!i) return -1; fprintf(fp,"%lu",i); fclose(fp); return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : obj_align=`cat conftest1` { $as_echo "$as_me:${as_lineno-$LINENO}: result: $obj_align" >&5 $as_echo "$obj_align" >&6; } cat >>confdefs.h <<_ACEOF #define OBJ_ALIGNMENT $obj_align _ACEOF else as_fn_error $? "Cannot find object alignent" "$LINENO" 5 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for C extension variable alignment" >&5 $as_echo_n "checking for C extension variable alignment... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { char *v __attribute__ ((aligned ($obj_align))); return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : obj_align="__attribute__ ((aligned ($obj_align)))" else as_fn_error $? "Need alignment attributes" "$LINENO" 5 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $obj_align" >&5 $as_echo "$obj_align" >&6; } cat >>confdefs.h <<_ACEOF #define OBJ_ALIGN $obj_align _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking for C extension noreturn function attribute" >&5 $as_echo_n "checking for C extension noreturn function attribute... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { extern int v() __attribute__ ((noreturn)); return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : no_return="__attribute__ ((noreturn))" else no_return= fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $no_return" >&5 $as_echo "$no_return" >&6; } cat >>confdefs.h <<_ACEOF #define NO_RETURN $no_return _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking sizeof struct contblock" >&5 $as_echo_n "checking sizeof struct contblock... " >&6; } # work around MSYS pwd result incompatibility if test "$use" = "mingw" ; then if test "$cross_compiling" = yes; then : echo Cannot find sizeof struct contblock;exit 1 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #define EXTER #include "$MP_INCLUDE" #include "h/enum.h" #include "h/type.h" #include "h/lu.h" #include "h/object.h" int main(int argc,char **argv,char **envp) { FILE *f=fopen("conftest1","w"); fprintf(f,"%u",sizeof(struct contblock)); fclose(f); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : sizeof_contblock=`cat conftest1` else echo Cannot find sizeof struct contblock;exit 1 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi else if test "$cross_compiling" = yes; then : echo Cannot find sizeof struct contblock;exit 1 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #define EXTER #include "$MP_INCLUDE" #include "`pwd`/h/enum.h" #include "`pwd`/h/type.h" #include "`pwd`/h/lu.h" #include "`pwd`/h/object.h" int main(int argc,char **argv,char **envp) { FILE *f=fopen("conftest1","w"); fprintf(f,"%u",sizeof(struct contblock)); fclose(f); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : sizeof_contblock=`cat conftest1` else echo Cannot find sizeof struct contblock;exit 1 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $sizeof_contblock" >&5 $as_echo "$sizeof_contblock" >&6; } cat >>confdefs.h <<_ACEOF #define SIZEOF_CONTBLOCK $sizeof_contblock _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sbrk" >&5 $as_echo_n "checking for sbrk... " >&6; } HAVE_SBRK="" if test "$cross_compiling" = yes; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&5 $as_echo "no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&6; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main() { FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%u",sbrk(0)); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : HAVE_SBRK=1 { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&5 $as_echo "no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi if test "$use" = "386-macosx" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: emulating sbrk for mac" >&5 $as_echo "emulating sbrk for mac" >&6; }; HAVE_SBRK=0 fi if test "$HAVE_SBRK" = "1" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ADDR_NO_RANDOMIZE constant" >&5 $as_echo_n "checking for ADDR_NO_RANDOMIZE constant... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main () { FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_NO_RANDOMIZE); return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ADDR_NO_RANDOMIZE=`cat conftest1` { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes $ADDR_NO_RANDOMIZE" >&5 $as_echo "yes $ADDR_NO_RANDOMIZE" >&6; } else ADDR_NO_RANDOMIZE=0 { $as_echo "$as_me:${as_lineno-$LINENO}: result: no assuming 0x40000" >&5 $as_echo "no assuming 0x40000" >&6; } cat >>confdefs.h <<_ACEOF #define ADDR_NO_RANDOMIZE 0x40000 _ACEOF fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ADDR_COMPAT_LAYOUT constant" >&5 $as_echo_n "checking for ADDR_COMPAT_LAYOUT constant... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main () { FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_COMPAT_LAYOUT); return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ADDR_COMPAT_LAYOUT=`cat conftest1` { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes $ADDR_COMPAT_LAYOUT" >&5 $as_echo "yes $ADDR_COMPAT_LAYOUT" >&6; } else ADDR_COMPAT_LAYOUT=0 { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } cat >>confdefs.h <<_ACEOF #define ADDR_COMPAT_LAYOUT 0 _ACEOF fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ADDR_LIMIT_3GB constant" >&5 $as_echo_n "checking for ADDR_LIMIT_3GB constant... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main () { FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_LIMIT_3GB); return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ADDR_LIMIT_3GB=`cat conftest1` { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes $ADDR_LIMIT_3GB" >&5 $as_echo "yes $ADDR_LIMIT_3GB" >&6; } else ADDR_LIMIT_3GB=0 { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } cat >>confdefs.h <<_ACEOF #define ADDR_LIMIT_3GB 0 _ACEOF fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for personality(ADDR_NO_RANDOMIZE) support" >&5 $as_echo_n "checking for personality(ADDR_NO_RANDOMIZE) support... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include void gprof_cleanup() {}; int main(int argc,char **argv,char **envp) { #include "h/unrandomize.h" return 0;} _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } $as_echo "#define CAN_UNRANDOMIZE_SBRK 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking that sbrk is (now) non-random" >&5 $as_echo_n "checking that sbrk is (now) non-random... " >&6; } if test "$cross_compiling" = yes; then : SBRK=0 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include void gprof_cleanup() {}; int main(int argc,char * argv[],char * envp[]) { FILE *f; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%u",sbrk(0)); return 0;} _ACEOF if ac_fn_c_try_run "$LINENO"; then : SBRK=`cat conftest1` else SBRK=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi if test "$SBRK" = "0" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: cannot trap sbrk" >&5 $as_echo "cannot trap sbrk" >&6; } exit 1 fi if test "$cross_compiling" = yes; then : SBRK1=0 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include void gprof_cleanup() {}; int main(int argc,char * argv[],char * envp[]) { FILE *f; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%u",sbrk(0)); return 0;} _ACEOF if ac_fn_c_try_run "$LINENO"; then : SBRK1=`cat conftest1` else SBRK1=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi if test "$SBRK1" = "0" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: cannot trap sbrk" >&5 $as_echo "cannot trap sbrk" >&6; } exit 1 fi if test "$SBRK" = "$SBRK1" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "Cannot build with randomized sbrk. Your options:" echo " - upgrade to a kernel/libc that knows about personality(ADDR_NO_RANDOMIZE)" echo " - recompile your kernel with CONFIG_COMPAT_BRK (if it has that option)" echo " - run sysctl kernel.randomize_va_space=0 before using gcl" exit 1 fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking CSTACK_ADDRESS" >&5 $as_echo_n "checking CSTACK_ADDRESS... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include void * foo() { int i; return (void *)&i; } void gprof_cleanup() {}; int main(int argc,char **argv,char **envp) { void *v ; FILE *fp = fopen("conftest1","w"); unsigned long i,j; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif j=1; j<<=$PAGEWIDTH; j<<=16; i=(unsigned long)&v; if (foo()>i) i-=j; j--; i+=j; i&=~j; fprintf(fp,"0x%lx",i-1); fclose(fp); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : cstack_address=`cat conftest1` else cstack_address=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi cat >>confdefs.h <<_ACEOF #define CSTACK_ADDRESS $cstack_address _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cstack_address" >&5 $as_echo "$cstack_address" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking cstack bits" >&5 $as_echo_n "checking cstack bits... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include void * foo() { int i; return (void *)&i; } void gprof_cleanup() {}; int main(int argc,char **argv,char **envp) { void *v ; FILE *fp = fopen("conftest1","w"); unsigned long i,j; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif j=1; j<<=$PAGEWIDTH; j<<=16; i=(unsigned long)&v; if (foo()>i) i-=j; j--; i+=j; i&=~j; for (j=0;(i>>j)!=(i>>(sizeof(long)*8-1));j++); fprintf(fp,"%d",j); fclose(fp); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : cstack_bits=`cat conftest1` else cstack_bits=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi cat >>confdefs.h <<_ACEOF #define CSTACK_BITS $cstack_bits _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cstack_bits" >&5 $as_echo "$cstack_bits" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking NEG_CSTACK_ADDRESS" >&5 $as_echo_n "checking NEG_CSTACK_ADDRESS... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include void gprof_cleanup() {}; int main(int argc,char **argv,char **envp) { #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif return (long)$cstack_address<0 ? 0 : -1; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } neg_cstack_address=1 $as_echo "#define NEG_CSTACK_ADDRESS 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } neg_cstack_address=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking finding CSTACK_ALIGNMENT" >&5 $as_echo_n "checking finding CSTACK_ALIGNMENT... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include void gprof_cleanup() {}; int main(int argc,char **argv,char **envp) { void *b,*c; FILE *fp = fopen("conftest1","w"); long n; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif b=alloca(sizeof(b)); c=alloca(sizeof(c)); n=b>c ? b-c : c-b; n=n>sizeof(c) ? n : 1; fprintf(fp,"%ld",n); fclose(fp); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : cstack_alignment=`cat conftest1` else cstack_alignment=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi cat >>confdefs.h <<_ACEOF #define CSTACK_ALIGNMENT $cstack_alignment _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cstack_alignment" >&5 $as_echo "$cstack_alignment" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking CSTACK_DIRECTION" >&5 $as_echo_n "checking CSTACK_DIRECTION... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include void * foo(void) { int i; return (void *)&i; } void gprof_cleanup() {}; int main(int argc,char **argv,char **envp) { char *b; FILE *fp = fopen("conftest1","w"); #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif fprintf(fp,"%d",((long) &b) > ((long) foo()) ? -1 : 1); fclose(fp); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : cstack_direction=`cat conftest1` else cstack_direction=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi cat >>confdefs.h <<_ACEOF #define CSTACK_DIRECTION $cstack_direction _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cstack_direction" >&5 $as_echo "$cstack_direction" >&6; } if test "$use" != "386-gnu" ; then #hurd can push .data below C stack, but sbrk(0) remains above, foiling unexec { $as_echo "$as_me:${as_lineno-$LINENO}: checking finding default linker script" >&5 $as_echo_n "checking finding default linker script... " >&6; } touch unixport/gcl.script echo "int main() {return 0;}" >foo.c $CC -Wl,--verbose foo.c -o foo 2>&1 | \ $AWK '/\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=/ {i=1-i;next} {if (i) print}' >gcl.script rm -rf foo.c foo if test "`cat gcl.script | wc -l`" != "0" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: got it" >&5 $as_echo "got it" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: trying to adjust text start" >&5 $as_echo "$as_me: trying to adjust text start" >&6;} cp gcl.script gcl.script.def n=-1; k=0; lim=`$AWK 'END {printf("%d\n",m*8-2)}' m=$ac_cv_sizeof_long`; max=0; min=$lim; while test $n -lt $lim ; do j=`$AWK 'END {for (i=j=0;j<=n;j++) i=i ? i*2 : 1;printf("%x\n",3*i)}' n=$n gcl.script # diff -u gcl.script.def gcl.script echo "int main() {return 0;}" >foo.c if ( $CC -Wl,-T gcl.script foo.c -o foo && ./foo ) >/dev/null 2>&1 ; then if test $n -lt $min ; then min=$n; fi; if test $n -gt $max; then max=$n; fi; elif test $max -gt 0 ; then break; fi; n=`$AWK 'END {print n+1}' n=$n &5 $as_echo "$as_me: min log text start $min" >&6;} { $as_echo "$as_me:${as_lineno-$LINENO}: max log text start $max" >&5 $as_echo "$as_me: max log text start $max" >&6;} if test $neg_cstack_address -eq 1 ; then #FIXME test this if test $cstack_bits -lt $max ; then max=$cstack_bits; { $as_echo "$as_me:${as_lineno-$LINENO}: max log text start reduced to $max considering c stack address" >&5 $as_echo "$as_me: max log text start reduced to $max considering c stack address" >&6;} fi fi j=-1; low_shft=""; if test $min -le $max ; then if test $max -ge $enable_fastimmfix && test "$enable_immfix" = "yes" ; then j=`$AWK 'END {for (i=j=0;j<=n;j++) i=i ? i*2 : 1;printf("%x\n",3*i)}' n=$max &5 $as_echo "$as_me: raising log text to $j for a $max bit wide low immfix table" >&6;} else j=`$AWK 'END {for (i=j=0;j<=n;j++) i=i ? i*2 : 1;printf("%x\n",3*i)}' n=$min &5 $as_echo "$as_me: lowering log text to $j to maximize data area" >&6;} fi fi if test "$low_shft" != "" ; then cat >>confdefs.h <<_ACEOF #define LOW_SHFT $low_shft _ACEOF cat >>confdefs.h <<_ACEOF #define OBJNULL (object)0x$j _ACEOF else cat >>confdefs.h <<_ACEOF #define OBJNULL NULL _ACEOF fi # echo $j; { $as_echo "$as_me:${as_lineno-$LINENO}: checking our linker script" >&5 $as_echo_n "checking our linker script... " >&6; } if test "$j" -ne "-1" ; then cat gcl.script.def | $AWK '/SIZEOF_HEADERS/ {gsub("0x[0-9]*","0x" j,$0);} {print}' j=$j >gcl.script { $as_echo "$as_me:${as_lineno-$LINENO}: result: done" >&5 $as_echo "done" >&6; } rm -f gcl.script.def LDFLAGS="$LDFLAGS -Wl,-T gcl.script " cp gcl.script unixport else { $as_echo "$as_me:${as_lineno-$LINENO}: result: none found or not needed" >&5 $as_echo "none found or not needed" >&6; } rm -f gcl.script gcl.script.def fi rm -rf foo.c foo else { $as_echo "$as_me:${as_lineno-$LINENO}: result: not found" >&5 $as_echo "not found" >&6; } fi else cat >>confdefs.h <<_ACEOF #define OBJNULL NULL _ACEOF fi mem_top=0 mem_range=0 { $as_echo "$as_me:${as_lineno-$LINENO}: checking mem top" >&5 $as_echo_n "checking mem top... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { void *v; unsigned long i,j,k,l,m; FILE *fp = fopen("conftest1","w"); for (i=2,k=1;i;k=i,i<<=1); l=$cstack_address; l=$cstack_direction==1 ? (l>=1,i|=j); if (j<(k>>3)) i=0; j=1; j<<=$PAGEWIDTH; j<<=4; j--; i+=j; i&=~j; fprintf(fp,"0x%lx",i); fclose(fp); return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : mem_top=`cat conftest1` else mem_top="0x0" fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $mem_top" >&5 $as_echo "$mem_top" >&6; } if test "$mem_top" != "0x0" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking finding upper mem half range" >&5 $as_echo_n "checking finding upper mem half range... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { unsigned long j; FILE *fp = fopen("conftest1","w"); for (j=1;j && !(j& $mem_top);j<<=1); fprintf(fp,"0x%lx",j>>1); fclose(fp); return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : mem_range=`cat conftest1` else mem_range="0x0" fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $mem_range" >&5 $as_echo "$mem_range" >&6; } if test "$mem_range" != "0x0" ; then cat >>confdefs.h <<_ACEOF #define MEM_TOP $mem_top _ACEOF cat >>confdefs.h <<_ACEOF #define MEM_RANGE $mem_range _ACEOF fi fi if test "$enable_immfix" = "yes" ; then if test "$mem_top" != "0x0" ; then if test "$mem_range" != "0x0" ; then cat >>confdefs.h <<_ACEOF #define IM_FIX_BASE $mem_top _ACEOF cat >>confdefs.h <<_ACEOF #define IM_FIX_LIM $mem_range _ACEOF fi fi fi # On systems with execshield, brk is randomized. We need to catch # this and restore the traditional behavior here { $as_echo "$as_me:${as_lineno-$LINENO}: checking sizeof long long int" >&5 $as_echo_n "checking sizeof long long int... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { if (sizeof(long long int) == 2*sizeof(long)) return 0; return 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : $as_echo "#define HAVE_LONG_LONG 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi for ac_header in dirent.h do : ac_fn_c_check_header_mongrel "$LINENO" "dirent.h" "ac_cv_header_dirent_h" "$ac_includes_default" if test "x$ac_cv_header_dirent_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_DIRENT_H 1 _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking for d_type" >&5 $as_echo_n "checking for d_type... " >&6; } if test "$cross_compiling" = yes; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { struct dirent d; return d.d_type=0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } $as_echo "#define HAVE_D_TYPE 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi done # readline # Check whether --enable-readline was given. if test "${enable_readline+set}" = set; then : enableval=$enable_readline; else enable_readline="yes" fi # ansi lisp # Check whether --enable-ansi was given. if test "${enable_ansi+set}" = set; then : enableval=$enable_ansi; else enable_ansi="no" fi if test "$enable_ansi" = "yes" ; then SYSTEM=ansi_gcl $as_echo "#define ANSI_COMMON_LISP 1" >>confdefs.h CLSTANDARD=ANSI else SYSTEM=gcl CLSTANDARD=CLtL1 fi FLISP="saved_$SYSTEM" # Maximum number of pages # Check if Posix compliant getcwd exists, if not we'll use getwd. for ac_func in getcwd do : ac_fn_c_check_func "$LINENO" "getcwd" "ac_cv_func_getcwd" if test "x$ac_cv_func_getcwd" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_GETCWD 1 _ACEOF fi done for ac_func in getwd do : ac_fn_c_check_func "$LINENO" "getwd" "ac_cv_func_getwd" if test "x$ac_cv_func_getwd" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_GETWD 1 _ACEOF fi done ac_fn_c_check_func "$LINENO" "uname" "ac_cv_func_uname" if test "x$ac_cv_func_uname" = xyes; then : else $as_echo "#define NO_UNAME 1" >>confdefs.h fi ac_fn_c_check_func "$LINENO" "gettimeofday" "ac_cv_func_gettimeofday" if test "x$ac_cv_func_gettimeofday" = xyes; then : else $as_echo "#define NO_GETTOD 1" >>confdefs.h fi for ac_header in sys/ioctl.h do : ac_fn_c_check_header_mongrel "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$ac_includes_default" if test "x$ac_cv_header_sys_ioctl_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SYS_IOCTL_H 1 _ACEOF fi done # OpenBSD has elf_abi.h instead of elf.h for ac_header in elf.h elf_abi.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in sys/sockio.h do : ac_fn_c_check_header_mongrel "$LINENO" "sys/sockio.h" "ac_cv_header_sys_sockio_h" "$ac_includes_default" if test "x$ac_cv_header_sys_sockio_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SYS_SOCKIO_H 1 _ACEOF fi done #-------------------------------------------------------------------- # The code below deals with several issues related to gettimeofday: # 1. Some systems don't provide a gettimeofday function at all # (set NO_GETTOD if this is the case). # 2. SGI systems don't use the BSD form of the gettimeofday function, # but they have a BSDgettimeofday function that can be used instead. # 3. See if gettimeofday is declared in the header file. # if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can # declare it. #-------------------------------------------------------------------- ac_fn_c_check_func "$LINENO" "BSDgettimeofday" "ac_cv_func_BSDgettimeofday" if test "x$ac_cv_func_BSDgettimeofday" = xyes; then : $as_echo "#define HAVE_BSDGETTIMEOFDAY 1" >>confdefs.h else ac_fn_c_check_func "$LINENO" "gettimeofday" "ac_cv_func_gettimeofday" if test "x$ac_cv_func_gettimeofday" = xyes; then : else $as_echo "#define NO_GETTOD 1" >>confdefs.h fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gettimeofday declaration" >&5 $as_echo_n "checking for gettimeofday declaration... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "gettimeofday" >/dev/null 2>&1; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: present" >&5 $as_echo "present" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: missing" >&5 $as_echo "missing" >&6; } $as_echo "#define GETTOD_NOT_DECLARED 1" >>confdefs.h fi rm -f conftest* { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sin in -lm" >&5 $as_echo_n "checking for sin in -lm... " >&6; } if ${ac_cv_lib_m_sin+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lm $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char sin (); int main () { return sin (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_m_sin=yes else ac_cv_lib_m_sin=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_m_sin" >&5 $as_echo "$ac_cv_lib_m_sin" >&6; } if test "x$ac_cv_lib_m_sin" = xyes; then : LIBS="${LIBS} -lm" else true fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lmingwex" >&5 $as_echo_n "checking for main in -lmingwex... " >&6; } if ${ac_cv_lib_mingwex_main+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmingwex $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_mingwex_main=yes else ac_cv_lib_mingwex_main=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mingwex_main" >&5 $as_echo "$ac_cv_lib_mingwex_main" >&6; } if test "x$ac_cv_lib_mingwex_main" = xyes; then : LIBS="${LIBS} -lmingwex" else true fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for buggy maximum sscanf length" >&5 $as_echo_n "checking for buggy maximum sscanf length... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { char *s= "2.7182818284590452353602874713526624977572470936999595749669676277240766303535475945713821785251664274274663919320030599218174135966290435729003342952605956307381323286279434907632338298807531952510190115738341879307021540891499348841675092447614606680822648001684774118537423454424371075390777449920695517027618386062613313845830007520449338265602976067371132007093287091274437470472306969772093101416928368190255151086574637721112523897844250569536967707854499699679468644549059879316368892300987931277361782154249992295763514822082698951936680331825288693984964651058209392398294887933203625094431173012381970684161404"; int n, m; double f; char *endptr; FILE *fp=fopen("conftest1","w"); n=sscanf(s,"%lf%n",&f,&m); fprintf(fp,"%d",m); fclose(fp); return s[m]; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: none" >&5 $as_echo "none" >&6; } else buggy_maximum_sscanf_length=`cat conftest1` { $as_echo "$as_me:${as_lineno-$LINENO}: result: $buggy_maximum_sscanf_length" >&5 $as_echo "$buggy_maximum_sscanf_length" >&6; } cat >>confdefs.h <<_ACEOF #define BUGGY_MAXIMUM_SSCANF_LENGTH $buggy_maximum_sscanf_length _ACEOF fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi EXTRA_LOBJS= if test "$try_japi" = "yes" ; then for ac_header in japi.h do : ac_fn_c_check_header_mongrel "$LINENO" "japi.h" "ac_cv_header_japi_h" "$ac_includes_default" if test "x$ac_cv_header_japi_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_JAPI_H 1 _ACEOF $as_echo "#define HAVE_JAPI_H 1" >>confdefs.h EXTRA_LOBJS="${EXTRA_LOBJS} gcl_japi.o" LIBS="${LIBS} -ljapi -lwsock32" fi done fi # Should really find a way to check for prototypes, but this # basically works for now. CM # for ac_header in math.h do : ac_fn_c_check_header_mongrel "$LINENO" "math.h" "ac_cv_header_math_h" "$ac_includes_default" if test "x$ac_cv_header_math_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_MATH_H 1 _ACEOF $as_echo "#define HAVE_MATH_H 1" >>confdefs.h fi done for ac_header in complex.h do : ac_fn_c_check_header_mongrel "$LINENO" "complex.h" "ac_cv_header_complex_h" "$ac_includes_default" if test "x$ac_cv_header_complex_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_COMPLEX_H 1 _ACEOF $as_echo "#define HAVE_COMPLEX_H 1" >>confdefs.h fi done # # For DBL_MAX et. al. on (only) certain Linux arches, apparently CM # for ac_header in values.h do : ac_fn_c_check_header_mongrel "$LINENO" "values.h" "ac_cv_header_values_h" "$ac_includes_default" if test "x$ac_cv_header_values_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_VALUES_H 1 _ACEOF $as_echo "#define HAVE_VALUES_H 1" >>confdefs.h fi done # # Sparc solaris keeps this in float.h, rework either/or with values.h later # for ac_header in float.h do : ac_fn_c_check_header_mongrel "$LINENO" "float.h" "ac_cv_header_float_h" "$ac_includes_default" if test "x$ac_cv_header_float_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_FLOAT_H 1 _ACEOF $as_echo "#define HAVE_FLOAT_H 1" >>confdefs.h fi done # # The second alternative is for solaris. This needs to be # a more comprehensive later, i.e. checking that the fpclass # test makes sense. CM # { $as_echo "$as_me:${as_lineno-$LINENO}: checking for isnormal" >&5 $as_echo_n "checking for isnormal... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define _GNU_SOURCE #include int main () { float f; return isnormal(f) || !isnormal(f) ? 0 : 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : $as_echo "#define HAVE_ISNORMAL 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for fpclass in ieeefp.h" >&5 $as_echo_n "checking for fpclass in ieeefp.h... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { float f; return fpclass(f)>=FP_NZERO || fpclass(f)>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for isfinite" >&5 $as_echo_n "checking for isfinite... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define _GNU_SOURCE #include int main () { float f; return isfinite(f) || !isfinite(f) ? 0 : 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : $as_echo "#define HAVE_ISFINITE 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for finite()" >&5 $as_echo_n "checking for finite()... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main () { float f; return finite(f) || !finite(f) ? 0 : 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : $as_echo "#define HAVE_FINITE 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else as_fn_error $? "no" "$LINENO" 5 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi #-------------------------------------------------------------------- # Check for the existence of the -lsocket and -lnsl libraries. # The order here is important, so that they end up in the right # order in the command line generated by make. Here are some # special considerations: # 1. Use "connect" and "accept" to check for -lsocket, and # "gethostbyname" to check for -lnsl. # 2. Use each function name only once: can't redo a check because # autoconf caches the results of the last check and won't redo it. # 3. Use -lnsl and -lsocket only if they supply procedures that # aren't already present in the normal libraries. This is because # IRIX 5.2 has libraries, but they aren't needed and they're # bogus: they goof up name resolution if used. # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. # To get around this problem, check for both libraries together # if -lsocket doesn't work by itself. #-------------------------------------------------------------------- { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sockets" >&5 $as_echo_n "checking for sockets... " >&6; } tcl_checkBoth=0 ac_fn_c_check_func "$LINENO" "connect" "ac_cv_func_connect" if test "x$ac_cv_func_connect" = xyes; then : tcl_checkSocket=0 else tcl_checkSocket=1 fi if test "$tcl_checkSocket" = 1; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lsocket" >&5 $as_echo_n "checking for main in -lsocket... " >&6; } if ${ac_cv_lib_socket_main+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsocket $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_socket_main=yes else ac_cv_lib_socket_main=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_main" >&5 $as_echo "$ac_cv_lib_socket_main" >&6; } if test "x$ac_cv_lib_socket_main" = xyes; then : TLIBS="$TLIBS -lsocket" else tcl_checkBoth=1 fi fi if test "$tcl_checkBoth" = 1; then tk_oldLibs=$TLIBS TLIBS="$TLIBS -lsocket -lnsl" ac_fn_c_check_func "$LINENO" "accept" "ac_cv_func_accept" if test "x$ac_cv_func_accept" = xyes; then : tcl_checkNsl=0 else TLIBS=$tk_oldLibs fi fi ac_fn_c_check_func "$LINENO" "gethostbyname" "ac_cv_func_gethostbyname" if test "x$ac_cv_func_gethostbyname" = xyes; then : else { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lnsl" >&5 $as_echo_n "checking for main in -lnsl... " >&6; } if ${ac_cv_lib_nsl_main+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lnsl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_nsl_main=yes else ac_cv_lib_nsl_main=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nsl_main" >&5 $as_echo "$ac_cv_lib_nsl_main" >&6; } if test "x$ac_cv_lib_nsl_main" = xyes; then : TLIBS="$TLIBS -lnsl" fi fi RL_OBJS="" RL_LIB="" if test "$enable_readline" = "yes" ; then for ac_header in readline/readline.h do : ac_fn_c_check_header_mongrel "$LINENO" "readline/readline.h" "ac_cv_header_readline_readline_h" "$ac_includes_default" if test "x$ac_cv_header_readline_readline_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_READLINE_READLINE_H 1 _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: checking for rl_initialize in -lreadline" >&5 $as_echo_n "checking for rl_initialize in -lreadline... " >&6; } if ${ac_cv_lib_readline_rl_initialize+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lreadline $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char rl_initialize (); int main () { return rl_initialize (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_readline_rl_initialize=yes else ac_cv_lib_readline_rl_initialize=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_readline_rl_initialize" >&5 $as_echo "$ac_cv_lib_readline_rl_initialize" >&6; } if test "x$ac_cv_lib_readline_rl_initialize" = xyes; then : $as_echo "#define HAVE_READLINE 1" >>confdefs.h TLIBS="$TLIBS -lreadline" #some machines don't link this, e.g. Slackware RL_OBJS=gcl_readline.o # Readline support now initialized automatically when compiled in, this lisp # object no longer needed -- 20040102 CM # RL_LIB=lsp/gcl_readline.o fi fi done # These tests discover differences between readline 4.1 and 4.3 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for rl_completion_matches in -lreadline" >&5 $as_echo_n "checking for rl_completion_matches in -lreadline... " >&6; } if ${ac_cv_lib_readline_rl_completion_matches+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lreadline $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char rl_completion_matches (); int main () { return rl_completion_matches (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_readline_rl_completion_matches=yes else ac_cv_lib_readline_rl_completion_matches=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_readline_rl_completion_matches" >&5 $as_echo "$ac_cv_lib_readline_rl_completion_matches" >&6; } if test "x$ac_cv_lib_readline_rl_completion_matches" = xyes; then : $as_echo "#define HAVE_DECL_RL_COMPLETION_MATCHES 1" >>confdefs.h $as_echo "#define HAVE_RL_COMPENTRY_FUNC_T 1" >>confdefs.h fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking For network code for nsocket.c" >&5 $as_echo_n "checking For network code for nsocket.c... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include #include #include /************* for the sockets ******************/ #include /* struct sockaddr, SOCK_STREAM, ... */ #ifndef NO_UNAME # include /* uname system call. */ #endif #include /* struct in_addr, struct sockaddr_in */ #include /* inet_ntoa() */ #include /* gethostbyname() */ int main () { connect(0,(struct sockaddr *)0,0); gethostbyname("jil"); socket(AF_INET, SOCK_STREAM, 0); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : $as_echo "#define HAVE_NSOCKET 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: checking check for listen using fcntl" >&5 $as_echo_n "checking check for listen using fcntl... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main () { FILE *fp=fopen("configure.in","r"); int orig; orig = fcntl(fileno(fp), F_GETFL); if (! (orig & O_NONBLOCK )) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : $as_echo "#define LISTEN_USE_FCNTL 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_fn_c_check_func "$LINENO" "profil" "ac_cv_func_profil" if test "x$ac_cv_func_profil" = xyes; then : else $as_echo "#define NO_PROFILE 1" >>confdefs.h fi ac_fn_c_check_func "$LINENO" "setenv" "ac_cv_func_setenv" if test "x$ac_cv_func_setenv" = xyes; then : $as_echo "#define HAVE_SETENV 1" >>confdefs.h else no_setenv=1 fi if test "$no_setenv" = "1" ; then ac_fn_c_check_func "$LINENO" "putenv" "ac_cv_func_putenv" if test "x$ac_cv_func_putenv" = xyes; then : $as_echo "#define HAVE_PUTENV 1" >>confdefs.h fi fi ac_fn_c_check_func "$LINENO" "_cleanup" "ac_cv_func__cleanup" if test "x$ac_cv_func__cleanup" = xyes; then : $as_echo "#define USE_CLEANUP 1" >>confdefs.h fi gcl_ok=no # if test "x$enable_machine" = "x" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5 $as_echo_n "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O... " >&6; } case $system in OSF*) $as_echo "#define USE_FIONBIO 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5 $as_echo "FIONBIO" >&6; } ;; SunOS-4*) $as_echo "#define USE_FIONBIO 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5 $as_echo "FIONBIO" >&6; } ;; ULTRIX-4.*) $as_echo "#define USE_FIONBIO 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5 $as_echo "FIONBIO" >&6; } ;; *) { $as_echo "$as_me:${as_lineno-$LINENO}: result: O_NONBLOCK" >&5 $as_echo "O_NONBLOCK" >&6; } ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking check for SV_ONSTACK" >&5 $as_echo_n "checking check for SV_ONSTACK... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int joe=SV_ONSTACK; int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : $as_echo "#define HAVE_SV_ONSTACK 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: checking check for SIGSYS" >&5 $as_echo_n "checking check for SIGSYS... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int joe=SIGSYS; int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : $as_echo "#define HAVE_SIGSYS 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: checking check for SIGEMT" >&5 $as_echo_n "checking check for SIGEMT... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int joe=SIGEMT; int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : $as_echo "#define HAVE_SIGEMT 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext for ac_func in sigaltstack do : ac_fn_c_check_func "$LINENO" "sigaltstack" "ac_cv_func_sigaltstack" if test "x$ac_cv_func_sigaltstack" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SIGALTSTACK 1 _ACEOF fi done for ac_func in feenableexcept do : ac_fn_c_check_func "$LINENO" "feenableexcept" "ac_cv_func_feenableexcept" if test "x$ac_cv_func_feenableexcept" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_FEENABLEEXCEPT 1 _ACEOF fi done for ac_header in dis-asm.h do : ac_fn_c_check_header_mongrel "$LINENO" "dis-asm.h" "ac_cv_header_dis_asm_h" "$ac_includes_default" if test "x$ac_cv_header_dis_asm_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_DIS_ASM_H 1 _ACEOF MLIBS=$LIBS { $as_echo "$as_me:${as_lineno-$LINENO}: checking for init_disassemble_info in -lopcodes" >&5 $as_echo_n "checking for init_disassemble_info in -lopcodes... " >&6; } if ${ac_cv_lib_opcodes_init_disassemble_info+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lopcodes $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char init_disassemble_info (); int main () { return init_disassemble_info (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_opcodes_init_disassemble_info=yes else ac_cv_lib_opcodes_init_disassemble_info=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_opcodes_init_disassemble_info" >&5 $as_echo "$ac_cv_lib_opcodes_init_disassemble_info" >&6; } if test "x$ac_cv_lib_opcodes_init_disassemble_info" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBOPCODES 1 _ACEOF LIBS="-lopcodes $LIBS" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 $as_echo_n "checking for dlopen in -ldl... " >&6; } if ${ac_cv_lib_dl_dlopen+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_dl_dlopen=yes else ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 $as_echo "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = xyes; then : #opcodes changes too quickly to link directly for ac_func in print_insn_i386 do : ac_fn_c_check_func "$LINENO" "print_insn_i386" "ac_cv_func_print_insn_i386" if test "x$ac_cv_func_print_insn_i386" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_PRINT_INSN_I386 1 _ACEOF LIBS="$MLIBS -ldl" fi done fi fi done #if test $use = "386-linux" ; then for ac_header in asm/sigcontext.h do : ac_fn_c_check_header_mongrel "$LINENO" "asm/sigcontext.h" "ac_cv_header_asm_sigcontext_h" "$ac_includes_default" if test "x$ac_cv_header_asm_sigcontext_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_ASM_SIGCONTEXT_H 1 _ACEOF fi done for ac_header in asm/signal.h do : ac_fn_c_check_header_mongrel "$LINENO" "asm/signal.h" "ac_cv_header_asm_signal_h" "$ac_includes_default" if test "x$ac_cv_header_asm_signal_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_ASM_SIGNAL_H 1 _ACEOF fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sigcontext..." >&5 $as_echo_n "checking for sigcontext...... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { struct sigcontext foo; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : sigcontext_works=1; $as_echo "#define SIGNAL_H_HAS_SIGCONTEXT 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: sigcontext in signal.h" >&5 $as_echo "sigcontext in signal.h" >&6; } else sigcontext_works=0; { $as_echo "$as_me:${as_lineno-$LINENO}: result: sigcontext NOT in signal.h" >&5 $as_echo "sigcontext NOT in signal.h" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test "$sigcontext_works" = 0 ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sigcontext..." >&5 $as_echo_n "checking for sigcontext...... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #ifdef HAVE_ASM_SIGCONTEXT_H #include #endif #ifdef HAVE_ASM_SIGNAL_H #include #endif int main () { struct sigcontext foo; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : $as_echo "#define HAVE_SIGCONTEXT 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: sigcontext in asm files" >&5 $as_echo "sigcontext in asm files" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no sigcontext found" >&5 $as_echo "no sigcontext found" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi # echo 'foo() {}' > conftest1.c # $CC -S conftest1.c # use_underscore=0 # if fgrep _foo conftest1.s ; then use_underscore=1 ; fi # if test $use_underscore = 0 ; then # MPI_FILE=mpi-386_no_under.o # else # MPI_FILE=mpi-386d.o # fi # AC_SUBST(MPI_FILE) # GCC=$CC # if test -x /usr/bin/i386-glibc20-linux-gcc ; then # GCC=/usr/bin/i386-glibc20-linux-gcc # fi # AC_SUBST(GCC) #fi # Extract the first word of "emacs", so it can be a program name with args. set dummy emacs; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_EMACS+:} false; then : $as_echo_n "(cached) " >&6 else case $EMACS in [\\/]* | ?:[\\/]*) ac_cv_path_EMACS="$EMACS" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_EMACS="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi EMACS=$ac_cv_path_EMACS if test -n "$EMACS"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $EMACS" >&5 $as_echo "$EMACS" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # check for where the emacs site lisp directory is. rm -f conftest.el cat >> conftest.el <&5 $as_echo_n "checking emacs site lisp directory... " >&6; } if [ "$EMACS_SITE_LISP" = "unknown" ] ; then if [ "$EMACS" != "" ] ; then EMACS_SITE_LISP=`$EMACS -q -batch --no-site-file -l conftest.el 2>&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` else EMACS_SITE_LISP="" fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $EMACS_SITE_LISP" >&5 $as_echo "$EMACS_SITE_LISP" >&6; } # check for where the emacs site lisp default.el is rm -f conftest.el cat >> conftest.el <&5 $as_echo_n "checking emacs default.el... " >&6; } if [ "$EMACS" != "" ] ; then EMACS_DEFAULT_EL=`$EMACS -q -batch --no-site-file -l conftest.el 2>&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` else EMACS_DEFAULT_EL="" fi if test -f "${EMACS_DEFAULT_EL}" ; then true;else if test -d $EMACS_SITE_LISP ; then EMACS_DEFAULT_EL=${EMACS_SITE_LISP}/default.el fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $EMACS_DEFAULT_EL" >&5 $as_echo "$EMACS_DEFAULT_EL" >&6; } # check for where the emacs site lisp info/dir is rm -f conftest.el cat >> conftest.el <&5 $as_echo_n "checking emacs info/dir... " >&6; } if test "$use" = "mingw" ; then INFO_DIR=\$\(prefix\)/lib/gcl-$VERSION/info/ else if [ "$EMACS" != "" ] && [ "$INFO_DIR" = "unknown" ] ; then INFO_DIR=`$EMACS -q -batch --no-site-file -l conftest.el 2>&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $INFO_DIR" >&5 $as_echo "$INFO_DIR" >&6; } if test "$enable_tcltk" = "yes" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for tcl/tk" >&5 $as_echo_n "checking for tcl/tk... " >&6; } if test -d "${TCL_CONFIG_PREFIX}" ; then true ; else # Extract the first word of "tclsh", so it can be a program name with args. set dummy tclsh; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_TCLSH+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$TCLSH"; then ac_cv_prog_TCLSH="$TCLSH" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_TCLSH="tclsh" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_TCLSH" && ac_cv_prog_TCLSH="${TCLSH}" fi fi TCLSH=$ac_cv_prog_TCLSH if test -n "$TCLSH"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $TCLSH" >&5 $as_echo "$TCLSH" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "${TCLSH}" = "" ; then true ; else rm -f conftest.tcl cat >> conftest.tcl <&5 $as_echo_n "checking for main in -llieee... " >&6; } if ${ac_cv_lib_lieee_main+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-llieee $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_lieee_main=yes else ac_cv_lib_lieee_main=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_lieee_main" >&5 $as_echo "$ac_cv_lib_lieee_main" >&6; } if test "x$ac_cv_lib_lieee_main" = xyes; then : have_ieee=1 else have_ieee=0 fi if test "$have_ieee" = "0" ; then TCL_LIBS=`echo ${TCL_LIBS} | sed -e "s:-lieee::g" ` fi if test "$have_dl" = "0" ; then TCL_LIBS=`echo ${TCL_LIBS} | sed -e "s:-ldl::g"` fi TCL_STUB_LIBS="" fi fi if test -d "${TK_CONFIG_PREFIX}" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: using TK_VERSION=${TK_VERSION} in ${TK_CONFIG_PREFIX}" >&5 $as_echo "using TK_VERSION=${TK_VERSION} in ${TK_CONFIG_PREFIX}" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: not found" >&5 $as_echo "not found" >&6; } fi NOTIFY=$enable_notify # for sgbc the mprotect capabilities. # the time handling for unixtime, add timezone for ac_header in sys/mman.h do : ac_fn_c_check_header_mongrel "$LINENO" "sys/mman.h" "ac_cv_header_sys_mman_h" "$ac_includes_default" if test "x$ac_cv_header_sys_mman_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SYS_MMAN_H 1 _ACEOF for ac_func in mprotect do : ac_fn_c_check_func "$LINENO" "mprotect" "ac_cv_func_mprotect" if test "x$ac_cv_func_mprotect" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_MPROTECT 1 _ACEOF fi done fi done for ac_header in alloca.h do : ac_fn_c_check_header_mongrel "$LINENO" "alloca.h" "ac_cv_header_alloca_h" "$ac_includes_default" if test "x$ac_cv_header_alloca_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_ALLOCA_H 1 _ACEOF fi done ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default" if test "x$ac_cv_type_size_t" = xyes; then : else cat >>confdefs.h <<_ACEOF #define size_t unsigned int _ACEOF fi # The Ultrix 4.2 mips builtin alloca declared by alloca.h only works # for constant arguments. Useless! { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working alloca.h" >&5 $as_echo_n "checking for working alloca.h... " >&6; } if ${ac_cv_working_alloca_h+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { char *p = (char *) alloca (2 * sizeof (int)); if (p) return 0; ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_working_alloca_h=yes else ac_cv_working_alloca_h=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_working_alloca_h" >&5 $as_echo "$ac_cv_working_alloca_h" >&6; } if test $ac_cv_working_alloca_h = yes; then $as_echo "#define HAVE_ALLOCA_H 1" >>confdefs.h fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for alloca" >&5 $as_echo_n "checking for alloca... " >&6; } if ${ac_cv_func_alloca_works+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __GNUC__ # define alloca __builtin_alloca #else # ifdef _MSC_VER # include # define alloca _alloca # else # ifdef HAVE_ALLOCA_H # include # else # ifdef _AIX #pragma alloca # else # ifndef alloca /* predefined by HP cc +Olibcalls */ void *alloca (size_t); # endif # endif # endif # endif #endif int main () { char *p = (char *) alloca (1); if (p) return 0; ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_func_alloca_works=yes else ac_cv_func_alloca_works=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_alloca_works" >&5 $as_echo "$ac_cv_func_alloca_works" >&6; } if test $ac_cv_func_alloca_works = yes; then $as_echo "#define HAVE_ALLOCA 1" >>confdefs.h else # The SVR3 libPW and SVR4 libucb both contain incompatible functions # that cause trouble. Some versions do not even contain alloca or # contain a buggy version. If you still want to use their alloca, # use ar to extract alloca.o from them instead of compiling alloca.c. ALLOCA=\${LIBOBJDIR}alloca.$ac_objext $as_echo "#define C_ALLOCA 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether \`alloca.c' needs Cray hooks" >&5 $as_echo_n "checking whether \`alloca.c' needs Cray hooks... " >&6; } if ${ac_cv_os_cray+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #if defined CRAY && ! defined CRAY2 webecray #else wenotbecray #endif _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "webecray" >/dev/null 2>&1; then : ac_cv_os_cray=yes else ac_cv_os_cray=no fi rm -f conftest* fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_os_cray" >&5 $as_echo "$ac_cv_os_cray" >&6; } if test $ac_cv_os_cray = yes; then for ac_func in _getb67 GETB67 getb67; do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" if eval test \"x\$"$as_ac_var"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define CRAY_STACKSEG_END $ac_func _ACEOF break fi done fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking stack direction for C alloca" >&5 $as_echo_n "checking stack direction for C alloca... " >&6; } if ${ac_cv_c_stack_direction+:} false; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : ac_cv_c_stack_direction=0 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int find_stack_direction (int *addr, int depth) { int dir, dummy = 0; if (! addr) addr = &dummy; *addr = addr < &dummy ? 1 : addr == &dummy ? 0 : -1; dir = depth ? find_stack_direction (addr, depth - 1) : 0; return dir + dummy; } int main (int argc, char **argv) { return find_stack_direction (0, argc + !argv + 20) < 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_c_stack_direction=1 else ac_cv_c_stack_direction=-1 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_stack_direction" >&5 $as_echo "$ac_cv_c_stack_direction" >&6; } cat >>confdefs.h <<_ACEOF #define STACK_DIRECTION $ac_cv_c_stack_direction _ACEOF fi # alloca # dlopen etc # idea make it so you do something dlopen(libX.so,RTLD_GLOBAL) # then dlload("foo.o") a lisp file can refer to things in libX.so # # what machine this is, and include then a machine specific hdr. # and machine specific defs. # check bzero, # check getcwd, getwd etc.. # check socket stuff.. # getrlimit # fionread or block # redhat/cygnus released for some reason a buggy version of gcc, # which no one else released. Catch that here. LDFLAGS="`echo $LDFLAGS | sed 's,gcl.script,../unixport/gcl.script,g'`" LIBS="$X_PRE_LIBS $X_LIBS $X_EXTRA_LIBS $TLDFLAGS $LIBS $TLIBS" FINAL_CFLAGS="$CFLAGS $CPPFLAGS $X_CFLAGS $TCFLAGS $PROCESSOR_FLAGS" # Work around bug with gcc on ppc -- CM NIFLAGS="$CFLAGS $CPPFLAGS $TCFLAGS $TONIFLAGS $PROCESSOR_FLAGS -I\$(GCLDIR)/o" CFLAGS="$CFLAGS $CPPFLAGS $TCFLAGS $TO3FLAGS $PROCESSOR_FLAGS -I\$(GCLDIR)/o" O3FLAGS=$TO3FLAGS O2FLAGS=$TO2FLAGS if test -f h/$use.defs ; then ac_config_files="$ac_config_files makedefc windows/gcl.iss windows/sysdir.bat windows/install.lsp" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' DEFS=-DHAVE_CONFIG_H ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac case $ac_config_headers in *" "*) set x $ac_config_headers; shift; ac_config_headers=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" config_headers="$ac_config_headers" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE --header=FILE[:TEMPLATE] instantiate the configuration header FILE Configuration files: $config_files Configuration headers: $config_headers Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append CONFIG_HEADERS " '$ac_optarg'" ac_need_defaults=false;; --he | --h) # Conflict between --help and --header as_fn_error $? "ambiguous option: \`$1' Try \`$0 --help' for more information.";; --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "h/gclincl.h") CONFIG_HEADERS="$CONFIG_HEADERS h/gclincl.h" ;; "makedefc") CONFIG_FILES="$CONFIG_FILES makedefc" ;; "windows/gcl.iss") CONFIG_FILES="$CONFIG_FILES windows/gcl.iss" ;; "windows/sysdir.bat") CONFIG_FILES="$CONFIG_FILES windows/sysdir.bat" ;; "windows/install.lsp") CONFIG_FILES="$CONFIG_FILES windows/install.lsp" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. # This happens for instance with `./config.status Makefile'. if test -n "$CONFIG_HEADERS"; then cat >"$ac_tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF # Transform confdefs.h into an awk script `defines.awk', embedded as # here-document in config.status, that substitutes the proper values into # config.h.in to produce config.h. # Create a delimiter string that does not exist in confdefs.h, to ease # handling of long lines. ac_delim='%!_!# ' for ac_last_try in false false :; do ac_tt=`sed -n "/$ac_delim/p" confdefs.h` if test -z "$ac_tt"; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done # For the awk script, D is an array of macro values keyed by name, # likewise P contains macro parameters if any. Preserve backslash # newline sequences. ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* sed -n ' s/.\{148\}/&'"$ac_delim"'/g t rset :rset s/^[ ]*#[ ]*define[ ][ ]*/ / t def d :def s/\\$// t bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3"/p s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p d :bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3\\\\\\n"\\/p t cont s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p t cont d :cont n s/.\{148\}/&'"$ac_delim"'/g t clear :clear s/\\$// t bsnlc s/["\\]/\\&/g; s/^/"/; s/$/"/p d :bsnlc s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p b cont ' >$CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 for (key in D) D_is_set[key] = 1 FS = "" } /^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { line = \$ 0 split(line, arg, " ") if (arg[1] == "#") { defundef = arg[2] mac1 = arg[3] } else { defundef = substr(arg[1], 2) mac1 = arg[2] } split(mac1, mac2, "(") #) macro = mac2[1] prefix = substr(line, 1, index(line, defundef) - 1) if (D_is_set[macro]) { # Preserve the white space surrounding the "#". print prefix "define", macro P[macro] D[macro] next } else { # Replace #undef with comments. This is necessary, for example, # in the case of _POSIX_SOURCE, which is predefined and required # on some systems where configure will not decide to define it. if (defundef == "undef") { print "/*", prefix defundef, macro, "*/" next } } } { print } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 fi # test -n "$CONFIG_HEADERS" eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; :H) # # CONFIG_HEADER # if test x"$ac_file" != x-; then { $as_echo "/* $configure_input */" \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" } >"$ac_tmp/config.h" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 $as_echo "$as_me: $ac_file is unchanged" >&6;} else rm -f "$ac_file" mv "$ac_tmp/config.h" "$ac_file" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 fi else $as_echo "/* $configure_input */" \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ || as_fn_error $? "could not create -" "$LINENO" 5 fi ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi echo makedefc cat makedefc echo add-defs1 $use CC=$CC ./add-defs1 $use else echo "Unable to guess machine type" echo use configure --enable-machine=XXX, for XXX such that h/XXX.defs exists, ie in h/*.defs fi gcl/configure-new.ac000066400000000000000000000635071242227143400147140ustar00rootroot00000000000000AC_INIT() AC_CONFIG_HEADER(h/gclincl.h) # some parts of this configure script are taken from the tcl configure.in # Step 1: set the variable "system" to hold the name and version number # for the system. This can usually be done via the "uname" command, but # there are a few systems, like Next, where this doesn't work. AC_MSG_CHECKING([system version (for dynamic loading)]) if machine=`uname -m` ; then true; else machine=unknown ; fi AC_CHECK_PROGS(AWK,gawk nawk awk,"") AC_CHECK_PROGS(MAKEINFO,makeinfo,"false") AC_SUBST(MAKEINFO) if test -f /usr/lib/NextStep/software_version; then system=NEXTSTEP-`${AWK} '/3/,/3/' /usr/lib/NextStep/software_version` else system=`uname -s`-`uname -r` if test "$?" -ne 0 ; then AC_MSG_RESULT([unknown (can't find uname command)]) system=unknown else # Special check for weird MP-RAS system (uname returns weird # results, and the version is kept in special file). if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then system=MP-RAS-`${AWK} '{print $3}' /etc/.relid'` fi if test "`uname -s`" = "AIX" ; then system=AIX-`uname -v`.`uname -r` fi AC_MSG_RESULT($system) fi fi # Find where Data begins. This is used by the storage allocation # mechanism, in the PAGE macro. This offset is subtracted from # addresses, in calculating a page for an address in the heap. AC_PROG_CC # can only test for numbers -- CM # if test "${GCC}" -eq "yes" ; then if [[ "${GCC}" = "yes" ]] ; then # Allog for environment variable overrides on compiler selection -- CM GCC=$CC else GCC="" fi # subst GCC not only under 386-linux, but where available -- CM AC_SUBST(GCC) AC_CHECK_SIZEOF(long *,0) AC_CHECK_HEADERS(endian.h, AC_MSG_CHECKING("endianness") AC_TRY_RUN([#include int main() { return BYTE_ORDER == __LITTLE_ENDIAN ? 0 : 1;}], AC_DEFINE(LITTLE_END) AC_MSG_RESULT(little), AC_MSG_RESULT(big),AC_MSG_RESULT(big))) AC_SUBST(LITTLE_END) AC_MSG_CHECKING("finding DBEGIN") AC_TRY_RUN([#include #include main() { char *b = (void *) malloc(1000); FILE *fp = fopen("conftest1","w"); fprintf(fp,"0x%lx",((unsigned long) b) & ~(unsigned long)0xffffff); fclose(fp); return 0; }],dbegin=`cat conftest1`,dbegin=0,dbegin=0) AC_DEFINE_UNQUOTED(DBEGIN,$dbegin \ /* where data begins */ ) AC_MSG_RESULT(got $dbegin) AC_MSG_CHECKING("finding CSTACK_ADDRESS") AC_TRY_RUN([#include main() { char *b ; FILE *fp = fopen("conftest1","w"); fprintf(fp,"%d",((int) &b)); fclose(fp); return 0; }],cstack_address=`cat conftest1`,cstack_address=0,cstack_address=0) AC_DEFINE_UNQUOTED(CSTACK_ADDRESS,$cstack_address \ ) AC_MSG_RESULT(got $cstack_address) AC_MSG_CHECKING("sizeof long long int") AC_TRY_RUN([#include main() { if (sizeof(long long int) == 2*sizeof(long)) return 0; return 1; } ],[AC_DEFINE(HAVE_LONG_LONG) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no), AC_MSG_RESULT(no) ) AC_SUBST(HAVE_LONG_LONG) # readline AC_ARG_ENABLE(readline, [--enable-readine enables command line completion via the readline library ],, enable_readline="yes") # ansi lisp AC_ARG_ENABLE(ansi,[--enable-ansi builds a large gcl aiming for ansi compliance, --disable-ansi builds the smaller traditional CLtL1 image],,enable_ansi="no") if test "$enable_ansi" = "yes" ; then FLISP=saved_ansi_gcl; else FLISP=saved_gcl fi AC_SUBST(FLISP) # pagewidth AC_MSG_CHECKING(for pagewidth) AC_TRY_RUN([#include #include int main() {size_t i=getpagesize(),j; FILE *fp=fopen("conftest1","w"); for (j=0;i>>=1;j++); fprintf(fp,"%u",j); return 0;}],PAGEWIDTH=`cat conftest1`,PAGEWIDTH=0,PAGEWIDTH=0) AC_MSG_RESULT($PAGEWIDTH) AC_DEFINE_UNQUOTED(PAGEWIDTH,$PAGEWIDTH) AC_SUBST(PAGEWIDTH) # bfd probe AC_ARG_ENABLE(bfd, [ --disable-bfd prevents gcl from using libbfd.a for fast object loading and symbol table lookups ] ,, enable_bfd="yes") # Maximum number of pages help="--enable-maxpage=XXXX will compile in a page table of size XXX (default ${default_maxpage})" AC_ARG_ENABLE(maxpage,[ --enable-maxpage=XXXX will compile in a page table of size XXX (eg '--enable-maxpage=64*1024' would give 64K pages allowing 256 MB if pages are 4K each)] , [AC_DEFINE_UNQUOTED(MAXPAGE,$enable_maxpage)] ) AC_ARG_ENABLE(vssize,[ --enable-vssize=XXXX will compile in a value stack of size XXX] , [AC_DEFINE_UNQUOTED(VSSIZE,$enable_vssize)] ) AC_ARG_ENABLE(machine,[ --enable-machine=XXXX will force the use of one of the definitions in h/XXXX.defs] , [enable_machine=$enableval],[enable_machine=""]) AC_ARG_ENABLE(gmp,[ --enable-gmp=no will disable use of GMP gnu multiprecision arithmetic, (default is =yes)] , [use_gmp=$enableval],[use_gmp="yes"]) AC_ARG_ENABLE(notify,[ --enable-notify=no will disable the automatic notification of gcl maintainers of successful builds/problems] , [enable_notify=$enableval],[enable_notify="yes"]) AC_ARG_ENABLE(tkconfig,[ --enable-tkconfig=XXXX will force the use of a TK_CONFIG_PREFIX=XXXXX as place to look for tkConfig.sh and tclConfig.sh ] , [TK_CONFIG_PREFIX=$enableval],[TK_CONFIG_PREFIX="unknown"]) AC_ARG_ENABLE(tclconfig,[ --enable-tclconfig=XXXX will force the use of a TCL_CONFIG_PREFIX=XXXXX as place to look for tclConfig.sh and tclConfig.sh ] , [TCL_CONFIG_PREFIX=$enableval],[TCL_CONFIG_PREFIX="unknown"]) AC_ARG_ENABLE(infodir,[ --enable-infodir=XXXX will force the use of a INFO_DIR=XXXXX as place to look for info ] , [INFO_DIR=$enableval],[INFO_DIR="unknown"]) # Check if Posix compliant getcwd exists, if not we'll use getwd. AC_CHECK_FUNCS(getcwd) AC_CHECK_FUNCS(getwd) AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME)) AC_CHECK_FUNC(gettimeofday, , AC_DEFINE(NO_GETTOD)) AC_CHECK_HEADERS(sys/ioctl.h) #-------------------------------------------------------------------- # The code below deals with several issues related to gettimeofday: # 1. Some systems don't provide a gettimeofday function at all # (set NO_GETTOD if this is the case). # 2. SGI systems don't use the BSD form of the gettimeofday function, # but they have a BSDgettimeofday function that can be used instead. # 3. See if gettimeofday is declared in the header file. # if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can # declare it. #-------------------------------------------------------------------- AC_CHECK_FUNC([BSDgettimeofday], [AC_DEFINE(HAVE_BSDGETTIMEOFDAY)], [AC_CHECK_FUNC([gettimeofday], , [AC_DEFINE([NO_GETTOD])])]) AC_MSG_CHECKING([for gettimeofday declaration]) AC_EGREP_HEADER([gettimeofday], [sys/time.h], [AC_MSG_RESULT([present])], [AC_MSG_RESULT([missing]) AC_DEFINE(GETTOD_NOT_DECLARED)]) AC_CHECK_LIB(m,sin,LIBS="${LIBS} -lm",true) AC_CHECK_LIB(mingwex,main,LIBS="${LIBS} -lmingwex",true) # Should really find a way to check for prototypes, but this # basically works for now. CM # AC_CHECK_HEADERS(math.h,AC_DEFINE(NEED_MATH_H)) # # The second alternative is for solaris. This needs to be # a more comprehensive later, i.e. checking that the fpclass # test makes sense. CM # AC_MSG_CHECKING([for isnormal]) AC_TRY_RUN([#define _GNU_SOURCE #include int main() { float f; return isnormal(f) || !isnormal(f) ? 0 : 1; }], AC_DEFINE(HAVE_ISNORMAL) AC_MSG_RESULT(yes), AC_MSG_CHECKING([for fpclass in ieeefp.h]) AC_TRY_RUN([#include int main() { float f; return fpclass(f)>=FP_NZERO || fpclass(f) int main() { float f; return isfinite(f) || !isfinite(f) ? 0 : 1; }], AC_DEFINE(HAVE_ISFINITE) AC_MSG_RESULT(yes), AC_MSG_CHECKING([for finite()]) AC_TRY_RUN([#include int main() { float f; return finite(f) || !finite(f) ? 0 : 1; }], AC_DEFINE(HAVE_FINITE) AC_MSG_RESULT(yes), HAVE_FINITE=0 AC_MSG_RESULT(no),HAVE_FINITE=0 AC_MSG_RESULT(no)) ,HAVE_ISFINITE=0 AC_MSG_RESULT(no),HAVE_ISFINITE=0 AC_MSG_RESULT(no)) #-------------------------------------------------------------------- # Check for the existence of the -lsocket and -lnsl libraries. # The order here is important, so that they end up in the right # order in the command line generated by make. Here are some # special considerations: # 1. Use "connect" and "accept" to check for -lsocket, and # "gethostbyname" to check for -lnsl. # 2. Use each function name only once: can't redo a check because # autoconf caches the results of the last check and won't redo it. # 3. Use -lnsl and -lsocket only if they supply procedures that # aren't already present in the normal libraries. This is because # IRIX 5.2 has libraries, but they aren't needed and they're # bogus: they goof up name resolution if used. # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. # To get around this problem, check for both libraries together # if -lsocket doesn't work by itself. #-------------------------------------------------------------------- AC_MSG_CHECKING([for sockets]) tcl_checkBoth=0 AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) if test "$tcl_checkSocket" = 1; then AC_CHECK_LIB(socket, main, LIBS="$LIBS -lsocket", tcl_checkBoth=1) fi if test "$tcl_checkBoth" = 1; then tk_oldLibs=$LIBS LIBS="$LIBS -lsocket -lnsl" AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs]) fi AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main, [LIBS="$LIBS -lnsl"])) if test "$enable_readline" = "yes" ; then AC_CHECK_LIB([readline], [main], [AC_DEFINE(HAVE_READLINE) LIBS="$LIBS -lreadline -lncurses" RL_OBJS=readline.o RL_LIB=lsp/readline.o],, [-lncurses]) fi if test "$enable_bfd" = "yes" ; then AC_CHECK_HEADER(bfd.h, AC_CHECK_LIB(bfd,bfd_init, if $CC -v 2>&1 | fgrep ming > /dev/null ; then BFDLIB="-lbfd" IBRLIB="-liberty" else echo 'int main() {bfd_init();bfd_openr("/dev/null",0);return 0;}' >foo.c MP=`$GCC [[ -Wl,-M ]] -static -o foo foo.c -lbfd -liberty 2>&1 | tr '()' '\012\012' | $AWK '{print $NF}' | sort | uniq` rm -f foo.c foo BFDLIB=`echo $MP | tr ' ' '\012' | grep libbfd.a` IBRLIB=`echo $MP | tr ' ' '\012' | grep libiberty.a` fi # # Old binutils appear to need CONST defined to const # AC_MSG_CHECKING(if need to define CONST for bfd) AC_TRY_RUN([#define IN_GCC #include int main() { symbol_info t; return 0;}], AC_MSG_RESULT(no) AC_DEFINE(HAVE_LIBBFD) LIBS="$LIBS $BFDLIB $IBRLIB", AC_TRY_RUN([#define IN_GCC #include #define CONST const int main() {symbol_info t; return 0;}], AC_MSG_RESULT(yes) AC_DEFINE(NEED_CONST) AC_DEFINE(HAVE_LIBBFD) LIBS="$LIBS $BFDLIB $IBRLIB", AC_MSG_RESULT(cannot use bfd),AC_MSG_RESULT(cannot use bfd)), AC_MSG_RESULT(cannot use bfd)) ,,-liberty)) fi AC_SUBST(LIBS) AC_SUBST(RL_OBJS) AC_SUBST(RL_LIB) AC_MSG_CHECKING(For network code for nsocket.c) AC_TRY_LINK([ #include #include #include #include #include #include /************* for the sockets ******************/ #include /* struct sockaddr, SOCK_STREAM, ... */ #ifndef NO_UNAME # include /* uname system call. */ #endif #include /* struct in_addr, struct sockaddr_in */ #include /* inet_ntoa() */ #include /* gethostbyname() */ ],[ connect(0,(struct sockaddr *)0,0); gethostbyname("jil"); socket(AF_INET, SOCK_STREAM, 0); ], [AC_DEFINE(HAVE_NSOCKET) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) AC_MSG_CHECKING(check for listen using fcntl) AC_TRY_COMPILE([#include #include ], [FILE *fp=fopen("configure.in","r"); int orig; orig = fcntl(fileno(fp), F_GETFL); if (! (orig & O_NONBLOCK )) return 0; ], [AC_DEFINE(LISTEN_USE_FCNTL) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) AC_CHECK_FUNC(profil, ,[AC_DEFINE(NO_PROFILE)]) AC_SUBST(NO_PROFILE) AC_CHECK_FUNC(setenv,[AC_DEFINE(HAVE_SETENV)],no_setenv=1 ) AC_SUBST(HAVE_SETENV) if test "$no_setenv" = "1" ; then AC_CHECK_FUNC(putenv,[AC_DEFINE(HAVE_PUTENV)],) AC_SUBST(HAVE_PUTENV) fi AC_CHECK_FUNC(_cleanup, [AC_DEFINE(USE_CLEANUP)],) AC_SUBST(USE_CLEANUP) gcl_ok=no AC_HEADER_EGREP(LITTLE_ENDIAN, ctype.h, gcl_ok=yes, gcl_ok=noo) if test $gcl_ok = yes ; then AC_DEFINE(ENDIAN_ALREADY_DEFINED) fi AC_SUBST(ENDIAN_ALREADY_DEFINED) # if test "x$enable_machine" = "x" ; then AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) case $system in OSF*) AC_DEFINE(USE_FIONBIO) AC_MSG_RESULT(FIONBIO) ;; SunOS-4*) AC_DEFINE(USE_FIONBIO) AC_MSG_RESULT(FIONBIO) ;; ULTRIX-4.*) AC_DEFINE(USE_FIONBIO) AC_MSG_RESULT(FIONBIO) ;; *) AC_MSG_RESULT(O_NONBLOCK) ;; esac AC_CANONICAL_HOST canonical=$host ## host=CPU-COMPANY-SYSTEM AC_MSG_RESULT(host=$host) use=unknown case $canonical in older) use=386-bsd;; *86-*-linux*) use=386-linux; ln -snf linux.defs h/$use.defs;; m68k-*-linux*) use=m68k-linux; ln -snf linux.defs h/$use.defs;; alpha*-*-linux*) use=alpha-linux; ln -snf linux.defs h/$use.defs;; mips-*-linux*) use=mips-linux; ln -snf linux.defs h/$use.defs;; mipsel-*-linux*) use=mipsel-linux; ln -snf linux.defs h/$use.defs;; sparc*-*-linux*) use=sparc-linux; ln -snf linux.defs h/$use.defs;; arm*-*-linux*) use=arm-linux; ln -snf linux.defs h/$use.defs;; s390-*-linux*) use=s390-linux; ln -snf linux.defs h/$use.defs;; ia64-*-linux*) use=ia64-linux; ln -snf linux.defs h/$use.defs;; hppa-*-linux*) use=hppa-linux; ln -snf linux.defs h/$use.defs;; powerpc-*-linux*) use=powerpc-linux; ln -snf linux.defs h/$use.defs;; alpha-dec-osf) use=alpha-osf1;; mips-dec-ultrix) use=dec3100;; old) use=dos-go32;; *86*-freebsd) use=FreeBSD;; hp3*-*hpux*) use=hp300;; hp3*-*-*bsd*) use=hp300-bsd;; hppa*-*hpux*) use=hp800;; mips-sgi-irix) case $system in IRIX5*) use=irix5;; IRIX6*) use=irix6;; IRIX3*) use=sgi4d;; esac ;; m68k-apple-aux*) use=mac2;; old) use=mp386;; *86-ncr-sysv4) use=ncr;; *[3-9]86-*netbsd*) use=NetBSD;; old) use=NeXT;; old) use=NeXT30-m68k;; *86-*nextstep*) use=NeXT32-i386;; *m68*-*nextstep*) use=NeXT32-m68k;; *rs6000-*-aix4*) use=rios;; *rs6000-*-aix3*) use=rios-aix3;; old) use=rt_aix;; old) use=sgi;; sparc-sun-solaris*) use=solaris;; i?86-pc-solaris*) use=solaris-i386;; sparc-*-linux*) use=sparc-linux;; old) use=sun2r3;; old) use=sun3;; m68*-sunos*) use=sun3-os4;; old) use=sun386i;; sparc*sunos*) use=sun4;; *86-sequent-dynix) use=symmetry;; u370*aix) use=u370_aix;; old) use=vax;; i*cygwin*) if $CC -v 2>&1 | fgrep ming > /dev/null ; then use=mingw else use=gnuwin95 fi;; esac AC_MSG_CHECKING(check for SV_ONSTACK) AC_TRY_COMPILE([#include int joe=SV_ONSTACK; ], [], [AC_DEFINE(HAVE_SV_ONSTACK) AC_SUBST(HAVE_SV_ONSTACK) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) AC_MSG_CHECKING(check for SIGSYS) AC_TRY_COMPILE([#include int joe=SIGSYS; ], [], [AC_DEFINE(HAVE_SIGSYS) AC_SUBST(HAVE_SIGSYS) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) AC_MSG_CHECKING(check for SIGEMT) AC_TRY_COMPILE([#include int joe=SIGEMT; ], [], [AC_DEFINE(HAVE_SIGEMT) AC_SUBST(HAVE_SIGEMT) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) #if test $use = "386-linux" ; then AC_CHECK_HEADERS(asm/sigcontext.h) AC_CHECK_HEADERS(asm/signal.h) AC_TRY_COMPILE([#include long code; ], [ void *p = ((void *)(((struct sigcontext_struct *)(&code)))); ], [ sigcontext_struct_works=1; AC_DEFINE(SIGNAL_H_HAS_SIGCONTEXT) AC_MSG_RESULT("sigcontext in signal.h") ], [sigcontext_struct_works=0; AC_MSG_RESULT("sigcontext NOT in signal.h")] ) if test "$sigcontext_struct_works" = 0 ; then AC_TRY_COMPILE([#include #ifdef HAVE_ASM_SIGCONTEXT_H #include #endif #ifdef HAVE_ASM_SIGNAL_H #include #endif long code; ], [ void *p = ((void *)(((struct sigcontext *)(&code)))); ], [ sigcontext_works=1 ; AC_DEFINE(HAVE_SIGCONTEXT) AC_MSG_RESULT("use struct sigcontext") ], [ sigcontext_works=0 ; ]) fi # echo 'foo() {}' > conftest1.c # $CC -S conftest1.c # use_underscore=0 # if fgrep _foo conftest1.s ; then use_underscore=1 ; fi # if test $use_underscore = 0 ; then # MPI_FILE=mpi-386_no_under.o # else # MPI_FILE=mpi-386d.o # fi # AC_SUBST(MPI_FILE) # GCC=$CC # if test -x /usr/bin/i386-glibc20-linux-gcc ; then # GCC=/usr/bin/i386-glibc20-linux-gcc # fi # AC_SUBST(GCC) #fi AC_PATH_PROG(EMACS,emacs) # check for where the emacs site lisp directory is. rm -f conftest.el cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d ` else EMACS_SITE_LISP="" fi AC_MSG_RESULT($EMACS_SITE_LISP) AC_SUBST(EMACS_SITE_LISP) # check for where the emacs site lisp default.el is rm -f conftest.el cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d ` else EMACS_DEFAULT_EL="" fi if test -f "${EMACS_DEFAULT_EL}" ; then true;else if test -d "$EMACS_SITE_LISP" ; then EMACS_DEFAULT_EL=${EMACS_SITE_LISP}/default.el fi fi AC_MSG_RESULT($EMACS_DEFAULT_EL) AC_SUBST(EMACS_DEFAULT_EL) # check for where the emacs site lisp info/dir is rm -f conftest.el cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d ` fi if test -f "${INFO_DIR}dir" ; then true;else if test -f /usr/info/dir ; then INFO_DIR=/usr/info/ else true; fi fi AC_MSG_RESULT($INFO_DIR) AC_SUBST(INFO_DIR) AC_MSG_CHECKING([for tcl/tk]) if test -d "${TCL_CONFIG_PREFIX}" ; then true ; else rm -f conftest.tcl cat >> conftest.tcl <> conftest.tcl <&1 | ${AWK} '/"source / {if (i++) next;sub("/[[^/]]*$","",$2);print $2}'` fi fi fi #AC_MSG_CHECKING(TK_CONFIG_PREFIX=${TK_CONFIG_PREFIX}) if test -f ${TK_CONFIG_PREFIX}/tkConfig.sh ; then . ${TK_CONFIG_PREFIX}/tkConfig.sh ; fi if test -d ${TK_CONFIG_PREFIX}/tk${TK_VERSION} ; then TK_LIBRARY=${TK_CONFIG_PREFIX}/tk${TK_VERSION} else if test -d ${TK_CONFIG_PREFIX}/../tk${TK_VERSION} ; then TK_LIBRARY=${TK_CONFIG_PREFIX}/../tk${TK_VERSION} fi fi if test -d ${TK_CONFIG_PREFIX}/tcl${TCL_VERSION} ; then TCL_LIBRARY=${TK_CONFIG_PREFIX}/tcl${TCL_VERSION} else if test -d ${TK_CONFIG_PREFIX}/../tcl${TCL_VERSION} ; then TCL_LIBRARY=${TK_CONFIG_PREFIX}/../tcl${TCL_VERSION} fi fi if test -f ${TK_CONFIG_PREFIX}/../include/tk.h ; then TK_INCLUDE=-I${TK_CONFIG_PREFIX}/../include else if test -f /usr/include/tcl${TCL_VERSION}/tk.h ; then TK_INCLUDE=-I/usr/include/tcl${TCL_VERSION} fi fi if test -f ${TCL_CONFIG_PREFIX}/../include/tcl.h ; then TCL_INCLUDE=-I${TCL_CONFIG_PREFIX}/../include else if test -f /usr/include/tcl${TCL_VERSION}/tcl.h ; then TCL_INCLUDE=-I/usr/include/tcl${TCL_VERSION} fi fi AC_CHECK_LIB(lieee,main,have_ieee=1,have_ieee=0) if test "$have_ieee" = "0" ; then TCL_LIBS=`echo ${TCL_LIBS} | sed -e "s:-lieee::g" ` fi AC_CHECK_LIB(dl,dlopen,have_dl=1,have_dl=0) if test "$have_dl" = "0" ; then TCL_LIBS=`echo ${TCL_LIBS} | sed -e "s:-ldl::g"` fi AC_SUBST(TK_CONFIG_PREFIX) AC_SUBST(TK_LIBRARY) AC_SUBST(TCL_LIBRARY) AC_SUBST(TK_XINCLUDES) AC_SUBST(TK_INCLUDE) AC_SUBST(TCL_INCLUDE) AC_SUBST(TK_LIB_SPEC) AC_SUBST(TK_BUILD_LIB_SPEC) AC_SUBST(TK_XLIBSW) AC_SUBST(TK_XINCLUDES) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_DL_LIBS) AC_SUBST(TCL_LIBS) if test -d "${TK_CONFIG_PREFIX}" ; then AC_MSG_RESULT([using TK_VERSION=${TK_VERSION} in ${TK_CONFIG_PREFIX}]) else AC_MSG_RESULT([not found]) fi NOTIFY=$enable_notify AC_SUBST(NOTIFY) echo enable_machine=$enable_machine if test "x$enable_machine" != "x" ; then use=$enable_machine fi ## finally warn if we did not find a recognized machine.s ## #if test "$use" = "unknown" ; then #types=`echo h/*.defs` | sed -e "s:h/::g" -e "s:\.defs:g"` #echo got canonical=$canonical, but was not recognized. #echo Unable to guess type to use. Try one of #exit(1) #fi AC_MSG_RESULT(use=$use) # for sgbc the mprotect capabilities. # the time handling for unixtime, add timezone AC_MSG_CHECKING([alloca]) AC_TRY_RUN([int main() { exit(alloca(500) != NULL ? 0 : 1);}], ,gcl_ok=yes, gcl_ok=no,gcl_ok=no) if test $gcl_ok = yes ; then AC_MSG_RESULT(yes) AC_DEFINE(HAVE_ALLOCA) else AC_TRY_RUN([#include int main() { exit(alloca(500) != NULL ? 0 : 1)}], ,gcl_ok=yes, gcl_ok=no,gcl_ok=no) if test $gcl_ok = yes ; then AC_MSG_RESULT(yes) AC_DEFINE(HAVE_ALLOCA) AC_DEFINE(NEED_ALLOCA_H) fi fi if test $gcl_ok = no ; then AC_MSG_RESULT(no) ; fi # alloca # dlopen etc # idea make it so you do something dlopen(libX.so,RTLD_GLOBAL) # then dlload("foo.o") a lisp file can refer to things in libX.so # # what machine this is, and include then a machine specific hdr. # and machine specific defs. # check bzero, # check getcwd, getwd etc.. # check socket stuff.. # getrlimit # fionread or block rm -f makedefsafter MP_INLCUDE="" if test $use_gmp = yes ; then AC_MSG_CHECKING([use_gmp=yes, doing configure in gmp directory]) case "${canonical}" in # i[[5-9]]86* | pentium* | k6* | athlon*) # (cd gmp ; ./configure --target=i486) ;; *) (cd gmp ; ./configure) ;; esac [[ "`ls -1 gmp/mpn/add_n.* 2>/dev/null`" != "" ]] || cp gmp/mpn/generic/*.c gmp/mpn/ AC_MSG_CHECKING("for size of gmp limbs") AC_TRY_RUN([#include #include "h/gmp.h" int main() { FILE *fp=fopen("conftest1","w"); fprintf(fp,"%u",sizeof(mp_limb_t)); fclose(fp); return 0; }],mpsize=`cat conftest1`,mpsize=0,mpsize=0) if test "$mpsize" = "0" ; then echo "Cannot determine mpsize" exit 1 fi AC_DEFINE_UNQUOTED(MP_LIMB_BYTES,$mpsize) AC_MSG_RESULT($mpsize) GMP=1 AC_DEFINE(GMP) AC_SUBST(GMP) MP_INCLUDE=h/gmp.h echo > makedefsafter echo 'MPFILES=${GMP_DIR}libgmp.a' >> makedefsafter echo >> makedefsafter fi AC_SUBST(MP_INCLUDE) # redhat/cygnus released for some reason a buggy version of gcc, # which no one else released. Catch that here. AC_MSG_CHECKING([Checking for buggy gcc version from redhat]) if 2>&1 $CC -v | fgrep "gcc version 2.96" > /dev/null then BROKEN_O4_OPT=1 AC_DEFINE(BROKEN_O4_OPT) AC_SUBST(BROKEN_O4_OPT) echo ODIR_DEBUG=-O >> makedefsafter echo >> makedefsafter AC_MSG_RESULT([yes .. turning off -O4]) else AC_MSG_RESULT([no]) fi if test -f h/$use.defs ; then AC_SUBST(use) AC_OUTPUT(makedefc) echo makedefc cat makedefc echo add-defs1 $use CC=$CC ./add-defs1 $use else echo "Unable to guess machine type" echo use configure --enable-machine=XXX, for XXX such that h/XXX.defs exists, ie in h/*.defs fi gcl/configure.in000066400000000000000000002375711242227143400141540ustar00rootroot00000000000000AC_INIT() AC_PREREQ([2.61]) AC_CONFIG_HEADER(h/gclincl.h) VERSION=`cat majvers`.`cat minvers` AC_SUBST(VERSION) # some parts of this configure script are taken from the tcl configure.in # # Arguments # dnl help="--enable-maxpage=XXXX will compile in a page table of size XXX (default ${default_maxpage})" dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ dnl #include dnl #include dnl ]],[[ dnl FILE *fp=fopen("conftest1","w"); dnl fprintf(fp,"%u",262144*( SIZEOF_LONG >>2)/(1<<($PAGEWIDTH-12))); dnl return 0;]])],[def_maxpage=`cat conftest1`],[def_maxpage=262144]) dnl AC_ARG_ENABLE(maxpage, dnl [ --enable-maxpage=XXXX will compile in a page table of size XXX dnl (eg '--enable-maxpage=64*1024' would produce dnl 64K pages allowing 256 MB if pages are 4K each)], dnl ,enable_maxpage=$def_maxpage) AC_ARG_ENABLE(widecons,[use a three word cons with simplified typing],[AC_DEFINE([WIDE_CONS],[1],[three word cons])]) AC_ARG_ENABLE(safecdr,[protect cdr from immfix and speed up type processing],,[enable_safecdr="no"]) if test "$enable_safecdr" = "yes" ; then AC_DEFINE([USE_SAFE_CDR],[1],[protect cdr from immfix and speed up type processing]) fi AC_ARG_ENABLE(safecdrdbg,[debug safecdr code],[AC_DEFINE([DEBUG_SAFE_CDR],[1],[debug safecdr code])]) AC_ARG_ENABLE([prelink],[--enable-prelink will insist that the produced images may be prelinked],[PRELINK_CHECK=t],[PRELINK_CHECK=]) AC_ARG_ENABLE([fastimmfix],[--enable-fastimmfix=XXXX will reject low immediate fixnums unless 1<=2) print A[[2]]}'` AC_DEFINE_UNQUOTED(HOST_CPU,"`echo $host_cpu | awk '{print toupper($0)}'`",[Host cpu]) AC_DEFINE_UNQUOTED(HOST_KERNEL,"`echo $my_host_kernel | awk '{print toupper($0)}'`",[Host kernel]) if test "$my_host_system" != "" ; then AC_DEFINE_UNQUOTED(HOST_SYSTEM,"`echo $my_host_system | awk '{print toupper($0)}'`",[Host system]) fi ## host=CPU-COMPANY-SYSTEM AC_MSG_RESULT(host=$host) PROCESSOR_FLAGS=${PROCESSOR_FLAGS:-""} use=unknown TLDFLAGS="" case $canonical in older) use=386-bsd;; sh4*linux*) use=sh4-linux;; *x86_64*linux*) use=amd64-linux;; *x86_64*kfreebsd*) use=amd64-kfreebsd;; *86*linux*) use=386-linux;; *86*kfreebsd*) use=386-kfreebsd;; *86*gnu*) use=386-gnu;; # m6800 not working with gcc-3.2 m68k*linux*) if test "$use_common_binary" = "yes"; then host=m68020-unknown-linux-gnu echo "The host is canonicalised to $host" fi use=m68k-linux;; alpha*linux*) use=alpha-linux;; mips*linux*) use=mips-linux;; mipsel*linux*) use=mipsel-linux;; sparc*linux*) use=sparc-linux;; aarch64*linux*) use=aarch64-linux;; arm*linux*) use=arm-linux;; s390*linux*) use=s390-linux;; ia64*linux*) use=ia64-linux;; hppa*linux*) use=hppa-linux;; powerpc*linux*) use=powerpc-linux;; powerpc-*-darwin*) use=powerpc-macosx;; *86*darwin*) use=386-macosx if test "$build_cpu" = "x86_64" ; then CFLAGS="-m64 $CFLAGS"; LDFLAGS="-m64 -Wl,-headerpad,72 $LDFLAGS"; else CFLAGS="-m32 $CFLAGS"; LDFLAGS="-m32 -Wl,-headerpad,56 $LDFLAGS"; fi;; alpha-dec-osf) use=alpha-osf1;; mips-dec-ultrix) use=dec3100;; old) use=dos-go32;; *86*-freebsd*) use=FreeBSD;; hp3*-*hpux*) use=hp300;; hp3*-*-*bsd*) use=hp300-bsd;; hppa*-*hpux*) use=hp800;; mips-sgi-irix) case $system in IRIX5*) use=irix5;; IRIX6*) use=irix6;; IRIX3*) use=sgi4d;; esac ;; m68k-apple-aux*) use=mac2;; old) use=mp386;; *86-ncr-sysv4) use=ncr;; *[3-9]86-*netbsd*) use=NetBSD;; old) use=NeXT;; old) use=NeXT30-m68k;; *86-*nextstep*) use=NeXT32-i386;; *m68*-*nextstep*) use=NeXT32-m68k;; *rs6000-*-aix4*) use=rios;; *rs6000-*-aix3*) use=rios-aix3;; old) use=rt_aix;; old) use=sgi;; sparc-sun-solaris*) use=solaris;; i?86-pc-solaris*) use=solaris-i386;; old) use=sun2r3;; old) use=sun3;; m68*-sunos*) use=sun3-os4;; old) use=sun386i;; sparc*sunos*) use=sun4;; *86-sequent-dynix) use=symmetry;; u370*aix) use=u370_aix;; old) use=vax;; i*mingw*) if test "$use_common_binary" = "yes"; then host=i386-pc-mingw32 PROCESSOR_FLAGS="-march=i386 " echo "The host is canonicalised to $host" fi use=mingw;; i*cygwin*) if $CC -v 2>&1 | fgrep ming > /dev/null ; then use=mingw else use=gnuwin95 fi;; *openbsd*) # 'ld -Z' means disable W^X TLDFLAGS="$TLDFLAGS -Z" use=FreeBSD;; esac AC_SUBST(PROCESSOR_FLAGS) echo enable_machine=$enable_machine if test "x$enable_machine" != "x" ; then use=$enable_machine fi def_dlopen="no" def_statsysbfd="no" def_custreloc="yes" #def_statsysbfd="yes" #def_custreloc="no" def_locbfd="no" def_oldgmp="no" def_pic="no"; def_static="no"; def_debug="no"; case $use in *kfreebsd) ln -snf linux.defs h/$use.defs;; *gnu) ln -snf linux.defs h/$use.defs;; *linux) ln -snf linux.defs h/$use.defs; case $use in # def_static -- Function descriptors are currently realized at runtime in a non-reproducible fashion # on these architectures -- CM powerpc*) # if test "$host_cpu" = "powerpc64" ; then def_dlopen="yes" ; def_custreloc="no" ; fi ;; ia64*) def_dlopen="yes" ; def_custreloc="no" ;; hppa*) def_pic="yes" ;; # def_dlopen="yes" ; def_custreloc="no" ; def_pic="yes" ;; esac;; esac AC_ARG_ENABLE(dlopen, [ --enable-dlopen uses dlopen for loading objects, which can then not be retained in saved images ] ,,enable_dlopen="$def_dlopen") AC_ARG_ENABLE(statsysbfd, [ --enable-statsysbfd uses a static sytem bfd library for loading and relocationing object files ] ,,enable_statsysbfd="$def_statsysbfd") AC_ARG_ENABLE(dynsysbfd, [ --enable-dynsysbfd uses a dynamic shared sytem bfd library for loading and relocationing object files ] ,,enable_dynsysbfd="no") #AC_ARG_ENABLE(locbfd, # [ --enable-locbfd uses a static bfd library built from this source tree for loading and relocationing object files ] # ,,enable_locbfd="$def_locbfd") AC_ARG_ENABLE(custreloc, [ --enable-custreloc uses custom gcl code if available for loading and relocationing object files ] ,,enable_custreloc="$def_custreloc") AC_ARG_ENABLE(debug, [ --enable-debug builds gcl with -g in CFLAGS to enable running under gdb ] ,,enable_debug="$def_debug") AC_ARG_ENABLE(gprof, [ --enable-gprof builds gcl with -pg in CFLAGS to enable profiling with gprof ] ,,enable_gprof="no") AC_ARG_ENABLE(static,[ --enable-static will link your GCL against static as opposed to shared system libraries ] , [enable_static=$enableval],[enable_static="$def_static"]) AC_ARG_ENABLE(pic, [ --enable-pic builds gcl with -fPIC in CFLAGS ] ,,enable_pic="$def_pic") AC_ARG_ENABLE(oldgmp, [ --enable-oldgmp will link against gmp2 instead of gmp3 ] ,,enable_oldgmp="$def_oldgmp") AC_ARG_ENABLE(dynsysgmp, [ --enable-dynsysgmp will link against the system libgmp3 overriding certain functions with patched versions from the local source ] ,,enable_dynsysgmp="yes") load_opt="0" if test "$enable_dlopen" = "yes" ; then load_opt=1 fi if test "$enable_statsysbfd" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; esac fi if test "$enable_dynsysbfd" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; 2) load_opt=3;; esac fi if test "$enable_locbfd" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; 2) load_opt=3;; 3) load_opt=4;; esac fi if test "$enable_custreloc" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; 2) load_opt=3;; 3) load_opt=4;; 4) load_opt=5;; esac fi if test "$load_opt" != "1" ; then echo "Exactly one loader option must be chosen: dlopen=$enable_dlopen statsysbfd=$enable_statsysbfd dynsysbfd=$enable_dynsysbfd locbfd=$enable_locbfd custreloc=$enable_custreloc" exit 1 fi TLDFLAGS="" if test "$enable_static" = "yes" ; then TLDFLAGS="-static -Wl,-zmuldefs $TLDFLAGS"; #FIXME should be in unixport/makefile AC_DEFINE(STATIC_LINKING,1,[staticly linked images]) fi case $use in *gnuwin*) TLDFLAGS="$TLDFLAGS -Wl,--stack,8000000";; esac ## finally warn if we did not find a recognized machine.s ## #if test "$use" = "unknown" ; then #types=`echo h/*.defs` | sed -e "s:h/::g" -e "s:\.defs:g"` #echo got canonical=$canonical, but was not recognized. #echo Unable to guess type to use. Try one of #exit(1) #fi AC_MSG_RESULT([use=$use]) # # System programs # # We set the default CFLAGS below, and don't want the autoconf default # CM 20040106 if test "$CFLAGS" = "" ; then CFLAGS=" " fi if test "$LDFLAGS" = "" ; then LDFLAGS=" " fi AC_PROG_CC AC_PROG_CPP AC_SUBST(CC) # can only test for numbers -- CM # if test "${GCC}" -eq "yes" ; then #if [[ "${GCC}" = "yes" ]] ; then # Allog for environment variable overrides on compiler selection -- CM #GCC=$CC #else #GCC="" #fi # subst GCC not only under 386-linux, but where available -- CM if test "$GCC" = "yes" ; then TCFLAGS="-Wall -fsigned-char" #FIXME -Wno-unused-but-set-variable when time TMPF=-Wno-unused-but-set-variable AC_MSG_CHECKING([for CFLAG $TMPF]) CFLAGS_ORI=$CFLAGS CFLAGS="$CFLAGS $TMPF" AC_TRY_RUN([int main() {return 0;}],TCFLAGS="$TCFLAGS $TMPF";AC_MSG_RESULT(yes),AC_MSG_RESULT(no),AC_MSG_RESULT(no)) CFLAGS=$CFLAGS_ORI else TCFLAGS="-fsigned-char" fi if test "$GCC" = "yes" ; then TCFLAGS="$TCFLAGS -pipe" case $use in *mingw*|*gnuwin*) # echo "WARNING: Remove -fno-zero-initialized-in-bss from makedefs if gcc less than 3.3.1." # echo " It is otherwise needed for the Unexec stuff to work." # if test "$enable_debug" = "yes" ; then TCFLAGS="$TCFLAGS -gstabs" ; fi TCFLAGS="$TCFLAGS -fno-zero-initialized-in-bss -mms-bitfields";; esac fi #if test -f /proc/sys/kernel/exec-shield ; then # exec_stat=`cat /proc/sys/kernel/exec-shield` # if test "$exec_stat" != "0" ; then # # CFLAGS here to hopefully cover the DBEGIN routine below # CFLAGS="$CFLAGS -Wa,--execstack" # fi #fi TO3FLAGS="" TO2FLAGS="" #TFPFLAG="-fomit-frame-pointer" # FIXME -- remove when mingw compiler issues are fixed case "$use" in *mingw*) TFPFLAG="";; m68k*)#FIXME gcc 4.x bug workaround TFPFLAG="";; *) TFPFLAG="-fomit-frame-pointer";; esac AC_CHECK_PROGS(AWK,[gawk nawk awk]) # Work around system/gprof mips/hppa hang AC_MSG_CHECKING([working gprof]) old_enable_gprof=$enable_gprof case $use in powerpc*) if test "$host_cpu" = "powerpc64le" ; then enable_gprof="no"; fi;; sh4*) enable_gprof="no";; ia64*) enable_gprof="no";; # mips*) enable_gprof="no";; hppa*) enable_gprof="no";; arm*) enable_gprof="no";;#FIXME mcount compiled as a 24/22 bit reloc even with -mlong-calls, marginally accessible *gnu) enable_gprof="no";; esac if test "$enable_gprof" = "$old_enable_gprof" ; then AC_MSG_RESULT([ok]) else AC_MSG_RESULT([disabled]) fi if test "$enable_gprof" = "yes" ; then AC_MSG_CHECKING(for text start) echo 'int main () {return(0);}' >foo.c $CC foo.c -o foo GCL_GPROF_START=`nm foo | $AWK '/ *[[TD]] *__*start$/ {print $NF}'` # D for ppc64 -- FIXME custreloc rm -f foo.c foo if test "$GCL_GPROF_START" != "" ; then AC_MSG_RESULT($GCL_GPROF_START) AC_DEFINE_UNQUOTED(GCL_GPROF_START,$GCL_GPROF_START,[starting address for gprof]) case "$use" in arm*) #FIXME report and remove this when done AC_MSG_RESULT(Reducing optimization on profiling arm build to workaround gcc bug) enable_debug=yes;; esac TCFLAGS="$TCFLAGS -pg"; TLIBS="$TLIBS -pg"; TFPFLAG="" AC_DEFINE(GCL_GPROF,1,[use gprof profiling]) else enable_gprof="no"; fi fi if $CC -v 2>&1 | tail -1 | grep "gcc version 4.6.1" >/dev/null ; then case "$use" in arm*) #FIXME report and remove this when done AC_MSG_RESULT(Reducing optimization on arm build to workaround gcc 4.6 bug) enable_debug=yes;; esac fi if test "$enable_debug" = "yes" ; then TCFLAGS="$TCFLAGS -g" # for subconfigurations CFLAGS="$CFLAGS -g" else TO3FLAGS="-O3 $TFPFLAG" TO2FLAGS="-O" fi # gcc on ppc cannot compile our new_init.c with full opts --CM TONIFLAGS="" case $use in powerpc*macosx) TCFLAGS="$TCFLAGS -mlongcall";; *linux) case $use in # amd64*) # stack-boundary option does not work # TCFLAGS="$TCFLAGS -m64 -mpreferred-stack-boundary=8";; alpha*) TCFLAGS="$TCFLAGS -mieee" if test "$enable_debug" != "yes" ; then TO3FLAGS="-O0" ; fi #FIXME needed asof gcc 4.8.1 ;; # m68k*) # TCFLAGS="$TCFLAGS -ffloat-store";; aarch64*) TLIBS="$TLIBS -lgcc_s";; hppa*) TCFLAGS="$TCFLAGS -mlong-calls " TLIBS="$TLIBS -lgcc_s" # workaround hppa __moddi3 local func symbols with default linker flags if test "$enable_debug" != "yes" ; then TO3FLAGS="-O2" ; TFPFLAG=""; fi #FIXME needed asof gcc 4.8.1 # TCFLAGS="$TCFLAGS -ffunction-sections" # if test "$enable_debug" != "yes" ; then TO3FLAGS="-O $TFPFLAG" ; fi # if test "$enable_debug" != "yes" ; then TO2FLAGS="-O" ; fi ;; mips*) # if test "$enable_debug" != "yes" ; then TO3FLAGS="-O0" ; fi #FIXME needed asof gcc 4.6.2 ;; ia64*) if test "$enable_debug" != "yes" ; then TO3FLAGS="-O" ; fi #FIXME needed asof gcc 4.8.1 ;; arm*) TCFLAGS="$TCFLAGS -mlong-calls -fdollars-in-identifiers -g " # if test "$enable_debug" != "yes" ; then TO3FLAGS="-O" ; fi #FIXME needed asof gcc 4.6.2 # if test "$enable_debug" != "yes" ; then TO2FLAGS="-O" ; fi ;; powerpc*) TCFLAGS="$TCFLAGS -mlongcall" ;; # if $CC -v 2>&1 | grep -q "gcc version 3.2" ; then # echo Reducing optimization for buggy gcc-3.2 # if test "$enable_debug" != "yes" ; then TONIFLAGS="-O $TFPFLAG" ; fi # fi; # echo Probing for longcall # if ! $CC -v 2>&1 | $AWK '/^gcc version / {split($3,A,".");if (A[[1]]+0>3 || (A[[1]]+0>=3 && A[[2]]+0>=3)) exit 1;}'; then # echo Enabling longcall on gcc 3.3 or later # TCFLAGS="$TCFLAGS -mlongcall" # echo Reducing optimization for buggy gcc 3.3 or later # if test "$enable_debug" != "yes" ; then TONIFLAGS="-O $TFPFLAG" ; fi # fi;; esac;; esac if test "$enable_pic" = "yes" ; then TCFLAGS="$TCFLAGS -fPIC" fi FDEBUG=`echo $CFLAGS | tr ' ' '\012' |grep "^\-g$"|tr '\012' ' '` #CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-g$"` FOMITF=`echo $CFLAGS | tr ' ' '\012' |grep "^\-fomit-frame-pointer$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-fomit-frame-pointer$"|tr '\012' ' '` FOOPT3=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O3$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O3$"|tr '\012' ' '` FOOPT2=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O2$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O2$"|tr '\012' ' '` FOOPT1=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O1$"|tr '\012' ' '` TMPF=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O$"|tr '\012' ' '` FOOPT1="$FOOPT1$TMPF" CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O1$"|grep -v "^\-O$"|tr '\012' ' '` FOOPT0=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O0$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O0$"|tr '\012' ' '` if test "$FOOPT0" != "" ; then TO3FLAGS=`echo $TO3FLAGS | sed 's,\-O[[123 ]],-O0 ,g' | sed 's,\-O$,-O0 ,g'` TO2FLAGS=`echo $TO2FLAGS | sed 's,\-O[[123 ]],-O0 ,g' | sed 's,\-O$,-O0 ,g'` else if test "$FOOPT1" != "" ; then TO3FLAGS=`echo $TO3FLAGS | sed 's,\-O[[2-3]],-O1,g'` TO2FLAGS=`echo $TO2FLAGS | sed 's,\-O[[2-3]],-O1,g'` else if test "$FOOPT2" != "" ; then TO3FLAGS=`echo "$TO3FLAGS" | sed 's,\-O3,-O2,g'` TO2FLAGS=`echo "$TO2FLAGS" | sed 's,\-O3,-O2,g'` fi fi fi if test "$FDEBUG" != "" ; then TO3FLAGS=`echo $TO3FLAGS | sed 's,\-fomit-frame-pointer,,g'` TO2FLAGS=`echo $TO2FLAGS | sed 's,\-fomit-frame-pointer,,g'` fi if test "$FOMITF" != "" ; then TO3FLAGS="$TO3FLAGS $FOMITF" fi # Step 1: set the variable "system" to hold the name and version number # for the system. This can usually be done via the "uname" command, but # there are a few systems, like Next, where this doesn't work. AC_MSG_CHECKING([system version (for dynamic loading)]) if machine=`uname -m` ; then true; else machine=unknown ; fi AC_CHECK_PROGS(MAKEINFO,makeinfo,"false") AC_SUBST(MAKEINFO) if test -f /usr/lib/NextStep/software_version; then system=NEXTSTEP-`${AWK} '/3/,/3/' /usr/lib/NextStep/software_version` else system=`uname -s`-`uname -r` if test "$?" -ne 0 ; then AC_MSG_RESULT([unknown (can't find uname command)]) system=unknown else # Special check for weird MP-RAS system (uname returns weird # results, and the version is kept in special file). if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then system="MP-RAS-`${AWK} '{print $3}' '/etc/.relid'`" fi if test "`uname -s`" = "AIX" ; then system=AIX-`uname -v`.`uname -r` fi AC_MSG_RESULT($system) fi fi case $use in *macosx) AC_CHECK_HEADERS(malloc/malloc.h,,[AC_MSG_ERROR([need malloc.h on macosx])]) AC_CHECK_MEMBER([struct _malloc_zone_t.memalign], AC_DEFINE(HAVE_MALLOC_ZONE_MEMALIGN,1,[memalign element present]), [], [ #include ]) AC_SUBST(HAVE_MALLOC_ZONE_MEMALIGN) ;; esac AC_CHECK_HEADERS(setjmp.h, AC_MSG_CHECKING([sizeof jmp_buf]) AC_RUN_IFELSE([ AC_LANG_SOURCE([[ #include #include int main() { FILE *fp=fopen("conftest1","w"); fprintf(fp,"%lu\n",sizeof(jmp_buf)); fclose(fp); return 0; }]])], [sizeof_jmp_buf=`cat conftest1` AC_MSG_RESULT($sizeof_jmp_buf) AC_DEFINE_UNQUOTED(SIZEOF_JMP_BUF,$sizeof_jmp_buf,[sizeof jmp_buf])], [AC_MSG_RESULT(no)])) # sysconf AC_CHECK_HEADERS(unistd.h, AC_CHECK_LIB(c,sysconf, AC_MSG_CHECKING(_SC_CLK_TCK) AC_TRY_RUN([#include #include int main() { FILE *fp=fopen("conftest1","w"); fprintf(fp,"%lu\n",sysconf(_SC_CLK_TCK)); fclose(fp); return 0; }], hz=`cat conftest1` AC_DEFINE_UNQUOTED(HZ,$hz,[time system constant]) ,hz=0,hz=0) [AC_MSG_RESULT($hz)] dnl AC_MSG_CHECKING(_SC_PHYS_PAGES) dnl AC_RUN_IFELSE([ dnl AC_LANG_SOURCE([[ dnl #include dnl #include dnl int main() { dnl FILE *fp=fopen("conftest1","w"); dnl fprintf(fp,"%lu\n",sysconf(_SC_PHYS_PAGES)); dnl fclose(fp); dnl return 0; dnl }]])], dnl [phys=`cat conftest1` dnl AC_MSG_RESULT($phys) dnl AC_DEFINE(HAVE_SYSCONF_PHYS_PAGES,$phys,[probe runtime phys pages for gc performance])], dnl [AC_MSG_RESULT(no)]) )) #MY_SUBDIRS= # # GMP # rm -f makedefsafter MP_INCLUDE="" if test $use_gmp = yes ; then PATCHED_SYMBOLS="" if test "$enable_dynsysgmp" = "yes" ; then AC_CHECK_HEADERS(gmp.h, AC_CHECK_LIB(gmp,__gmpz_init, AC_MSG_CHECKING("for external gmp version") AC_TRY_RUN([#include int main() { #if __GNU_MP_VERSION > 3 return 0; #else return -1; #endif }], # MPFILES=$GMPDIR/mpn/mul_n.o # PATCHED_SYMBOLS=__gmpn_toom3_mul_n MPFILES= PATCHED_SYMBOLS= # if test "$use" = "m68k-linux" ; then # MPFILES="$MPFILES $GMPDIR/mpn/lshift.o $GMPDIR/mpn/rshift.o" # PATCHED_SYMBOLS="$PATCHED_SYMBOLS __gmpn_lshift __gmpn_rshift" # fi TLIBS="$TLIBS -lgmp" echo "#include \"gmp.h\"" >foo.c echo "int main() {return 0;}" >>foo.c MP_INCLUDE=`cpp foo.c | $AWK '/(\/|\\\\)gmp.h/ {if (!i) print $3;i=1}' | tr -d '"'` rm -f foo.c, echo "Cannot use dynamic gmp lib" , echo "Cannot use dynamic gmp lib" ), echo "Cannot use dynamic gmp lib" ,), echo "Cannot use dynamic gmp lib" ,) fi NEED_LOCAL_GMP='' if test "$MP_INCLUDE" = "" ; then NEED_LOCAL_GMP=1; fi if test "$PATCHED_SYMBOLS" != "" ; then NEED_LOCAL_GMP=1; fi if test "$NEED_LOCAL_GMP" != "" ; then GMPDIR=gmp4 AC_MSG_CHECKING([use_gmp=yes, doing configure in gmp directory]) echo echo "#" echo "#" echo "# -------------------" echo "# Subconfigure of GMP" echo "#" echo "#" if test "$use_common_binary" = "yes"; then cd $GMPDIR && ./configure --build=$host && cd .. else cd $GMPDIR && ./configure && cd .. fi #MY_SUBDIRS="$MY_SUBDIRS $GMPDIR" echo "#" echo "#" echo "#" echo "# Subconfigure of GMP done" echo "# ------------------------" echo "#" if test "$MP_INCLUDE" = "" ; then cp $GMPDIR/gmp.h h/gmp.h MP_INCLUDE=h/gmp.h MPFILES=gmp_all fi fi AC_MSG_CHECKING("for leading underscore in object symbols") cat>foo.c < #include int main() {FILE *f;double d=0.0;getc(f);cos(d);return 0;} EOFF $CC -c foo.c -o foo.o if nm foo.o |grep " U " | grep "_cos" >/dev/null || nm foo.o |grep " U " | grep " _getc" >/dev/null ; then LEADING_UNDERSCORE=1 AC_DEFINE(LEADING_UNDERSCORE,1,[symbol name mangling convention]) AC_MSG_RESULT("yes") else LEADING_UNDERSCORE="" AC_MSG_RESULT("no") fi AC_MSG_CHECKING("for GNU ld option -Map") touch map $CC -o foo [ -Wl,-Map ] map foo.o >/dev/null 2>&1 if test `cat map | wc -l` != "0" ; then AC_MSG_RESULT("yes") AC_DEFINE(HAVE_GNU_LD,1,[gnu linker present]) GNU_LD=1 else AC_MSG_RESULT("no") GNU_LD= fi rm -f foo.c foo.o foo map AC_MSG_CHECKING([for size of gmp limbs]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #include #include "$MP_INCLUDE" ]],[[ FILE *fp=fopen("conftest1","w"); fprintf(fp,"%u",sizeof(mp_limb_t)); fclose(fp); return 0; ]])],[mpsize=`cat conftest1`],[AC_MSG_ERROR([Cannot determine mpsize])]) AC_DEFINE_UNQUOTED(MP_LIMB_BYTES,$mpsize,[sizeof mp_limb in gmp library]) AC_MSG_RESULT($mpsize) AC_MSG_CHECKING([_SHORT_LIMB]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #include #include "$MP_INCLUDE" ]],[[ #ifdef _SHORT_LIMB return 0; #else return 1; #endif ]])],[AC_DEFINE(__SHORT_LIMB,1,[short gmp3 limbs]) AC_MSG_RESULT(yes)],[AC_MSG_RESULT(no)]) AC_MSG_CHECKING([_LONG_LONG_LIMB]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #include #include "$MP_INCLUDE" ]],[[ #ifdef _LONG_LONG_LIMB return 0; #else return 1; #endif ]])],[AC_DEFINE(__LONG_LONG_LIMB,1,[long gmp3 limbs]) AC_MSG_RESULT(yes)],[AC_MSG_RESULT(no)]) GMP=1 AC_DEFINE(GMP,1,[using gmp]) AC_SUBST(GMP) AC_SUBST(GMPDIR) echo > makedefsafter echo "MPFILES=$MPFILES" >> makedefsafter echo "PATCHED_SYMBOLS=$PATCHED_SYMBOLS" >> makedefsafter echo >> makedefsafter fi # # X windows # if test "$enable_xgcl" = "yes" ; then AC_PATH_X # AC_PATH_XTRA # echo $X_CFLAGS # echo $X_LIBS # echo $X_EXTRA_LIBS # echo $X_PRE_LIBS miss=0 # AC_CHECK_LIB(Xmu,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS)#FIXME remove these # AC_CHECK_LIB(Xt,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS) # AC_CHECK_LIB(Xext,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS) # AC_CHECK_LIB(Xaw,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS)#until here AC_CHECK_LIB(X11,main,X_LIBS="$X_LIBS -lX11",miss=1,$X_LIBS) if test "$miss" = "1" ; then X_CFLAGS= X_LIBS= X_EXTRA_LIBS= X_PRE_LIBS= echo missing x libraries -- cannot compile xgcl else AC_DEFINE(HAVE_XGCL,1,[using xgcl]) fi fi AC_SUBST(X_LIBS) AC_SUBST(X_CFLAGS) # # Dynamic loading # if test "$enable_dlopen" = "yes" ; then AC_CHECK_LIB(dl,dlopen,have_dl=1,have_dl=0) if test "$have_dl" = "0" ; then echo "Cannot find dlopen in -dl" exit 1 fi dnl AC_SEARCH_LIBS(dlopen, dl, have_dl=1, AC_ERROR(dlopen not found)) dnl LIBS and TLIBS - why not merged from the beginning? TLIBS="$TLIBS -ldl -rdynamic" TCFLAGS="-fPIC $TCFLAGS" dnl TLIBS="$TLIBS -rdynamic" AC_DEFINE(USE_DLOPEN,1,[link compiled objects via libdl]) fi if test "$enable_statsysbfd" = "yes" || test "$enable_dynsysbfd" = "yes" ; then AC_CHECK_HEADERS(bfd.h, AC_CHECK_LIB(bfd,bfd_init, # # Old binutils appear to need CONST defined to const # AC_MSG_CHECKING(if need to define CONST for bfd) AC_TRY_RUN([#define IN_GCC #include int main() { symbol_info t; return 0;}], AC_MSG_RESULT(no), AC_TRY_RUN([#define CONST const #define IN_GCC #include int main() {symbol_info t; return 0;}], AC_MSG_RESULT(yes) AC_DEFINE(NEED_CONST,1,[binutils requires CONST definition]), AC_MSG_ERROR([cannot use bfd]), AC_MSG_ERROR([cannot use bfd])), AC_MSG_ERROR([cannot use bfd])) ,,-liberty)) AC_DEFINE(HAVE_LIBBFD,1,[use libbfd]) # # BFD boolean syntax # AC_MSG_CHECKING(for useable bfd_boolean) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #define IN_GCC #include bfd_boolean foo() {return FALSE;} ]],[[return 0;]])], [AC_MSG_RESULT(yes) AC_DEFINE(HAVE_BFD_BOOLEAN,1,[bfd_boolean defined])], [AC_MSG_RESULT(no)]) # # bfd_link_info.output_bfd minimal configure change check # AC_CHECK_MEMBER([struct bfd_link_info.output_bfd], AC_DEFINE(HAVE_OUTPUT_BFD,1,[output_bfd element present]), [], [ #include #include ]) AC_SUBST(HAVE_OUTPUT_BFD) # # FIXME: Need to workaround mingw before this point -- CM # if test "$enable_statsysbfd" = "yes" && ! $CC -v 2>&1 | fgrep ming > /dev/null ; then echo 'int main() {bfd_init();bfd_openr("/dev/null",0);return 0;}' >foo.c MP=`$CC [ -Wl,-M ] -static -o foo foo.c -lbfd -liberty -ldl 2>&1 | grep -v : | tr '()' '\012\012' | $AWK '{print $NF}' | sort | uniq` rm -f foo.c foo if echo $MP | tr ' ' '\012' | grep libbfd.a >/dev/null; then LIBBFD="`echo $MP | tr ' ' '\012' | grep libbfd.a | $AWK '{i=split($1,A,"/");for (j=1;j<=i;j++) if (j>1 && A[[j]]=="..") {j--;i-=2;for (k=j;k<=i;k++) A[[k]]=A[[k+2]];j--;}} END {for (j=1;j<=i;j++) printf("%s%s",A[[j]],j!=i ? "/" : "")}'`" else AC_MSG_ERROR([cannot locate external libbfd.a]) fi if echo $MP | tr ' ' '\012' | grep libiberty.a >/dev/null ; then LIBIBERTY="`echo $MP | tr ' ' '\012' | grep libiberty.a | $AWK '{i=split($1,A,"/");for (j=1;j<=i;j++) if (j>1 && A[[j]]=="..") {j--;i-=2;for (k=j;k<=i;k++) A[[k]]=A[[k+2]];j--;}} END {for (j=1;j<=i;j++) printf("%s%s",A[[j]],j!=i ? "/" : "")}'`" else AC_MSG_ERROR([cannot locate external libiberty.a]) fi BUILD_BFD=copy_bfd AC_CHECK_LIB(z,inflate, [TLIBS="$TLIBS -lz"], AC_MSG_ERROR([Need zlib for bfd linking]),[]) AC_CHECK_LIB(dl,dlsym, [TLIBS="$TLIBS -ldl"], AC_MSG_ERROR([Need libdl for bfd linking]),[]) AC_SUBST(BUILD_BFD) AC_SUBST(LIBBFD) AC_SUBST(LIBIBERTY) else TLIBS="$TLIBS -lbfd -liberty -ldl" fi fi if test "$enable_locbfd" = "yes" ; then # check for gettext. It is part of glibc, but others # need GNU gettext separately. # AC_CHECK_HEADERS(libintl.h, true, # AC_MSG_ERROR(libintl.h (gettext) not found)) # AC_SEARCH_LIBS(dgettext, intl, true, AC_MSG_ERROR(gettext library not found)) echo "#" echo "#" echo "# -------------------------" echo "# Subconfigure of LIBINTL" echo "#" echo "#" cd binutils/intl && chmod +x configure && ./configure --disable-nls && cd ../.. # MY_SUBDIRS="$MY_SUBDIRS binutils/libiberty " echo "#" echo "#" echo "#" echo "# Subconfigure of LIBINTL done" echo "# ------------------------------" echo "#" echo "#" echo "#" echo "# -------------------------" echo "# Subconfigure of LIBIBERTY" echo "#" echo "#" cd binutils/libiberty && chmod +x configure && ./configure --disable-nls && cd ../.. # MY_SUBDIRS="$MY_SUBDIRS binutils/libiberty " echo "#" echo "#" echo "#" echo "# Subconfigure of LIBIBERTY done" echo "# ------------------------------" echo "#" echo "#" echo "#" echo "# -------------------" echo "# Subconfigure of BFD" echo "#" echo "#" cd binutils/bfd && chmod +x configure && ./configure --with-included-gettext --disable-nls && cd ../.. # MY_SUBDIRS="$MY_SUBDIRS binutils/bfd " echo "#" echo "#" echo "#" echo "# Subconfigure of BFD done" echo "# ------------------------" echo "#" # TLIBS="$TLIBS `pwd`/binutils/bfd/libbfd.a `pwd`/binutils/libiberty/libiberty.a" AC_DEFINE(HAVE_LIBBFD,1,[use libbfd]) BUILD_BFD="h/bfd.h h/bfdlink.h h/ansidecl.h h/symcat.h" AC_SUBST(BUILD_BFD) fi if test "$enable_xdr" = "yes" ; then AC_CHECK_FUNC(xdr_double,AC_DEFINE(HAVE_XDR,1,[have xdr extensions]), AC_CHECK_LIB(tirpc,xdr_double,AC_DEFINE(HAVE_XDR,1,[have xdr extensions]) TLIBS="$TLIBS -ltirpc", AC_CHECK_LIB(rpc,xdr_double,AC_DEFINE(HAVE_XDR,1,[have xdr extensions]) TLIBS="$TLIBS -lrpc", AC_CHECK_LIB(oncrpc,xdr_double,AC_DEFINE(HAVE_XDR,1,[have xdr extensions]) TLIBS="$TLIBS -loncrpc")))) fi AC_MSG_CHECKING([__builtin_clzl]) AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include #include int main() { unsigned long u; long j; if (__builtin_clzl(0)!=sizeof(long)*8) return -1; for (u=1,j=sizeof(long)*8-1;j>=0;j--,u<<=1) if (__builtin_clzl(u)!=j) return -1; return 0; }]])],[AC_MSG_RESULT([yes]) AC_DEFINE(HAVE_CLZL,[1],[clzl instruction])], [AC_MSG_RESULT([no])]) AC_MSG_CHECKING([__builtin_ctzl]) AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include #include int main() { unsigned long u; long j; if (__builtin_ctzl(0)!=sizeof(long)*8) return -1; for (u=1,j=0;j #include #ifdef __CYGWIN__ #define getpagesize() 4096 #endif ]],[[ size_t i=getpagesize(),j; FILE *fp=fopen("conftest1","w"); for (j=0;i>>=1;j++); j=j<$min_pagewidth ? $min_pagewidth : j; fprintf(fp,"%u",j); return 0; ]])], [PAGEWIDTH=`cat conftest1`], [PAGEWIDTH=0]) AC_MSG_RESULT($PAGEWIDTH) AC_DEFINE_UNQUOTED(PAGEWIDTH,$PAGEWIDTH,[system pagewidth]) AC_SUBST(PAGEWIDTH) AC_MSG_CHECKING([for required object alignment]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #include #define EXTER #include "$MP_INCLUDE" #include "./h/enum.h" #define OBJ_ALIGN #include "./h/type.h" #include "./h/lu.h" #include "./h/object.h" ]],[[ unsigned long i; FILE *fp=fopen("conftest1","w"); for (i=1;i && NOT_OBJECT_ALIGNED(i); i<<=1); if (!i) return -1; fprintf(fp,"%lu",i); fclose(fp); return 0; ]])], [obj_align=`cat conftest1` AC_MSG_RESULT($obj_align) AC_DEFINE_UNQUOTED(OBJ_ALIGNMENT,$obj_align,[needed object alignment in bytes])], [AC_MSG_ERROR([Cannot find object alignent])]) AC_MSG_CHECKING([for C extension variable alignment]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[]],[[ char *v __attribute__ ((aligned ($obj_align))); return 0;]])],[obj_align="__attribute__ ((aligned ($obj_align)))"],[AC_MSG_ERROR([Need alignment attributes])]) AC_MSG_RESULT($obj_align) AC_DEFINE_UNQUOTED(OBJ_ALIGN,$obj_align,[can use C extension for object alignment]) AC_MSG_CHECKING([for C extension noreturn function attribute]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[]],[[ extern int v() __attribute__ ((noreturn)); return 0;]])],[no_return="__attribute__ ((noreturn))"],[no_return=]) AC_MSG_RESULT($no_return) AC_DEFINE_UNQUOTED(NO_RETURN,$no_return,[can use C extension for functions that do not return]) AC_MSG_CHECKING(sizeof struct contblock) # work around MSYS pwd result incompatibility if test "$use" = "mingw" ; then AC_TRY_RUN([#include #define EXTER #include "$MP_INCLUDE" #include "h/enum.h" #include "h/type.h" #include "h/lu.h" #include "h/object.h" int main(int argc,char **argv,char **envp) { FILE *f=fopen("conftest1","w"); fprintf(f,"%u",sizeof(struct contblock)); fclose(f); return 0; }],sizeof_contblock=`cat conftest1`, echo Cannot find sizeof struct contblock;exit 1, echo Cannot find sizeof struct contblock;exit 1) else AC_TRY_RUN([#include #define EXTER #include "$MP_INCLUDE" #include "`pwd`/h/enum.h" #include "`pwd`/h/type.h" #include "`pwd`/h/lu.h" #include "`pwd`/h/object.h" int main(int argc,char **argv,char **envp) { FILE *f=fopen("conftest1","w"); fprintf(f,"%u",sizeof(struct contblock)); fclose(f); return 0; }],sizeof_contblock=`cat conftest1`, echo Cannot find sizeof struct contblock;exit 1, echo Cannot find sizeof struct contblock;exit 1) fi AC_MSG_RESULT($sizeof_contblock) AC_DEFINE_UNQUOTED(SIZEOF_CONTBLOCK,$sizeof_contblock,[sizeof linked list for contiguous pages]) AC_MSG_CHECKING([for sbrk]) HAVE_SBRK="" AC_TRY_RUN([#include #include int main() { FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%u",sbrk(0)); return 0; }], HAVE_SBRK=1 AC_MSG_RESULT(yes), AC_MSG_RESULT([no: WARNING you must be able to emulate sbrk: as on mingw or macosx]), AC_MSG_RESULT([no: WARNING you must be able to emulate sbrk: as on mingw or macosx])) if test "$use" = "386-macosx" ; then AC_MSG_RESULT(emulating sbrk for mac); HAVE_SBRK=0 fi if test "$HAVE_SBRK" = "1" ; then AC_MSG_CHECKING([for ADDR_NO_RANDOMIZE constant]) AC_RUN_IFELSE([ AC_LANG_PROGRAM([[ #include #include ]],[[ FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_NO_RANDOMIZE); return 0; ]])], [ADDR_NO_RANDOMIZE=`cat conftest1` AC_MSG_RESULT([yes $ADDR_NO_RANDOMIZE])], [ADDR_NO_RANDOMIZE=0 AC_MSG_RESULT([no assuming 0x40000]) AC_DEFINE_UNQUOTED(ADDR_NO_RANDOMIZE,0x40000,[punt guess for no randomize value])]) AC_MSG_CHECKING([for ADDR_COMPAT_LAYOUT constant]) AC_RUN_IFELSE([ AC_LANG_PROGRAM([[ #include #include ]],[[ FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_COMPAT_LAYOUT); return 0; ]])], [ADDR_COMPAT_LAYOUT=`cat conftest1` AC_MSG_RESULT([yes $ADDR_COMPAT_LAYOUT])], [ADDR_COMPAT_LAYOUT=0 AC_MSG_RESULT([no])] AC_DEFINE_UNQUOTED(ADDR_COMPAT_LAYOUT,0,[constant to reserve upper 3Gb for C stack])) AC_MSG_CHECKING([for ADDR_LIMIT_3GB constant]) AC_RUN_IFELSE([ AC_LANG_PROGRAM([[ #include #include ]],[[ FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_LIMIT_3GB); return 0; ]])], [ADDR_LIMIT_3GB=`cat conftest1` AC_MSG_RESULT([yes $ADDR_LIMIT_3GB])], [ADDR_LIMIT_3GB=0 AC_MSG_RESULT([no])] AC_DEFINE_UNQUOTED(ADDR_LIMIT_3GB,0,[only 3Gb of address space])) AC_MSG_CHECKING([for personality(ADDR_NO_RANDOMIZE) support]) AC_RUN_IFELSE([ AC_LANG_SOURCE([[ #include #include void gprof_cleanup() {}; int main(int argc,char **argv,char **envp) { #include "h/unrandomize.h" return 0;}]])], [AC_MSG_RESULT(yes) AC_DEFINE(CAN_UNRANDOMIZE_SBRK,1,[can prevent sbrk from returning random values])], [AC_MSG_RESULT(no)]) AC_MSG_CHECKING([that sbrk is (now) non-random]) AC_TRY_RUN([#include #include void gprof_cleanup() {}; int main(int argc,char * argv[],char * envp[]) { FILE *f; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%u",sbrk(0)); return 0;}],SBRK=`cat conftest1`,SBRK=0,SBRK=0) if test "$SBRK" = "0" ; then AC_MSG_RESULT(cannot trap sbrk) exit 1 fi AC_TRY_RUN([#include #include void gprof_cleanup() {}; int main(int argc,char * argv[],char * envp[]) { FILE *f; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%u",sbrk(0)); return 0;}],SBRK1=`cat conftest1`,SBRK1=0,SBRK1=0) if test "$SBRK1" = "0" ; then AC_MSG_RESULT(cannot trap sbrk) exit 1 fi if test "$SBRK" = "$SBRK1" ; then AC_MSG_RESULT(yes) else AC_MSG_RESULT(no) echo "Cannot build with randomized sbrk. Your options:" echo " - upgrade to a kernel/libc that knows about personality(ADDR_NO_RANDOMIZE)" echo " - recompile your kernel with CONFIG_COMPAT_BRK (if it has that option)" echo " - run sysctl kernel.randomize_va_space=0 before using gcl" exit 1 fi fi dnl AC_MSG_CHECKING(DBEGIN) dnl AC_RUN_IFELSE([AC_LANG_SOURCE([[ dnl #include dnl #include dnl #include dnl void gprof_cleanup() {}; dnl int main(int argc,char **argv,char **envp) { dnl void *b; dnl FILE *fp; dnl #ifdef CAN_UNRANDOMIZE_SBRK dnl #include "h/unrandomize.h" dnl #endif dnl fp = fopen("conftest1","w"); dnl #ifdef _WIN32 dnl fprintf ( fp,"0x%lx", 0x3000000 ); /* Windows custom allocation from this point up */ dnl #else dnl #if defined (__APPLE__) && defined (__MACH__) dnl fprintf(fp,"0x0"); dnl #else dnl b = sbrk(0); dnl fprintf(fp,"0x%lx",((unsigned long) b) & ~(unsigned long)((1< dnl #include dnl ]],[[ dnl FILE *fp=fopen("conftest1","w"); dnl fprintf(fp,"%u",262144*( SIZEOF_LONG >>2)/(1<<($PAGEWIDTH-12))); dnl return 0;]])],[def_maxpage=`cat conftest1`],[def_maxpage=262144]) dnl AC_ARG_ENABLE(maxpage, dnl [ --enable-maxpage=XXXX will compile in a page table of size XXX dnl (eg '--enable-maxpage=64*1024' would produce dnl 64K pages allowing 256 MB if pages are 4K each)], dnl ,enable_maxpage=$def_maxpage) AC_MSG_CHECKING(CSTACK_ADDRESS) AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include #include void * foo() { int i; return (void *)&i; } void gprof_cleanup() {}; int main(int argc,char **argv,char **envp) { void *v ; FILE *fp = fopen("conftest1","w"); unsigned long i,j; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif j=1; j<<=$PAGEWIDTH; j<<=16; i=(unsigned long)&v; if (foo()>i) i-=j; j--; i+=j; i&=~j; fprintf(fp,"0x%lx",i-1); fclose(fp); return 0; }]])],[cstack_address=`cat conftest1`],[cstack_address=0]) AC_DEFINE_UNQUOTED(CSTACK_ADDRESS,$cstack_address,[starting C stack address]) AC_MSG_RESULT($cstack_address) AC_MSG_CHECKING([cstack bits]) AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include #include void * foo() { int i; return (void *)&i; } void gprof_cleanup() {}; int main(int argc,char **argv,char **envp) { void *v ; FILE *fp = fopen("conftest1","w"); unsigned long i,j; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif j=1; j<<=$PAGEWIDTH; j<<=16; i=(unsigned long)&v; if (foo()>i) i-=j; j--; i+=j; i&=~j; for (j=0;(i>>j)!=(i>>(sizeof(long)*8-1));j++); fprintf(fp,"%d",j); fclose(fp); return 0; }]])],[cstack_bits=`cat conftest1`],[cstack_bits=0]) AC_DEFINE_UNQUOTED(CSTACK_BITS,$cstack_bits,[log starting C stack address]) AC_MSG_RESULT($cstack_bits) AC_MSG_CHECKING(NEG_CSTACK_ADDRESS) AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include #include void gprof_cleanup() {}; int main(int argc,char **argv,char **envp) { #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif return (long)$cstack_address<0 ? 0 : -1; }]])],[AC_MSG_RESULT(yes) neg_cstack_address=1 AC_DEFINE(NEG_CSTACK_ADDRESS,1,[C stack address is negative])], [AC_MSG_RESULT(no) neg_cstack_address=0]) AC_MSG_CHECKING([finding CSTACK_ALIGNMENT]) AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include #include void gprof_cleanup() {}; int main(int argc,char **argv,char **envp) { void *b,*c; FILE *fp = fopen("conftest1","w"); long n; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif b=alloca(sizeof(b)); c=alloca(sizeof(c)); n=b>c ? b-c : c-b; n=n>sizeof(c) ? n : 1; fprintf(fp,"%ld",n); fclose(fp); return 0; }]])],[cstack_alignment=`cat conftest1`],[cstack_alignment=0]) AC_DEFINE_UNQUOTED(CSTACK_ALIGNMENT,$cstack_alignment,[C stack alignment]) AC_MSG_RESULT($cstack_alignment) AC_MSG_CHECKING(CSTACK_DIRECTION) AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include #include void * foo(void) { int i; return (void *)&i; } void gprof_cleanup() {}; int main(int argc,char **argv,char **envp) { char *b; FILE *fp = fopen("conftest1","w"); #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif fprintf(fp,"%d",((long) &b) > ((long) foo()) ? -1 : 1); fclose(fp); return 0; }]])],[cstack_direction=`cat conftest1`],[cstack_direction=0]) AC_DEFINE_UNQUOTED(CSTACK_DIRECTION,$cstack_direction,[whether C stack grows up or down]) AC_MSG_RESULT($cstack_direction) dnl AC_MSG_CHECKING(for shared library/C stack ceiling to heap) dnl if test "$use" = "mingw" ; then dnl heap_ceiling=2000000000 dnl else dnl if test "$use" = "solaris-i386" ; then dnl heap_ceiling=0x0 dnl else dnl if test "$enable_static" = "yes" ; then dnl heap_ceiling=0x0 dnl else dnl if ! test -x `which ldd` && ! test -f /proc/self/maps ; then dnl heap_ceiling=0x0 dnl else dnl if test -f /proc/self/maps ; then dnl heap_ceiling=0x`/bin/cat /proc/self/maps | grep "/lib.*/ld-" | cut -f1 -d- | head -1` dnl else dnl if test "`which ldd`" = "" ; then dnl heap_ceiling=0x0 dnl else dnl #echo -e "#include \n int main() {printf(\"foo\");return 0;}" >foo.c dnl #$CC foo.c -o foo dnl AAWK=`which awk` dnl # | grep -v ld-kfreebsd needed on some strange bsd amd64 boxes dnl heap_ceiling=`ldd $AAWK | tail -n 1 | $AWK '{print $NF}' | tr -d '()'` dnl fi dnl fi dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ dnl #include dnl ]],[[ dnl FILE *fp=fopen("conftest1","w"); dnl unsigned long h=$heap_ceiling,d=$dbegin,c=$cstack_address; dnl h=hd && cfoo.c dnl else dnl echo "int main() {return !($heap_ceiling && (unsigned long)$dbegin < (unsigned long)$cstack_address);}" >foo.c dnl fi dnl $CC foo.c -o foo dnl if ./foo ; then if test "$use" != "386-gnu" ; then #hurd can push .data below C stack, but sbrk(0) remains above, foiling unexec AC_MSG_CHECKING([finding default linker script]) touch unixport/gcl.script echo "int main() {return 0;}" >foo.c $CC -Wl,--verbose foo.c -o foo 2>&1 | \ $AWK '/\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=/ {i=1-i;next} {if (i) print}' >gcl.script rm -rf foo.c foo if test "`cat gcl.script | wc -l`" != "0" ; then AC_MSG_RESULT(got it) AC_MSG_NOTICE([trying to adjust text start]) cp gcl.script gcl.script.def n=-1; k=0; lim=`$AWK 'END {printf("%d\n",m*8-2)}' m=$ac_cv_sizeof_long`; max=0; min=$lim; while test $n -lt $lim ; do j=`$AWK 'END {for (i=j=0;j<=n;j++) i=i ? i*2 : 1;printf("%x\n",3*i)}' n=$n gcl.script # diff -u gcl.script.def gcl.script echo "int main() {return 0;}" >foo.c if ( $CC -Wl,-T gcl.script foo.c -o foo && ./foo ) >/dev/null 2>&1 ; then if test $n -lt $min ; then min=$n; fi; if test $n -gt $max; then max=$n; fi; elif test $max -gt 0 ; then break; fi; n=`$AWK 'END {print n+1}' n=$n gcl.script AC_MSG_RESULT([done]) rm -f gcl.script.def LDFLAGS="$LDFLAGS -Wl,-T gcl.script " cp gcl.script unixport else AC_MSG_RESULT([none found or not needed]) rm -f gcl.script gcl.script.def fi rm -rf foo.c foo else AC_MSG_RESULT([not found]) fi else AC_DEFINE_UNQUOTED(OBJNULL,NULL,[lowest address non-object]) fi dnl old_LDFLAGS="$LDFLAGS" dnl LDFLAGS="$LDFLAGS $TLDFLAGS" dnl AC_MSG_CHECKING([revised DBEGIN]) dnl AC_RUN_IFELSE([AC_LANG_SOURCE([[ dnl #include dnl #include dnl #include dnl int main(int argc,char **argv,char **envp) { dnl void *b; dnl FILE *fp; dnl #ifdef CAN_UNRANDOMIZE_SBRK dnl #include "h/unrandomize.h" dnl #endif dnl fp = fopen("conftest1","w"); dnl #ifdef _WIN32 dnl fprintf ( fp,"0x%lx", 0x1a000000 ); /* Windows custom allocation from this point up */ dnl #else dnl #if defined (__APPLE__) && defined (__MACH__) dnl fprintf(fp,"((unsigned long)get_dbegin())"); dnl #else dnl b = sbrk(0); dnl fprintf(fp,"0x%lx",((unsigned long) b) & ~(unsigned long)0xffffff); dnl #endif dnl #endif dnl fclose(fp); dnl return 0;}]])],[dbegin=`cat conftest1`],[dbegin=0]) dnl AC_MSG_RESULT($dbegin) dnl LDFLAGS="$old_LDFLAGS" dnl fi dnl dnl AC_DEFINE_UNQUOTED(DBEGIN,$dbegin,[down-rounded beginning address of lisp data]) dnl rm -rf foo* dnl AC_MSG_CHECKING(for maxpage revision) dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ dnl #include dnl ]],[[ dnl char *b; dnl unsigned long i,j; dnl FILE *fp = fopen("conftest1","w"); dnl j=((unsigned long)$enable_maxpage <<$PAGEWIDTH) + $dbegin; dnl j=$heap_ceiling && j>$heap_ceiling ? $heap_ceiling : j; dnl j-=$dbegin; dnl /* for (i=1;i<<1 && i<=j;i<<=1); */ dnl /* if (i>j) i>>=1; */ dnl i=j; dnl fprintf(fp,"%ld",i>>$PAGEWIDTH); dnl fclose(fp); dnl return 0; dnl ]])],[tmp_maxpage=`cat conftest1`],[tmp_maxpage=0]) dnl if test "$tmp_maxpage" != "$enable_maxpage" ; then dnl enable_maxpage=$tmp_maxpage dnl AC_MSG_RESULT($enable_maxpage) dnl else dnl AC_MSG_RESULT($enable_maxpage is OK) dnl fi dnl AC_DEFINE_UNQUOTED(MAXPAGE,$enable_maxpage,[maximum number of pages to be allocated]) dnl AC_MSG_CHECKING(for C stack size floor from heap) dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ dnl #include dnl ]],[[ dnl char *b; dnl FILE *fp = fopen("conftest1","w"); dnl unsigned long j,k; dnl j=$cstack_address + $cstack_direction * $enable_cssize; dnl k=($dbegin + ((unsigned long)$enable_maxpage << $PAGEWIDTH)); dnl j=abs(j-$cstack_address)!=$enable_cssize || (j dnl ]],[[ dnl char *b; dnl FILE *fp = fopen("conftest1","w"); dnl unsigned long j,k; dnl j=$cstack_address + $cstack_direction * $enable_cssize; dnl if ($cstack_direction>0) { dnl k=$cstack_address + ((-(unsigned long)$cstack_address)>>1); dnl j=j<$cstack_address || j > k ? k : j; dnl j=$cstack_address < $dbegin && j > $dbegin ? $dbegin : j; dnl } dnl j-=$cstack_address; dnl j*=$cstack_direction; dnl fprintf(fp,"%lu",j); dnl fclose(fp); dnl return 0; dnl ]])],[tmp_cssize=`cat conftest1`],[tmp_cssize=0]) dnl if test "$tmp_cssize" != "$enable_cssize" ; then dnl enable_cssize=$tmp_cssize; dnl AC_MSG_RESULT($enable_cssize) dnl else dnl AC_MSG_RESULT($enable_cssize is OK) dnl fi dnl AC_MSG_CHECKING(for C stack size limit from address wrap) dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ dnl #include dnl ]],[[ dnl char *b; dnl FILE *fp = fopen("conftest1","w"); dnl unsigned long j,k; dnl j=-$cstack_address * $cstack_direction; dnl j=j>$enable_cssize ? $enable_cssize : j; dnl fprintf(fp,"%lu",j); dnl fclose(fp); dnl return 0; dnl ]])],[tmp_cssize=`cat conftest1`],[tmp_cssize=0]) dnl if test "$tmp_cssize" != "$enable_cssize" ; then dnl enable_cssize=$tmp_cssize; dnl AC_MSG_RESULT($enable_cssize) dnl else dnl AC_MSG_RESULT($enable_cssize is OK) dnl fi dnl AC_DEFINE_UNQUOTED(CSSIZE,$enable_cssize,[maximum C stack size]) dnl AC_MSG_CHECKING(for fast NULL_OR_ON_CSTACK macro) dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ dnl #include dnl ]],[[ dnl return ((long)$dbegin>=0 && dnl ((long)$dbegin+(long)($enable_maxpage<<$PAGEWIDTH)) >=0 && dnl ((long)$cstack_address<0)) ? 0 : 1; dnl ]])],[tmp_fnocm=yes],[tmp_fnocm=no]) dnl if test "$tmp_fnocm" = "yes" ; then dnl AC_MSG_RESULT(yes) dnl AC_DEFINE(USE_FAST_NULL_OR_ON_CSTACK_MACRO,1,[whether one instruction heap address check can be used]) dnl else dnl AC_MSG_RESULT(no) dnl fi mem_top=0 mem_range=0 AC_MSG_CHECKING(mem top) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #include ]],[[ void *v; unsigned long i,j,k,l,m; FILE *fp = fopen("conftest1","w"); for (i=2,k=1;i;k=i,i<<=1); l=$cstack_address; l=$cstack_direction==1 ? (l>=1,i|=j); if (j<(k>>3)) i=0; j=1; j<<=$PAGEWIDTH; j<<=4; j--; i+=j; i&=~j; fprintf(fp,"0x%lx",i); fclose(fp); return 0; ]])],[mem_top=`cat conftest1`],[mem_top="0x0"]) AC_MSG_RESULT($mem_top) if test "$mem_top" != "0x0" ; then AC_MSG_CHECKING(finding upper mem half range) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #include ]],[[ unsigned long j; FILE *fp = fopen("conftest1","w"); for (j=1;j && !(j& $mem_top);j<<=1); fprintf(fp,"0x%lx",j>>1); fclose(fp); return 0; ]])],[mem_range=`cat conftest1`],[mem_range="0x0"]) AC_MSG_RESULT($mem_range) if test "$mem_range" != "0x0" ; then AC_DEFINE_UNQUOTED(MEM_TOP,$mem_top,[beginning address for immediate fixnum range]) AC_DEFINE_UNQUOTED(MEM_RANGE,$mem_range,[size of immediate fixnum address space]) fi fi if test "$enable_immfix" = "yes" ; then if test "$mem_top" != "0x0" ; then if test "$mem_range" != "0x0" ; then AC_DEFINE_UNQUOTED(IM_FIX_BASE,$mem_top,[beginning address for immediate fixnum range]) AC_DEFINE_UNQUOTED(IM_FIX_LIM,$mem_range,[size of immediate fixnum address space]) fi fi fi dnl AC_MSG_CHECKING(for word order) dnl AC_TRY_RUN([int main () { dnl /* Are we little or big endian? Adapted from Harbison&Steele. */ dnl union dnl { dnl double d; dnl int l[sizeof(double)/sizeof(int)]; dnl } u; dnl u.d = 1.0; dnl return u.l[sizeof(double)/sizeof(int)-1] ? 0 : 1; dnl }],AC_MSG_RESULT(little) dnl AC_DEFINE(LITTLE_END), dnl AC_MSG_RESULT(big), dnl AC_MSG_RESULT([WARNING: ASSUMING LITTLE ENDIAN FOR CROSS COMPILING !!!] dnl AC_DEFINE(LITTLE_END))) dnl AC_SUBST(LITTLE_END) # On systems with execshield, brk is randomized. We need to catch # this and restore the traditional behavior here dnl old_LDFLAGS="$LDFLAGS" dnl LDFLAGS="$TLDFLAGS" dnl AC_MSG_CHECKING("finding DBEGIN") dnl AC_TRY_RUN([#include dnl #include dnl void gprof_cleanup() {}; dnl int dnl main(int argc,char * argv[],char *envp[]) dnl { dnl char *b,*b1; dnl FILE *fp; dnl #ifdef CAN_UNRANDOMIZE_SBRK dnl #include "h/unrandomize.h" dnl #endif dnl b = (void *) malloc(1000); dnl fp = fopen("conftest1","w"); dnl #ifdef _WIN32 dnl fprintf(fp,"_dbegin"); dnl #else dnl #if defined (__APPLE__) && defined (__MACH__) dnl fprintf(fp,"mach_mapstart"); dnl #else dnl b1=((unsigned long) b) & ~(unsigned long)0xffffff;b=(void *)b1<(void *)&b1 && (void *)b>(void *)&b ? ((unsigned long) b) & ~(unsigned long)((1< dnl main() dnl { dnl char *b ; dnl FILE *fp = fopen("conftest1","w"); dnl fprintf(fp,"%ld",((long) &b)); dnl fclose(fp); dnl return 0; dnl }],cstack_address=`cat conftest1`,cstack_address=0,cstack_address=0) dnl AC_DEFINE_UNQUOTED(CSTACK_ADDRESS,$cstack_address \ dnl ) dnl AC_MSG_RESULT(got $cstack_address) AC_MSG_CHECKING([sizeof long long int]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #include ]],[[ if (sizeof(long long int) == 2*sizeof(long)) return 0; return 1; ]])],[AC_DEFINE(HAVE_LONG_LONG,1,[long long is available]) AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)]) AC_SUBST(HAVE_LONG_LONG) AC_CHECK_HEADERS(dirent.h, AC_MSG_CHECKING([for d_type]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #include ]],[[ struct dirent d; return d.d_type=0; ]])], [AC_MSG_RESULT([yes]) AC_DEFINE(HAVE_D_TYPE,1,[have struct dirent d_type field])], AC_MSG_RESULT([no]),AC_MSG_RESULT([no]))) # readline AC_ARG_ENABLE(readline, [--enable-readline enables command line completion via the readline library ],, enable_readline="yes") # ansi lisp AC_ARG_ENABLE(ansi,[--enable-ansi builds a large gcl aiming for ansi compliance, --disable-ansi builds the smaller traditional CLtL1 image],,enable_ansi="no") if test "$enable_ansi" = "yes" ; then SYSTEM=ansi_gcl AC_DEFINE(ANSI_COMMON_LISP,1,[compile ansi compliant image]) CLSTANDARD=ANSI else SYSTEM=gcl CLSTANDARD=CLtL1 fi FLISP="saved_$SYSTEM" AC_SUBST(FLISP) AC_SUBST(SYSTEM) AC_SUBST(CLSTANDARD) # Maximum number of pages # Check if Posix compliant getcwd exists, if not we'll use getwd. AC_CHECK_FUNCS(getcwd) AC_CHECK_FUNCS(getwd) AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME,1,[no uname call])) AC_CHECK_FUNC(gettimeofday, , AC_DEFINE(NO_GETTOD)) AC_CHECK_HEADERS(sys/ioctl.h) # OpenBSD has elf_abi.h instead of elf.h AC_CHECK_HEADERS(elf.h elf_abi.h) AC_CHECK_HEADERS(sys/sockio.h) #-------------------------------------------------------------------- # The code below deals with several issues related to gettimeofday: # 1. Some systems don't provide a gettimeofday function at all # (set NO_GETTOD if this is the case). # 2. SGI systems don't use the BSD form of the gettimeofday function, # but they have a BSDgettimeofday function that can be used instead. # 3. See if gettimeofday is declared in the header file. # if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can # declare it. #-------------------------------------------------------------------- AC_CHECK_FUNC([BSDgettimeofday], [AC_DEFINE(HAVE_BSDGETTIMEOFDAY,1,[have bsdgettimeofday])], [AC_CHECK_FUNC([gettimeofday], , [AC_DEFINE([NO_GETTOD],1,[no gettimeofday call])])]) AC_MSG_CHECKING([for gettimeofday declaration]) AC_EGREP_HEADER([gettimeofday], [sys/time.h], [AC_MSG_RESULT([present])], [AC_MSG_RESULT([missing]) AC_DEFINE(GETTOD_NOT_DECLARED,1,[No gettimeofday call -- fixme])]) AC_CHECK_LIB(m,sin,LIBS="${LIBS} -lm",true) AC_CHECK_LIB(mingwex,main,LIBS="${LIBS} -lmingwex",true) AC_MSG_CHECKING([for buggy maximum sscanf length]) AC_RUN_IFELSE([ AC_LANG_PROGRAM([[ #include ]],[[ char *s= "2.7182818284590452353602874713526624977572470936999595749669676277240766303535475945713821785251664274274663919320030599218174135966290435729003342952605956307381323286279434907632338298807531952510190115738341879307021540891499348841675092447614606680822648001684774118537423454424371075390777449920695517027618386062613313845830007520449338265602976067371132007093287091274437470472306969772093101416928368190255151086574637721112523897844250569536967707854499699679468644549059879316368892300987931277361782154249992295763514822082698951936680331825288693984964651058209392398294887933203625094431173012381970684161404"; int n, m; double f; char *endptr; FILE *fp=fopen("conftest1","w"); n=sscanf(s,"%lf%n",&f,&m); fprintf(fp,"%d",m); fclose(fp); return s[m]; ]])], [AC_MSG_RESULT([none])], [buggy_maximum_sscanf_length=`cat conftest1` AC_MSG_RESULT([$buggy_maximum_sscanf_length]) AC_DEFINE_UNQUOTED(BUGGY_MAXIMUM_SSCANF_LENGTH,$buggy_maximum_sscanf_length,[sscanf terminates prematurely (Windows XP)])]) EXTRA_LOBJS= if test "$try_japi" = "yes" ; then AC_CHECK_HEADERS(japi.h,[AC_DEFINE(HAVE_JAPI_H) EXTRA_LOBJS="${EXTRA_LOBJS} gcl_japi.o" LIBS="${LIBS} -ljapi -lwsock32"] ) fi dnl if test "$use" = "mingw" ; then dnl if test "$try_xdr" = "yes" ; then dnl AC_CHECK_HEADERS(rpc/rpc.h,[AC_DEFINE(HAVE_XDR) dnl LIBS="${LIBS} -loncrpc"] ) dnl fi dnl else dnl if test "$try_xdr" = "yes" ; then dnl AC_CHECK_HEADERS(rpc/rpc.h,[AC_DEFINE(HAVE_XDR) dnl LIBS="${LIBS} -lrpc"] ) dnl fi dnl fi # Should really find a way to check for prototypes, but this # basically works for now. CM # AC_CHECK_HEADERS(math.h,AC_DEFINE(HAVE_MATH_H,1,[have math.h])) AC_CHECK_HEADERS(complex.h,AC_DEFINE(HAVE_COMPLEX_H,1,[have complex.h])) # # For DBL_MAX et. al. on (only) certain Linux arches, apparently CM # AC_CHECK_HEADERS(values.h,AC_DEFINE(HAVE_VALUES_H,1,[have values.h])) # # Sparc solaris keeps this in float.h, rework either/or with values.h later # AC_CHECK_HEADERS(float.h,AC_DEFINE(HAVE_FLOAT_H,1,[have float.h])) # # The second alternative is for solaris. This needs to be # a more comprehensive later, i.e. checking that the fpclass # test makes sense. CM # AC_MSG_CHECKING([for isnormal]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #define _GNU_SOURCE #include ]],[[ float f; return isnormal(f) || !isnormal(f) ? 0 : 1; ]])], [AC_DEFINE(HAVE_ISNORMAL,1,[Have isnormal function]) AC_MSG_RESULT(yes)], [AC_MSG_CHECKING([for fpclass in ieeefp.h]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #include ]],[[ float f; return fpclass(f)>=FP_NZERO || fpclass(f) ]],[[ float f; return isfinite(f) || !isfinite(f) ? 0 : 1; ]])],[AC_DEFINE(HAVE_ISFINITE,1,[Have isfinite function]) AC_MSG_RESULT(yes)], [AC_MSG_CHECKING([for finite()]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #include #include ]],[[ float f; return finite(f) || !finite(f) ? 0 : 1; ]])],[AC_DEFINE(HAVE_FINITE,1,[Have finite function]) AC_MSG_RESULT(yes)], [AC_MSG_ERROR(no)])]) dnl AC_MSG_CHECKING([for INFINITY]) dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ dnl #define _GNU_SOURCE dnl #include dnl ]],[[ dnl double d=INFINITY; dnl return 0; dnl ]])],[AC_MSG_RESULT(yes)], dnl [AC_MSG_CHECKING([for builtin_inf()]) dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ dnl #include dnl #include dnl ]],[[ dnl double d=__builtin_inf(); dnl return 0; dnl ]])],[AC_DEFINE_UNQUOTED(INFINITY,__builtin_inf(),[Have builtin_inf]) AC_MSG_RESULT(yes)], dnl [AC_MSG_ERROR(no)])]) dnl AC_MSG_CHECKING([for NAN]) dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ dnl #define _GNU_SOURCE dnl #include dnl ]],[[ dnl double d=NAN; dnl return 0; dnl ]])],[AC_MSG_RESULT(yes)], dnl [AC_MSG_CHECKING([for builtin_nan()]) dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ dnl #include dnl #include dnl ]],[[ dnl double d=__builtin_nan("0x0"); dnl return 0; dnl ]])],[AC_DEFINE_UNQUOTED(NAN,__builtin_nan("0x0"),[Have builtin_nan]) AC_MSG_RESULT(yes)], dnl [AC_MSG_ERROR(no)])]) #-------------------------------------------------------------------- # Check for the existence of the -lsocket and -lnsl libraries. # The order here is important, so that they end up in the right # order in the command line generated by make. Here are some # special considerations: # 1. Use "connect" and "accept" to check for -lsocket, and # "gethostbyname" to check for -lnsl. # 2. Use each function name only once: can't redo a check because # autoconf caches the results of the last check and won't redo it. # 3. Use -lnsl and -lsocket only if they supply procedures that # aren't already present in the normal libraries. This is because # IRIX 5.2 has libraries, but they aren't needed and they're # bogus: they goof up name resolution if used. # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. # To get around this problem, check for both libraries together # if -lsocket doesn't work by itself. #-------------------------------------------------------------------- AC_MSG_CHECKING([for sockets]) tcl_checkBoth=0 AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) if test "$tcl_checkSocket" = 1; then AC_CHECK_LIB(socket, main, TLIBS="$TLIBS -lsocket", tcl_checkBoth=1) fi if test "$tcl_checkBoth" = 1; then tk_oldLibs=$TLIBS TLIBS="$TLIBS -lsocket -lnsl" AC_CHECK_FUNC(accept, tcl_checkNsl=0, [TLIBS=$tk_oldLibs]) fi AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main, [TLIBS="$TLIBS -lnsl"])) RL_OBJS="" RL_LIB="" if test "$enable_readline" = "yes" ; then AC_CHECK_HEADERS(readline/readline.h, AC_CHECK_LIB(readline,rl_initialize, AC_DEFINE(HAVE_READLINE,1,[have readline library]) TLIBS="$TLIBS -lreadline" #some machines don't link this, e.g. Slackware RL_OBJS=gcl_readline.o # Readline support now initialized automatically when compiled in, this lisp # object no longer needed -- 20040102 CM # RL_LIB=lsp/gcl_readline.o )) # These tests discover differences between readline 4.1 and 4.3 AC_CHECK_LIB(readline,rl_completion_matches, AC_DEFINE(HAVE_DECL_RL_COMPLETION_MATCHES,1,[have readline completion matches]) AC_DEFINE(HAVE_RL_COMPENTRY_FUNC_T,1,[have readline completion matches]),,) fi AC_SUBST(RL_OBJS) AC_SUBST(RL_LIB) AC_MSG_CHECKING(For network code for nsocket.c) AC_TRY_LINK([ #include #include #include #include #include #include /************* for the sockets ******************/ #include /* struct sockaddr, SOCK_STREAM, ... */ #ifndef NO_UNAME # include /* uname system call. */ #endif #include /* struct in_addr, struct sockaddr_in */ #include /* inet_ntoa() */ #include /* gethostbyname() */ ],[ connect(0,(struct sockaddr *)0,0); gethostbyname("jil"); socket(AF_INET, SOCK_STREAM, 0); ], [AC_DEFINE(HAVE_NSOCKET,1,[can use nsocket library]) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) AC_MSG_CHECKING(check for listen using fcntl) AC_TRY_COMPILE([#include #include ], [FILE *fp=fopen("configure.in","r"); int orig; orig = fcntl(fileno(fp), F_GETFL); if (! (orig & O_NONBLOCK )) return 0; ], [AC_DEFINE(LISTEN_USE_FCNTL,1,[can use fcntl for listen function]) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) AC_CHECK_FUNC(profil, ,[AC_DEFINE(NO_PROFILE,1,[no profil system call])]) AC_SUBST(NO_PROFILE) AC_CHECK_FUNC(setenv,[AC_DEFINE(HAVE_SETENV,1,[have setenv call])],no_setenv=1 ) AC_SUBST(HAVE_SETENV) if test "$no_setenv" = "1" ; then AC_CHECK_FUNC(putenv,[AC_DEFINE(HAVE_PUTENV,1,[have putenv call])],) AC_SUBST(HAVE_PUTENV) fi AC_CHECK_FUNC(_cleanup, [AC_DEFINE(USE_CLEANUP,1,[have _cleanup function])],) AC_SUBST(USE_CLEANUP) gcl_ok=no dnl AC_HEADER_EGREP(LITTLE_ENDIAN, ctype.h, gcl_ok=yes, gcl_ok=noo) dnl if test $gcl_ok = yes ; then dnl AC_DEFINE(ENDIAN_ALREADY_DEFINED) dnl fi dnl AC_SUBST(ENDIAN_ALREADY_DEFINED) # if test "x$enable_machine" = "x" ; then AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) case $system in OSF*) AC_DEFINE(USE_FIONBIO,1,[use fionbio for non-blocking io]) AC_MSG_RESULT(FIONBIO) ;; SunOS-4*) AC_DEFINE(USE_FIONBIO,1,[use fionbio for non-blocking io]) AC_MSG_RESULT(FIONBIO) ;; ULTRIX-4.*) AC_DEFINE(USE_FIONBIO,1,[use fionbio for non-blocking io]) AC_MSG_RESULT(FIONBIO) ;; *) AC_MSG_RESULT(O_NONBLOCK) ;; esac AC_MSG_CHECKING(check for SV_ONSTACK) AC_TRY_COMPILE([#include int joe=SV_ONSTACK; ], [], [AC_DEFINE(HAVE_SV_ONSTACK,1,[have sv_onstack]) AC_SUBST(HAVE_SV_ONSTACK) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) AC_MSG_CHECKING(check for SIGSYS) AC_TRY_COMPILE([#include int joe=SIGSYS; ], [], [AC_DEFINE(HAVE_SIGSYS,1,[have SIGSYS signal]) AC_SUBST(HAVE_SIGSYS) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) AC_MSG_CHECKING(check for SIGEMT) AC_TRY_COMPILE([#include int joe=SIGEMT; ], [], [AC_DEFINE(HAVE_SIGEMT,1,[have SIGEMT signal]) AC_SUBST(HAVE_SIGEMT) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) AC_CHECK_FUNCS(sigaltstack) AC_CHECK_FUNCS(feenableexcept) AC_CHECK_HEADERS(dis-asm.h, MLIBS=$LIBS AC_CHECK_LIB(opcodes,init_disassemble_info) AC_CHECK_LIB(dl,dlopen,#opcodes changes too quickly to link directly AC_CHECK_FUNCS(print_insn_i386,LIBS="$MLIBS -ldl"))) #if test $use = "386-linux" ; then AC_CHECK_HEADERS(asm/sigcontext.h) AC_CHECK_HEADERS(asm/signal.h) AC_MSG_CHECKING([for sigcontext...]) AC_TRY_COMPILE([#include ], [ struct sigcontext foo; ], [ sigcontext_works=1; AC_DEFINE(SIGNAL_H_HAS_SIGCONTEXT,1,[have sigcontext in signal.h]) AC_MSG_RESULT(sigcontext in signal.h) ], [sigcontext_works=0; AC_MSG_RESULT(sigcontext NOT in signal.h)] ) if test "$sigcontext_works" = 0 ; then AC_MSG_CHECKING([for sigcontext...]) AC_TRY_COMPILE([#include #ifdef HAVE_ASM_SIGCONTEXT_H #include #endif #ifdef HAVE_ASM_SIGNAL_H #include #endif ], [ struct sigcontext foo; ], [ AC_DEFINE(HAVE_SIGCONTEXT,1,[have sigcontext]) AC_MSG_RESULT(sigcontext in asm files) ], [ AC_MSG_RESULT(no sigcontext found) ]) fi # echo 'foo() {}' > conftest1.c # $CC -S conftest1.c # use_underscore=0 # if fgrep _foo conftest1.s ; then use_underscore=1 ; fi # if test $use_underscore = 0 ; then # MPI_FILE=mpi-386_no_under.o # else # MPI_FILE=mpi-386d.o # fi # AC_SUBST(MPI_FILE) # GCC=$CC # if test -x /usr/bin/i386-glibc20-linux-gcc ; then # GCC=/usr/bin/i386-glibc20-linux-gcc # fi # AC_SUBST(GCC) #fi AC_PATH_PROG(EMACS,emacs) # check for where the emacs site lisp directory is. rm -f conftest.el cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` else EMACS_SITE_LISP="" fi fi AC_MSG_RESULT($EMACS_SITE_LISP) AC_SUBST(EMACS_SITE_LISP) # check for where the emacs site lisp default.el is rm -f conftest.el cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` else EMACS_DEFAULT_EL="" fi if test -f "${EMACS_DEFAULT_EL}" ; then true;else if test -d $EMACS_SITE_LISP ; then EMACS_DEFAULT_EL=${EMACS_SITE_LISP}/default.el fi fi AC_MSG_RESULT($EMACS_DEFAULT_EL) AC_SUBST(EMACS_DEFAULT_EL) # check for where the emacs site lisp info/dir is rm -f conftest.el cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` fi fi AC_MSG_RESULT($INFO_DIR) AC_SUBST(INFO_DIR) if test "$enable_tcltk" = "yes" ; then AC_MSG_CHECKING([for tcl/tk]) if test -d "${TCL_CONFIG_PREFIX}" ; then true ; else AC_CHECK_PROG(TCLSH,tclsh,tclsh,${TCLSH}) if test "${TCLSH}" = "" ; then true ; else rm -f conftest.tcl cat >> conftest.tcl <&1 $CC -v | fgrep "gcc version 2.96" > /dev/null dnl then dnl BROKEN_O4_OPT=1 dnl AC_DEFINE(BROKEN_O4_OPT) dnl AC_SUBST(BROKEN_O4_OPT) dnl echo ODIR_DEBUG=-O >> makedefsafter dnl echo >> makedefsafter dnl AC_MSG_RESULT([yes .. turning off -O4]) dnl else dnl AC_MSG_RESULT([no]) dnl fi LDFLAGS="`echo $LDFLAGS | sed 's,gcl.script,../unixport/gcl.script,g'`" AC_SUBST(LDFLAGS) LIBS="$X_PRE_LIBS $X_LIBS $X_EXTRA_LIBS $TLDFLAGS $LIBS $TLIBS" AC_SUBST(LIBS) FINAL_CFLAGS="$CFLAGS $CPPFLAGS $X_CFLAGS $TCFLAGS $PROCESSOR_FLAGS" AC_SUBST(FINAL_CFLAGS) # Work around bug with gcc on ppc -- CM NIFLAGS="$CFLAGS $CPPFLAGS $TCFLAGS $TONIFLAGS $PROCESSOR_FLAGS -I\$(GCLDIR)/o" AC_SUBST(NIFLAGS) CFLAGS="$CFLAGS $CPPFLAGS $TCFLAGS $TO3FLAGS $PROCESSOR_FLAGS -I\$(GCLDIR)/o" AC_SUBST(CFLAGS) O3FLAGS=$TO3FLAGS AC_SUBST(O3FLAGS) O2FLAGS=$TO2FLAGS AC_SUBST(O2FLAGS) AC_SUBST(PRELINK_CHECK) AC_SUBST(EXTRA_LOBJS) AC_SUBST(LEADING_UNDERSCORE) AC_SUBST(GNU_LD) if test -f h/$use.defs ; then AC_SUBST(use) AC_OUTPUT(makedefc windows/gcl.iss windows/sysdir.bat windows/install.lsp ) echo makedefc cat makedefc echo add-defs1 $use CC=$CC ./add-defs1 $use else echo "Unable to guess machine type" echo use configure --enable-machine=XXX, for XXX such that h/XXX.defs exists, ie in h/*.defs fi gcl/debian/000077500000000000000000000000001242227143400130465ustar00rootroot00000000000000gcl/debian/README.Debian000066400000000000000000000023061242227143400151100ustar00rootroot00000000000000The Debian package gcl ---------------------- GCL is one of the oldest free common lisp systems still in use. Several production systems have used it for over a decade. The common lisp standard in effect when GCL was first released is known as "Common Lisp, the Language" (CLtL1) after a book by Steele of the same name providing this specification. Subsequently, a much expanded standard was adopted by the American National Standards Institute (ANSI), which is still considered the definitive common lisp language specification to this day. Debian GCL now installs both the small 'traditional' lisp image designed to conform to a pre-ANSI Lisp standard, and an experimental ANSI image. Please note that ANSI support in GCL is still preliminary. On an ansi-test suite written by a GCL developer, GCL fails on a little under 3 percent of the tests. Details can be found in /usr/share/doc/gcl/test_results.gz. To toggle the use of the ANSI image, set the environment variable GCL_ANSI to any non-empty string. New in 2.6.2 ------------ Please see the RELEASE-2.6.2.html file for release note information, regression testing, and sample benchmarks. -- Camm Maguire , Wed Dec 14 18:55:19 2005 gcl/debian/changelog000066400000000000000000003252141242227143400147270ustar00rootroot00000000000000gcl (2.6.10-31) unstable; urgency=medium * dpkg-buildflags trial -- Camm Maguire Tue, 22 Jul 2014 20:06:10 +0000 gcl (2.6.10-30) unstable; urgency=medium * fix offsets ppc -- Camm Maguire Tue, 22 Jul 2014 17:12:27 +0000 gcl (2.6.10-29) unstable; urgency=medium * fix unexec file offsets -- Camm Maguire Tue, 22 Jul 2014 15:36:45 +0000 gcl (2.6.10-28) unstable; urgency=high * enable prelink -- Camm Maguire Fri, 18 Jul 2014 19:24:38 +0000 gcl (2.6.10-27) unstable; urgency=high * protect closure calls from gc -- Camm Maguire Wed, 16 Jul 2014 16:15:33 +0000 gcl (2.6.10-26) unstable; urgency=high * Bug fix: "packages should not build-depend on binutils-dev", thanks to Matthias Klose (Closes: #754840). Please note that gcl has long depended on binutils-dev for good reason -- happily it is no longer necessary -- Camm Maguire Tue, 15 Jul 2014 16:04:04 +0000 gcl (2.6.10-25) unstable; urgency=high * rebuild to get gcc fixes on i386 -- Camm Maguire Fri, 11 Jul 2014 03:14:45 +0000 gcl (2.6.10-24) unstable; urgency=high * try default gcc 4.9 * access libopcodes without link dependency via dlopen * Bug fix: "please switch to emacs24", thanks to Gabriele Giacone (Closes: #754012). -- Camm Maguire Wed, 09 Jul 2014 17:34:21 +0000 gcl (2.6.10-23) unstable; urgency=high * rebuild latest binutils -- Camm Maguire Sat, 05 Jul 2014 23:19:27 +0000 gcl (2.6.10-22) unstable; urgency=high * gcc-4.8 on i386, 4.9 has bugs at present -- Camm Maguire Fri, 04 Jul 2014 01:36:06 +0000 gcl (2.6.10-21) unstable; urgency=high * 2.6.11pre test 20 -- Camm Maguire Mon, 30 Jun 2014 22:43:27 +0000 gcl (2.6.10-20) unstable; urgency=high * 2.6.11pre test 19 -- Camm Maguire Sun, 29 Jun 2014 17:59:59 +0000 gcl (2.6.10-19) unstable; urgency=high * 2.6.11pre test 18 -- Camm Maguire Sun, 29 Jun 2014 16:00:07 +0000 gcl (2.6.10-18) unstable; urgency=high * 2.6.11pre test 17 -- Camm Maguire Sat, 28 Jun 2014 16:57:54 +0000 gcl (2.6.10-17) unstable; urgency=high * 2.6.11pre test 16 -- Camm Maguire Thu, 26 Jun 2014 18:06:42 +0000 gcl (2.6.10-16) unstable; urgency=high * 2.6.11pre test 15 -- Camm Maguire Wed, 18 Jun 2014 17:37:36 +0000 gcl (2.6.10-15) unstable; urgency=high * 2.6.11pre test 14 -- Camm Maguire Tue, 17 Jun 2014 00:39:35 +0000 gcl (2.6.10-14) unstable; urgency=high * 2.6.11pre test 13 -- Camm Maguire Sat, 14 Jun 2014 13:43:57 +0000 gcl (2.6.10-13) unstable; urgency=high * 2.6.11pre test 12 -- Camm Maguire Tue, 20 May 2014 16:00:22 +0000 gcl (2.6.10-12) unstable; urgency=high * 2.6.11pre test 11 -- Camm Maguire Fri, 16 May 2014 17:41:33 +0000 gcl (2.6.10-11) unstable; urgency=high * 2.6.11pre test 10 -- Camm Maguire Fri, 16 May 2014 13:18:07 +0000 gcl (2.6.10-10) unstable; urgency=high * 2.6.11pre test 9 -- Camm Maguire Wed, 07 May 2014 17:10:30 +0000 gcl (2.6.10-9) unstable; urgency=high * 2.6.11pre test 8 -- Camm Maguire Fri, 25 Apr 2014 19:53:10 +0000 gcl (2.6.10-8) unstable; urgency=high * 2.6.11pre test 7 -- Camm Maguire Mon, 21 Apr 2014 14:09:37 +0000 gcl (2.6.10-7) unstable; urgency=high * 2.6.11pre test 6 -- Camm Maguire Sat, 19 Apr 2014 17:52:17 +0000 gcl (2.6.10-6) unstable; urgency=high * 2.6.11pre test 5 -- Camm Maguire Fri, 18 Apr 2014 15:06:09 +0000 gcl (2.6.10-5) unstable; urgency=high * 2.6.11pre test 4 -- Camm Maguire Tue, 15 Apr 2014 20:30:13 +0000 gcl (2.6.10-4) unstable; urgency=high * 2.6.11pre test 3 * Bug fix: "debian/rules uses DEB_BUILD_* macros instead of DEB_HOST_* macros", thanks to Matthias Klose (Closes: #743520). -- Camm Maguire Wed, 09 Apr 2014 13:15:32 +0000 gcl (2.6.10-3) unstable; urgency=high * 2.6.11pre test 2 -- Camm Maguire Thu, 03 Apr 2014 14:24:23 +0000 gcl (2.6.10-2) unstable; urgency=high * 2.6.11pre test 1 * Bug fix: "FTBFS: gcl_readline.d:472:39: error: 'CPPFunction' undeclared (first use in this function)", thanks to David Suárez (Closes: #741819). -- Camm Maguire Mon, 24 Mar 2014 15:47:01 +0000 gcl (2.6.10-1) unstable; urgency=high * New upstream release -- Camm Maguire Wed, 13 Nov 2013 18:39:19 +0000 gcl (2.6.9-17) unstable; urgency=high * 2.6.10pre test 17 -- Camm Maguire Mon, 11 Nov 2013 19:41:45 +0000 gcl (2.6.9-16) unstable; urgency=high * 2.6.10pre test 16 * Bug fix: "gcl 2.6.7+dfsga-20 needs 1 GB disk space on amd64", thanks to Edi Meier (Closes: #714507). * Bug fix: "[INTL:ja] New Japanese translation", thanks to victory (Closes: #718925). -- Camm Maguire Sat, 09 Nov 2013 13:34:32 +0000 gcl (2.6.9-15) unstable; urgency=high * 2.6.10pre test 15 -- Camm Maguire Sat, 02 Nov 2013 22:21:16 +0000 gcl (2.6.9-14) unstable; urgency=high * 2.6.10pre test 14 -- Camm Maguire Wed, 23 Oct 2013 17:44:14 +0000 gcl (2.6.9-13) unstable; urgency=high * environment allocation unrandomize.h -- Camm Maguire Mon, 21 Oct 2013 00:20:16 +0000 gcl (2.6.9-12) unstable; urgency=high * 2.6.10pre test 13 -- Camm Maguire Fri, 18 Oct 2013 14:18:17 +0000 gcl (2.6.9-11) unstable; urgency=high * 2.6.10pre test 12, s390, mingw cleanup, make_bignum bug fix -- Camm Maguire Tue, 15 Oct 2013 23:32:09 +0000 gcl (2.6.9-10) unstable; urgency=high * fast-fixnums -- Camm Maguire Fri, 11 Oct 2013 15:05:58 +0000 gcl (2.6.9-9) unstable; urgency=high * 2.6.10pre test 10 and 11 -- Camm Maguire Wed, 02 Oct 2013 19:12:36 +0000 gcl (2.6.9-8) unstable; urgency=high * 2.6.10pre test 8 and 9 -- Camm Maguire Tue, 01 Oct 2013 21:00:19 +0000 gcl (2.6.9-7) unstable; urgency=high * 2.6.10pre test 6 and 7 -- Camm Maguire Mon, 30 Sep 2013 19:34:38 +0000 gcl (2.6.9-6) unstable; urgency=high * 2.6.10pre test 5 -- Camm Maguire Tue, 24 Sep 2013 17:03:24 +0000 gcl (2.6.9-5) unstable; urgency=high * 2.6.10pre test 4 -- Camm Maguire Mon, 23 Sep 2013 19:27:36 +0000 gcl (2.6.9-4) unstable; urgency=high * 2.6.10pre test 3 -- Camm Maguire Mon, 23 Sep 2013 16:30:09 +0000 gcl (2.6.9-3) unstable; urgency=high * 2.6.10pre test 2 -- Camm Maguire Sun, 22 Sep 2013 03:27:10 +0000 gcl (2.6.9-2) unstable; urgency=high * 2.6.10pre test -- Camm Maguire Sat, 21 Sep 2013 04:14:55 +0000 gcl (2.6.9-1) unstable; urgency=high * New upstream release -- Camm Maguire Wed, 28 Aug 2013 16:49:18 +0000 gcl (2.6.7+dfsga-40) unstable; urgency=high * fix allocate functions -- Camm Maguire Tue, 06 Aug 2013 22:36:37 +0000 gcl (2.6.7+dfsga-39) unstable; urgency=high * lower initial contiguous and relblock allocations, set *ihs-top* properly on startup, protect memory->cfd.cfd_start initialization from gc -- Camm Maguire Mon, 05 Aug 2013 17:38:22 +0000 gcl (2.6.7+dfsga-38) unstable; urgency=high * robustify near oom handling to fix axiom compile of EXPEXPAN on mips -- Camm Maguire Fri, 02 Aug 2013 16:25:16 +0000 gcl (2.6.7+dfsga-37) unstable; urgency=high * ppc64 gprof fix -- Camm Maguire Fri, 26 Jul 2013 23:40:14 +0000 gcl (2.6.7+dfsga-36) unstable; urgency=high * min_pagewidth=14 on mips -- Camm Maguire Fri, 26 Jul 2013 02:20:56 +0000 gcl (2.6.7+dfsga-35) unstable; urgency=high * latest gcc on all platforms, no gprof ppc64, -O1 ia64, -O0 alpha -- Camm Maguire Thu, 25 Jul 2013 14:42:48 +0000 gcl (2.6.7+dfsga-34) unstable; urgency=high * sgc link_array mark fix;rb_end across save fix;more stable gcc on older arches -- Camm Maguire Tue, 23 Jul 2013 17:11:23 +0000 gcl (2.6.7+dfsga-33) unstable; urgency=high * fix mark_link_array for marked sLAlink_arrayA->s.s_dbind -- Camm Maguire Mon, 22 Jul 2013 19:00:43 +0000 gcl (2.6.7+dfsga-32) unstable; urgency=high * protect mark_link_array in sgc -- Camm Maguire Sat, 20 Jul 2013 00:16:07 +0000 gcl (2.6.7+dfsga-31) unstable; urgency=high * properly clean link array on gc -- Camm Maguire Fri, 19 Jul 2013 20:34:34 +0000 gcl (2.6.7+dfsga-30) unstable; urgency=high * fix gcl.script compiler::link, darwin compile warnings -- Camm Maguire Mon, 15 Jul 2013 20:35:03 +0000 gcl (2.6.7+dfsga-29) unstable; urgency=high * fix compiler::link in presence of gcl.script -- Camm Maguire Mon, 15 Jul 2013 16:23:33 +0000 gcl (2.6.7+dfsga-28) unstable; urgency=high * install unixport/gcl.script -- Camm Maguire Sat, 13 Jul 2013 18:42:28 +0000 gcl (2.6.7+dfsga-27) unstable; urgency=high * workaround for ia64 and hurd brk issues -- Camm Maguire Fri, 12 Jul 2013 21:44:54 +0000 gcl (2.6.7+dfsga-26) unstable; urgency=high * -- command line support, map-shared in unexec -- Camm Maguire Fri, 12 Jul 2013 00:52:35 +0000 gcl (2.6.7+dfsga-25) unstable; urgency=high * alpha, mips, 68k -- Camm Maguire Wed, 10 Jul 2013 18:29:37 +0000 gcl (2.6.7+dfsga-24) unstable; urgency=high * sgc and reloc fixes -- Camm Maguire Mon, 08 Jul 2013 13:56:33 +0000 gcl (2.6.7+dfsga-23) unstable; urgency=high * fix for maxima on kfbsd and sparc -- Camm Maguire Wed, 03 Jul 2013 19:19:16 +0000 gcl (2.6.7+dfsga-22) unstable; urgency=high * fix stack definition issues on i386 -- Camm Maguire Tue, 02 Jul 2013 18:27:54 +0000 gcl (2.6.7+dfsga-21) unstable; urgency=high * near out of memory robustification -- Camm Maguire Tue, 02 Jul 2013 15:32:58 +0000 gcl (2.6.7+dfsga-20) unstable; urgency=high * fix 3GB workaround for gprof -- Camm Maguire Fri, 21 Jun 2013 11:09:01 -0400 gcl (2.6.7+dfsga-19) unstable; urgency=high * work around 3GB personality/alloca/malloc bug -- Camm Maguire Fri, 21 Jun 2013 02:46:49 +0000 gcl (2.6.7+dfsga-18) unstable; urgency=high * alpha NULL_OR_ON_C_STACK, attempt to get 32 immfix space with ADDR_LIMIT_3GB|ADDR_COMPAT_LAYOUT personality, clean compile with no immfix -- Camm Maguire Thu, 20 Jun 2013 20:24:29 +0000 gcl (2.6.7+dfsga-17) unstable; urgency=high * small optimizations, #= nil fix -- Camm Maguire Wed, 19 Jun 2013 16:23:27 +0000 gcl (2.6.7+dfsga-16) unstable; urgency=high * no linker script on hurd;fix OBJ_ALIGN -- Camm Maguire Thu, 13 Jun 2013 15:35:00 +0000 gcl (2.6.7+dfsga-15) unstable; urgency=high * ia64 fix -- Camm Maguire Thu, 13 Jun 2013 02:38:47 +0000 gcl (2.6.7+dfsga-14) unstable; urgency=high * eliminate maxpage/dbegin, restore windows and macosx builds -- Camm Maguire Wed, 12 Jun 2013 21:42:29 +0000 gcl (2.6.7+dfsga-13) unstable; urgency=low * ia64/hurd/s390 and SGC -- Camm Maguire Sun, 09 Jun 2013 00:23:51 +0000 gcl (2.6.7+dfsga-12) unstable; urgency=low * ia64/hurd/s390 -- Camm Maguire Sat, 08 Jun 2013 15:24:46 +0000 gcl (2.6.7+dfsga-11) unstable; urgency=high * 2.6.9 test -- Camm Maguire Fri, 07 Jun 2013 21:46:41 +0000 gcl (2.6.7+dfsga-10) unstable; urgency=high * output mips make bug text to stderr -- Camm Maguire Sat, 25 May 2013 12:24:35 +0000 gcl (2.6.7+dfsga-9) unstable; urgency=high * mips make bug workaround -- Camm Maguire Wed, 22 May 2013 14:23:43 +0000 gcl (2.6.7+dfsga-8) unstable; urgency=high * revert doubled default maxpage * export *read-eval* -- Camm Maguire Tue, 21 May 2013 14:42:05 +0000 gcl (2.6.7+dfsga-7) unstable; urgency=high * export ansi symbols -- Camm Maguire Sat, 11 May 2013 21:36:56 +0000 gcl (2.6.7+dfsga-6) unstable; urgency=high * fast hash-equal in compiler -- Camm Maguire Sat, 11 May 2013 19:11:42 +0000 gcl (2.6.7+dfsga-5) unstable; urgency=high * Bug fix: "FTBFS: cp: cannot stat 'debian/tmp/usr/share/info/gcl-si.info': No such file or directory", thanks to Lucas Nussbaum (Closes: #707490). -- Camm Maguire Fri, 10 May 2013 18:09:14 +0000 gcl (2.6.7+dfsga-4) unstable; urgency=high * sgc-on fix with latest gcc -- Camm Maguire Tue, 23 Apr 2013 18:45:11 +0000 gcl (2.6.7+dfsga-3) unstable; urgency=high * hash depth bug fix * new s390 reloc -- Camm Maguire Thu, 24 Jan 2013 19:46:30 +0000 gcl (2.6.7+dfsga-2) unstable; urgency=high * more arm relocs supported;check default timezone dynamically;follow bash ~ semantics in user-homedir-pathname -- Camm Maguire Mon, 21 Jan 2013 18:41:06 +0000 gcl (2.6.7+dfsga-1) unstable; urgency=high * Acknowledge Non-maintainer upload. (thanks David Prévot ) * Remove unused and non DFSG-compliant gmp3/gmp.* from source. (Closes: #695721) * Show translated debconf templates, thanks to Denis Barbier for the analysis and the proposed fixes. (Closes: #691946) * trim excess digits from printed floats -- Camm Maguire Tue, 15 Jan 2013 20:46:25 +0000 gcl (2.6.7-108) unstable; urgency=high * Depend on emacs23 | emacsen to allow wheezy propagation -- Camm Maguire Mon, 08 Oct 2012 18:08:36 +0000 gcl (2.6.7-107) unstable; urgency=high * mode 644 on ucf newfile -- Camm Maguire Wed, 03 Oct 2012 20:38:43 +0000 gcl (2.6.7-106) unstable; urgency=high * Bug fix: "modifies conffiles (policy 10.7.3): /etc/default/gcl", thanks to Andreas Beckmann (Closes: #688201). -- Camm Maguire Wed, 03 Oct 2012 16:52:10 +0000 gcl (2.6.7-105) unstable; urgency=high * restore #DEBHELPER# to postinst and postrm scripts -- Camm Maguire Mon, 01 Oct 2012 17:31:43 +0000 gcl (2.6.7-104) unstable; urgency=high * Bug fix: "modifies conffiles (policy 10.7.3): /etc/default/gcl", thanks to Andreas Beckmann (Closes: #688201). -- Camm Maguire Mon, 01 Oct 2012 15:32:52 +0000 gcl (2.6.7-103) unstable; urgency=high * sfaslelf.c: FIX_HIDDEN_SYMBOLS -- Camm Maguire Wed, 22 Aug 2012 15:13:12 +0000 gcl (2.6.7-102) unstable; urgency=high * Fix hash key distribution bug, bitvector equal bug * distinguish car position in equal-hash of lists -- Camm Maguire Mon, 20 Aug 2012 17:33:26 +0000 gcl (2.6.7-101) unstable; urgency=high * add alpha, ppc, ppc64, and ia64 to __builtin__clear_cache exception list as per gcc maintainers * lintian cleanups -- Camm Maguire Sat, 05 May 2012 23:18:56 +0000 gcl (2.6.7-100) unstable; urgency=high * nil case keylist support * Bug fix: "[INTL:da] Danish translation of the debconf templates gcl", thanks to Joe Dalton (Closes: #666528). -- Camm Maguire Fri, 20 Apr 2012 02:25:26 +0000 gcl (2.6.7-99) unstable; urgency=low * case default error checking -- Camm Maguire Fri, 23 Mar 2012 14:14:44 +0000 gcl (2.6.7-98) unstable; urgency=low * restore traditional make-sequence,make-array, and coerce, and optimize replace, as 2.6.8 compiler is still too weak re: inlines -- Camm Maguire Fri, 20 Jan 2012 19:55:45 +0000 gcl (2.6.7-97) unstable; urgency=low * evade __builtin___clear_cache on hppa * make-array;make-sequence;replace;coerce -- Camm Maguire Fri, 20 Jan 2012 05:13:22 +0000 gcl (2.6.7-96) unstable; urgency=low * better XDR detection; no __builtin_clear_cache on sh4 -- Camm Maguire Wed, 18 Jan 2012 01:32:43 +0000 gcl (2.6.7-95) unstable; urgency=low * clear_cache after mprotect -- Camm Maguire Tue, 17 Jan 2012 03:54:56 +0000 gcl (2.6.7-94) unstable; urgency=low * optimize unwind at O0 to workaround gcc bug; centralize on __builtin__clear_cache when available;arm_thm_call reloc support -- Camm Maguire Mon, 16 Jan 2012 20:10:07 +0000 gcl (2.6.7-93) unstable; urgency=low * remove C_GC_OFFSET for sparc64 * remove ncurses dependency for readline * Bug fix: "FTBFS: dpkg-buildpackage: error: dpkg-source -b gcl-2.6.7 gave error exit status 2", thanks to Didier Raboud (Closes: #643131). * Bug fix: "drops readline support if rebuilt", thanks to Sven Joachim (Closes: #646735). * lower opts on sparc64 asof gcc 4.6.1 -- Camm Maguire Wed, 11 Jan 2012 21:04:23 +0000 gcl (2.6.7-92) unstable; urgency=low * remove gprof on arm as mcount calls are 24/22bit -- marginally accessible -- Camm Maguire Sat, 07 Jan 2012 02:42:06 +0000 gcl (2.6.7-91) unstable; urgency=low * s390x reloc support * lower C optimization on ia64, arm and mips for now -- Camm Maguire Thu, 05 Jan 2012 17:30:01 +0000 gcl (2.6.7-90) unstable; urgency=low * libtirpc check for newest glibc * read_preserving_whitespace fix * armhf reloc support * s390x support * try C_GC_OFFSET for sparc64 -- Camm Maguire Wed, 04 Jan 2012 19:51:13 +0000 gcl (2.6.7-89) unstable; urgency=low * support new mips relocs * lower opt to work around gcc 4.6 bug on arm -- Camm Maguire Wed, 11 May 2011 20:06:04 +0000 gcl (2.6.7-88) unstable; urgency=low * Bug fix: "FTBFS: gcl_arraylib.c:4:42: error: 'VV' undeclared (first use in this function)", thanks to Lucas Nussbaum (Closes: #625032). -- Camm Maguire Mon, 09 May 2011 16:00:21 +0000 gcl (2.6.7-87) unstable; urgency=low * mips reloc fix;configure default dlopen fix;clean rules and makefiles -- Camm Maguire Fri, 05 Nov 2010 13:29:05 +0000 gcl (2.6.7-86) unstable; urgency=low * remove binutils subdir, configure and make changes -- Camm Maguire Thu, 04 Nov 2010 17:55:48 +0000 gcl (2.6.7-85) unstable; urgency=low * fix mips relocs for non-static clines -- Camm Maguire Tue, 02 Nov 2010 13:56:40 +0000 gcl (2.6.7-84) unstable; urgency=low * better mips relocs, fix link on mingw32 -- Camm Maguire Sat, 30 Oct 2010 00:07:39 +0000 gcl (2.6.7-83) unstable; urgency=low * fix alpha stubs; fix sparc64 typo; print armhf relocs -- Camm Maguire Thu, 28 Oct 2010 13:43:16 +0000 gcl (2.6.7-82) unstable; urgency=low * mips64 fixes -- Camm Maguire Tue, 26 Oct 2010 18:20:04 +0000 gcl (2.6.7-81) unstable; urgency=low * sparc64;mips64 -- Camm Maguire Tue, 26 Oct 2010 03:33:52 +0000 gcl (2.6.7-80) unstable; urgency=low * alpha stubs; sgc mips kernel bug test; mips GPREL32 reloc -- Camm Maguire Mon, 25 Oct 2010 19:52:51 +0000 gcl (2.6.7-79) unstable; urgency=low * mips ld_bind_now, disable sgc workaround mips SIGBUS bug -- Camm Maguire Wed, 20 Oct 2010 15:31:59 +0000 gcl (2.6.7-78) unstable; urgency=low * mips local got relocs -- Camm Maguire Tue, 12 Oct 2010 17:15:35 +0000 gcl (2.6.7-77) unstable; urgency=low * workaround gcc alpha bug * fix alpha reloc -- Camm Maguire Fri, 01 Oct 2010 21:25:11 +0000 gcl (2.6.7-76) unstable; urgency=low * fix page_multiple usage for runtime pagesize variance and stable mipsel builds * sparc64 support -- Camm Maguire Fri, 01 Oct 2010 19:18:47 +0000 gcl (2.6.7-75) unstable; urgency=low * fix alpha bug -- Camm Maguire Tue, 28 Sep 2010 20:23:21 +0000 gcl (2.6.7-74) unstable; urgency=low * fix alpha relocs for axiom -- Camm Maguire Tue, 28 Sep 2010 16:07:38 +0000 gcl (2.6.7-73) unstable; urgency=low * sparc reloc updates * fast-link fix -- Camm Maguire Fri, 24 Sep 2010 19:23:16 +0000 gcl (2.6.7-72) unstable; urgency=low * remove unused symbols from gcl_cmpopt.lsp * reloc updates * clear gcc warning * default tilde expansion to HOME env in absence of passwd * configure typo fix -- Camm Maguire Wed, 22 Sep 2010 19:32:52 +0000 gcl (2.6.7-71) unstable; urgency=low * print sparc64 relocs -- Camm Maguire Sat, 28 Aug 2010 14:50:00 +0000 gcl (2.6.7-70) unstable; urgency=low * sparc64/m68k -- Camm Maguire Fri, 27 Aug 2010 16:54:11 +0000 gcl (2.6.7-69) unstable; urgency=low * Bug fix: "non-standard gcc/g++ used for build (gcc-4.3)", thanks to Matthias Klose (Closes: #594280). -- Camm Maguire Thu, 26 Aug 2010 19:08:39 +0000 gcl (2.6.7-68) unstable; urgency=low * ppc/mips elf reloc fixes -- Camm Maguire Mon, 23 Aug 2010 20:54:30 +0000 gcl (2.6.7-67) unstable; urgency=low * Fix compiler::link ansi combo -- Camm Maguire Sat, 21 Aug 2010 02:05:37 +0000 gcl (2.6.7-66) unstable; urgency=low * ppc autobuild fix * Bug fix: "FTBFS: sfasli.c:139: error: invalid initializer", thanks to Lucas Nussbaum (Closes: #593037). * Bug fix: "FTBFS on powerpc: Error: The function TK::GET-AUTOLOADS is undefined.", thanks to Mehdi Dogguy (Closes: #593191). -- Camm Maguire Fri, 20 Aug 2010 01:25:09 +0000 gcl (2.6.7-65) unstable; urgency=low * autobuilder fixes -- Camm Maguire Sat, 14 Aug 2010 11:30:46 +0000 gcl (2.6.7-64) unstable; urgency=low * configure fix -- Camm Maguire Fri, 13 Aug 2010 23:26:07 +0000 gcl (2.6.7-63) unstable; urgency=low * macosx support, ppc, i386 and x86_64 -- sfaslmacho.c * windows/wine support -- sfaslcoff.c * better custreloc support obviating my_plt -- sfaslelf.c * debian default custreloc build where supported, all but ia64 and hppa * fix mingw/wine path issues -- Camm Maguire Fri, 13 Aug 2010 16:08:49 +0000 gcl (2.6.7-62) unstable; urgency=high * more stable sgc detection via h/tsgc.h * fix plt.h bug on hppa * sublis1-inline fix for acl2 -- Camm Maguire Mon, 26 Jul 2010 16:03:54 +0000 gcl (2.6.7-61) unstable; urgency=high * mac osx support * fix undef sgc bug in cmpinclude.h -- Camm Maguire Tue, 20 Jul 2010 14:50:19 +0000 gcl (2.6.7-60) unstable; urgency=high * fix sh4 support -- Camm Maguire Thu, 29 Apr 2010 18:09:04 +0000 gcl (2.6.7-59) unstable; urgency=high * fix hurd support -- Camm Maguire Fri, 23 Apr 2010 17:12:54 +0000 gcl (2.6.7-58) unstable; urgency=high * hurd support * sh4 support -- Camm Maguire Fri, 23 Apr 2010 05:09:29 +0000 gcl (2.6.7-57) unstable; urgency=high * static function pointer wrapper for gcl_gmp_allocfun, stabilizing gmp on hppa/ia64 -- Camm Maguire Mon, 12 Apr 2010 22:28:41 +0000 gcl (2.6.7-56) unstable; urgency=high * __builtin___clear_cache on arm * gcc-4.3 on alpha -- Camm Maguire Thu, 28 Jan 2010 00:32:16 +0000 gcl (2.6.7-55) unstable; urgency=low * SGC fix, debian override fix, xgcl update * SGC fix for relocatable and contiguous gmp storage * configure fix for arm and hppa -- Camm Maguire Tue, 26 Jan 2010 19:43:08 +0000 gcl (2.6.7-54) unstable; urgency=low * robustify user_match, unrandomize, read-char-no-hang for sockets * SA_SIGINFO for 386-linux * if cmpinclude.h is not available, use *cmpinclude-string* in compiler-pass2 -- Camm Maguire Wed, 20 Jan 2010 19:02:28 +0000 gcl (2.6.7-53) unstable; urgency=low * revert round ratio to nearest -- Camm Maguire Tue, 05 Jan 2010 03:06:59 +0000 gcl (2.6.7-52) unstable; urgency=low * SIGINFO for kfreebsd-386 -- Camm Maguire Mon, 04 Jan 2010 17:49:05 +0000 gcl (2.6.7-51) unstable; urgency=low * user_match exscapes once only -- Camm Maguire Sun, 03 Jan 2010 05:31:20 +0000 gcl (2.6.7-50) unstable; urgency=low * gcc 4.4 warning cleanups -- Camm Maguire Thu, 31 Dec 2009 20:43:39 +0000 gcl (2.6.7-49) unstable; urgency=low * Bug fix: "/bin/sh: line 6: /bin/gcl: Permission denied", thanks to Nobuhiro Iwamatsu (Closes: #561554). -- Camm Maguire Wed, 30 Dec 2009 23:04:39 +0000 gcl (2.6.7-48) unstable; urgency=low * round to nearest in ratio to double -- Camm Maguire Wed, 16 Dec 2009 15:01:55 +0000 gcl (2.6.7-47) unstable; urgency=low * Bug fix: "configure: error: Need zlib for bfd linking", thanks to Cyril Brulebois (Closes: #560761). * Bug fix: "Disfunctional maintainer address", thanks to Joerg Jaspert (Closes: #560752). -- Camm Maguire Mon, 14 Dec 2009 19:06:45 +0000 gcl (2.6.7-46) unstable; urgency=low * support newer binutils with output_bfd element * Fix 64bit interrupt bug * reader error fix * Ensure plt entries are not blank * plt table reading fix * Bug fix: "FTBFS: current binutils static libs need -lz", thanks to Daniel Schepler (Closes: #521929). * Bug fix: "replacing libreadline5-dev build dependency with libreadline-dev", thanks to Matthias Klose (Closes: #553761). * Bug fix: "crash after ctrl-C", thanks to Miroslaw Kwasniak (Closes: #519903). * Bug fix: "FTBFS with binutils-gold", thanks to Peter Fritzsche (Closes: #554418). -ldl added to bfd linker args * Bug fix: "[INTL:es] Spanish debconf template translation for gcl", thanks to Francisco Javier Cuadrado (Closes: #508728). * Bug fix: "[INTL:it] Italian translation", thanks to Vincenzo Campanella (Closes: #560364). * gcc error/warning cleanups * fix plt table awk -- Camm Maguire Fri, 11 Dec 2009 17:45:14 +0000 gcl (2.6.7-45) unstable; urgency=high * proper word order detection macro, fixes armel -- Camm Maguire Mon, 01 Sep 2008 13:48:16 +0000 gcl (2.6.7-44) unstable; urgency=high * backoff on arm opts * more careful handling of GCL_GPROF_START -- Camm Maguire Sat, 23 Aug 2008 21:28:52 +0000 gcl (2.6.7-43) unstable; urgency=low * redo unrandomize.h to enable compilation under -O2 -- FIXME; Closes: 494153 -- Camm Maguire Wed, 20 Aug 2008 21:18:43 +0000 gcl (2.6.7-42) unstable; urgency=low * more div/rem symbols for alpha -- Camm Maguire Sun, 03 Aug 2008 11:18:51 +0000 gcl (2.6.7-41) unstable; urgency=low * more div/rem symbols for arm and hppa -- Camm Maguire Sat, 02 Aug 2008 00:36:07 +0000 gcl (2.6.7-40) unstable; urgency=low * default gcc with pic enabled on mips/mipsel -- Camm Maguire Fri, 01 Aug 2008 13:28:00 -0400 gcl (2.6.7-39) unstable; urgency=high * gcc 4.2 for mips/mipsel for now * __divdi3 et. al. symbols for ia64 and arm * clean some compiler warnings -- Camm Maguire Fri, 01 Aug 2008 12:53:07 -0400 gcl (2.6.7-38) unstable; urgency=low * No infinite unrandomization loops -- Camm Maguire Thu, 31 Jul 2008 15:18:37 -0400 gcl (2.6.7-37) unstable; urgency=low * Non-maintainer upload to fix pending l10n issues * Debconf templates and debian/control reviewed by the debian-l10n- english team as part of the Smith review project. Closes: #457025 * [Debconf translation updates] - Portuguese. Closes: #457576 - Czech. Closes: #457677 - French. Closes: #458120 - Finnish. Closes: #458255 - Galician. Closes: #458529 - Vietnamese. Closes: #459008 - Russian. Closes: #459308 - Dutch. Closes: #459541 - German. Closes: #459887 * [Lintian] Correct FSF address in debian/copyright * [Lintian] Remove extra whitespaces at the end of debian/in.gcl-doc.doc-base.tk * [Lintian] Correct section in doc-base documents from Apps/Programming to Programming * Accept NMU * Bug fix: "[INTL:sv] po-debconf file for gcl", thanks to Martin Ã…gren (Closes: #492241). * Bug fix: "gcl: FTBFS [amd64]: cannot trap sbrk", thanks to Daniel Schepler (Closes: #487435). Modified and applied personality handling patch. * Bug fix: "gcl: Builds broken package with gcc-4.3", thanks to Daniel Schepler (Closes: #467474). Added sincos to plttest.c -- Camm Maguire Thu, 31 Jul 2008 15:18:15 -0400 gcl (2.6.7-36) unstable; urgency=low * statsysbfd in Debian, incoporating modules into libgcl.a for compiler::link support -- Camm Maguire Fri, 30 Nov 2007 12:03:31 -0500 gcl (2.6.7-35) unstable; urgency=low * drop gcc-3.4 on arm, Closes: #440421 * Depend on emacs22 | emacsen, Closes: #440190 * debconf translations Closes: #410683, Closes: #419736, Closes: #423706, Closes: #441408 -- Camm Maguire Fri, 23 Nov 2007 10:25:23 -0500 gcl (2.6.7-34) unstable; urgency=low * add read-byte,read-sequence,write-byte,write-sequence support * fix some float parsing inaccuracies * support GNU_HASH sections, Closes: #426135 * safety 2 for certain low level functions in gcl_listlib.lsp, CLoses: #415266 -- Camm Maguire Wed, 4 Jul 2007 16:23:25 -0400 gcl (2.6.7-33) unstable; urgency=low * Fix leading underscore behavior of my_plt * add sqrt to plttest.c * disable-nls added to the binutils subconfigures to avoid msgfmt dependency * remove -lintl from powerpc-macosx.defs * update to make-user-init from cvs head to support hol88, fix link on mingw * solaris-i386 support * fix read-char-no-hang on mingw * fast compile without wrap-literals * sigaltstack support * fix cerror -- Camm Maguire Wed, 16 May 2007 12:45:40 -0400 gcl (2.6.7-32) unstable; urgency=low * static function pointers for hppa -- Camm Maguire Sun, 29 Oct 2006 02:15:13 -0500 gcl (2.6.7-31) unstable; urgency=low * no C optimization on hppa, gcc 4.x on hppa * update cs.po, Closes: #389211 -- Camm Maguire Fri, 27 Oct 2006 13:06:55 -0400 gcl (2.6.7-30) unstable; urgency=low * make sure *tmp-dir* is set * makeinfo is optional -- Camm Maguire Wed, 25 Oct 2006 17:37:54 -0400 gcl (2.6.7-29) unstable; urgency=low * Fix build issues on hppa and m68k -- Camm Maguire Sat, 21 Oct 2006 15:10:41 -0400 gcl (2.6.7-28) unstable; urgency=low * si::gettimeofday function for HOL88 build;macosx fixes -- Camm Maguire Wed, 18 Oct 2006 13:21:26 -0400 gcl (2.6.7-27) unstable; urgency=low * unrestricted gcc for alpha * more default stack space -- Camm Maguire Tue, 17 Oct 2006 16:33:43 -0400 gcl (2.6.7-26) unstable; urgency=low * Fix large float read bug in c1constant-value -- Camm Maguire Mon, 16 Oct 2006 12:41:03 -0400 gcl (2.6.7-25) unstable; urgency=low * build-dep on gcc3.4 where appropriate * Newer standards -- Camm Maguire Thu, 12 Oct 2006 09:37:08 -0400 gcl (2.6.7-24) unstable; urgency=low * build-dep on gcc3.4 where appropriate * Newer standards -- Camm Maguire Thu, 12 Oct 2006 02:22:04 -0400 gcl (2.6.7-23) unstable; urgency=low * backoff to gcc-3.4 on alpha,arm,hppa, and m68k -- Camm Maguire Wed, 11 Oct 2006 10:16:59 -0400 gcl (2.6.7-22) unstable; urgency=low * HAVE_SYS_SOCKIO_H for solaris * autolocbfd for solaris * no -Wall when no gcc * no -fomit-frame-pointer on m68k * no profiling on mips * $(AWK) instead of awk * si::stat function * fix 'the boolean type coersion error * no varargs on cygwin * while eval macro * gensym counter fixes * xgcl updates -- Camm Maguire Fri, 15 Sep 2006 13:48:28 -0400 gcl (2.6.7-21) unstable; urgency=low * Fix socket write error -- Camm Maguire Wed, 6 Sep 2006 09:59:50 -0400 gcl (2.6.7-20) unstable; urgency=low * fix ia64 build -- Camm Maguire Thu, 31 Aug 2006 15:14:18 -0400 gcl (2.6.7-19) unstable; urgency=low * xgcl upgrade * parse_number from cvs head with *read-base* fixes * fix object_to_string * install xgcl-2/sysdef.lisp * fix info dir and emacs site lisp dir installation * New xgcl readme * Remove bashism from debian/rules, Closes: #376806, Closes: #385176. * Fix dwdoc doc-base error, Closes: #385126 -- Camm Maguire Wed, 30 Aug 2006 12:13:46 -0400 gcl (2.6.7-18) unstable; urgency=low * remove emacs build dependency * synch xgcl-2 with Novak edits * fix build errors * Remove power of two limit to MAXPAGE;fix X lib paths * configure cleanup * delete-file works on directories;build xgcl the old way;latest xgcl from Gordon Novak -- Camm Maguire Wed, 23 Aug 2006 14:19:51 -0400 gcl (2.6.7-17) unstable; urgency=low * Bug fix: "gcl: [INTL:sv] Swedish debconf templates translation", thanks to Daniel Nylander (Closes: #343695). * Bug fix: "gcl: French debconf templates translation update", thanks to Sylvain Archenault (Closes: #344629). * clean xgcl-2/gmon.out * cleanup latest gcc type-punning warnings * defentry C proclamations and xgcl cleanup -- Camm Maguire Mon, 26 Jun 2006 16:45:09 +0000 gcl (2.6.7-16) unstable; urgency=high * Add missing build dependencies, omit html generation to avoid non-free dependencies, CLoses: #372574. -- Camm Maguire Mon, 19 Jun 2006 14:05:59 +0000 gcl (2.6.7-15) unstable; urgency=low * Use internal gettext for bfd * Restore xgcl2 * Set compiler::*tmp-dir* at runtime * report tmp-dir setting with system-banner to enable clean -eval - batch operation; fix listen on socket streams; use (abs (getpid)) in tmp names for Windows * fix configure unbalanced quotes * support for bignums in nth et.al. * Fix branch cut of atanh * Fix typep on simple-arrays * prevent nested free errors * revert atanh branch cut change * Fix function documentation wrapping by compile * cond evalmacro from cvs head * Fix fixnum declarations in new smallnthcdr/bignthcdr * fix simple-array typep * updates for lsp/sys-proclaim * xgcl integration -- Camm Maguire Fri, 9 Jun 2006 17:52:22 +0000 gcl (2.6.7-14) unstable; urgency=low * Add mount declaration to plt.c -- Camm Maguire Sun, 18 Dec 2005 12:56:51 +0000 gcl (2.6.7-13) unstable; urgency=low * Add feof to plttest.c for macosx * plt related fixes for macosx * fix configure * Cleanup LEADING_UNDERSCORE case in plt.c et.al for macosx et.al. * pass devices if present in compiler::get-temp-dir, fix disassemble for new gazonk name pattern -- Camm Maguire Sat, 17 Dec 2005 15:22:40 +0000 gcl (2.6.7-12) unstable; urgency=low * Fix read-char-no-hang * Strip emacs warnings when finding site-lisp directory * mach-o update for latest binutils * Latext bfd mach-o support from Aurelien * revert to locbfd default on ppc-macosx * More ppc macosx fixes from Aurelien * revert a few macosx changes * default to void * prototype on my_sbrk for latest macosx pending Aureliens #ifdef * Fix plt.h parsing on macosx * Fix leading_underscore detection on mac * macosx name mangling fixes * multi-process safe gazonk names in compiler::*tmp-dir* * Add underscore-mangled setjmp calls to plttest.c for macosx * Fix POTFILES.in, Closes: #336207. * Update templates, Closes: #324636 * New French and Swedish translations, Closes: #333654, Closes: #336757. -- Camm Maguire Wed, 14 Dec 2005 18:52:49 +0000 gcl (2.6.7-11) unstable; urgency=low * Remove gcc-3.3 for arm in debian/rules * make default maxpage depend on SIZEOF_LONG and PAGEWIDTH in a sane fashion -- Camm Maguire Thu, 20 Oct 2005 00:08:37 +0000 gcl (2.6.7-10) unstable; urgency=low * Fix long-call gcc configure bug for ppc, add fdollars in identifiers on arm * remove gcc restrictions on arm * revert 64bit coersion (gmp_big.c, maybe_replace_big) and replace with code in siLnani (main.c) to get addresses from bignums. 2.7.0 will have 64bit fixnums on 64bit machines, but this should not be backported to 2.6.x -- Camm Maguire Wed, 12 Oct 2005 23:11:12 +0000 gcl (2.6.7-9) unstable; urgency=low * 64bit fixnum fasd data format fix from cvs head -- Camm Maguire Wed, 5 Oct 2005 18:49:50 +0000 gcl (2.6.7-8) unstable; urgency=low * Fix 64bit fixnum coersion bug using code from cvs HEAD -- Camm Maguire Fri, 30 Sep 2005 22:14:38 +0000 gcl (2.6.7-7) unstable; urgency=high * Scan .o file for init name when using dlopen * Set init name using .o file instead of source file by default * wrap-literals function from cvs head to allow optimizations using compile or compile-file * ADDR_NO_RANDOMIZE fix -- Camm Maguire Thu, 29 Sep 2005 17:50:56 +0000 gcl (2.6.7-6) unstable; urgency=high * Build bfd snapshot locally, Closes: #318681 -- Camm Maguire Tue, 20 Sep 2005 17:53:17 +0000 gcl (2.6.7-5) unstable; urgency=high * gcc-3.3 for arm -- Camm Maguire Thu, 15 Sep 2005 20:33:00 +0000 gcl (2.6.7-4) unstable; urgency=high * gcc 3.4 on arm to work around reserved '$' identifiers. * gcl: French translation update * French translation added, Closes: #325214 * Czech translation added, Closes: #325869 -- Camm Maguire Thu, 15 Sep 2005 13:45:11 +0000 gcl (2.6.7-3) unstable; urgency=low * static wraper for compiled_regexp for ia64 -- Camm Maguire Sat, 10 Sep 2005 11:26:37 +0000 gcl (2.6.7-2) unstable; urgency=high * rebuild against libgmp3c2, Closes: #323765 * 2.6.7 fixes all gcc 4.0 issues. Closes: #323979 -- Camm Maguire Wed, 24 Aug 2005 00:44:48 +0000 gcl (2.6.7-1) unstable; urgency=high * Fix (listen) with readline on * fix control-d with readline * libreadline5 support for Debian * Support for pre-compiled regexps and new texinfo format * Reenable run-process * Push function 'accept into lisp, use select for 'listen on socket streams * New Upstream release version * Native-reloc feature * Add daemon capabilities to server sockets, document socket and accept * Some gcl-tk fixes * Update wrapt-literals strategy to be consistent with CVS head -- wrap evreything but symbols and integers, don't wrap when keeping the gazonk files for linking in different images, this is really a compile-file operation * gcltk demo cleanups * Probe-file, open_stream, and the like fail on directories * Resolve symlinks in truename * Place prototypes for defcfun in header files * Support for unique init names for compiler::link and the like * libreadline5 for Debian * remove _o from init-names * gcc-4.0 fixups * Bug fix: "gcl: depends on binutils-dev <<= 2.1.5-999), so uninstallable in unstable", thanks to Steve Langasek (Closes: #318681). Rebuild with new release to autocompute this dep * Bug fix: "gcl: Please switch to po-debconf", thanks to Lucas Wall (Closes: #295930). Apply po-debconf patch * Newer standards -- Camm Maguire Thu, 11 Aug 2005 15:00:26 +0000 gcl (2.6.6-1) unstable; urgency=high * New upstream release * Allow .data section to be first in executable, as on solaris. Also allow for new bfd section size semantics * Don't try to write map file when not using GNU ld. Also allow compile-file to process pathnames with whitespace on Windows * Fix corner case fixnum arithmetic on 64bit machines * Rework gmp_wrappers semantics for older gcc * Explicitly mprotect loaded code pages PROT_EXEC on x86 Linux, as FC3 now requires it. * lisp-implementation-version is GCL * Reader extension patch allowing for foo::(bar foobar) semantics * a shell script variable fix in "unixport/makefile" for MSYS * __MINGW32__ malloc initialisation fix in "o/alloc.c" * Windows file/directory fixes in "o/unixfsys.c" * MinGW32 -march in configure - removes deprecation warnings * MinGW32 directory fix - "o/mingfile.c". * Allow for sysconf to determine clock granularity at compile time to fix time errors on the Itanium * Disable SGC on macosx until the sgc/save problem can be fixed. * Fix fixnum print bug on 64bit * Fix nil types in room report * 64bit fixes to fixnum_add and fixnum_sub * Fix Mac SGC/save bug, at least in part -- Camm Maguire Sun, 16 Jan 2005 02:28:50 +0000 gcl (2.6.5-1) unstable; urgency=high * New gmp_wrappers.{c,h} files that prevent all GBC within gmp, obviating the need for gmp patches and a local gmp configure. FIXME -- extend to all gmp functions in a systematic way, and write header information for future use in the compiler, making sure that plt.c carries the needed gmp symbols at this point * Build support for gmp_wrappers * Support for gmp_wrappers in alloc_relblock/alloc_contblock;Support for GCL_GPROF_START define in gprof functions * dynsysgmp on by default; configure backs off to local gmp configure and build automatically if needed either because gmp not present or patched symbols are needed; autodetect and set the _start symbol when using gprof * Fix (setf (get ...) ...) return bug when interpreted * Fix overwrite end of sgc_type_map bug * Versioned depends on binutils-dev manually installed by Debian build process * New upstream release * Proper binutils dependency for Debian * head -1l -> head -n 1 for freebsd * Cleanup gmp_wrapper code, check for in-place calls as write in one step is not guaranteed in gmp according to its developers * Rebuild against binutils 2.15, Closes: #266253, Closes: #263983 -- Camm Maguire Tue, 17 Aug 2004 18:22:27 +0000 gcl (2.6.4-1) unstable; urgency=high * New upstream release * Make disassemble work when original system directory is gone * New debian/support files for debconf image default selection support * More descriptive compiled C function names for use in gprof when profiling is compiled in * Compiler fix for proclaimed vararg functions * Allow sharp numbers to be bignums * lintian fix in string-match * Prototype for alloca for lint * Improve gprof support * Improve sgc page allocation which optimize-maximum-pages is in effect and the hole is overrun * Build a profiling set of images as well for Debian, toggle between all four by default via debconf * reset-sys-paths lisp function for moving image installation directories, show profiling support in banner if present * Fix typo in sys docs * reset sys paths on installation -- Camm Maguire Thu, 5 Aug 2004 22:48:56 +0000 gcl (2.6.3-1) unstable; urgency=high * Correctly parse gcc version strings in gmp3 subconfigure on arm * Fix variable capture error in dotimes macro * Better sed separator for LI-CC in unixport/makefile * Fix segfault in string-match * vs_top=sup -> (reset-top) where possible in compiler. FIXME: a few items of a different form which need to set *sup-used* too. * Correct room report to show proper percentages when sgc is on * Read in RELOC environment variable if set as default in debian/rules * Remove local bfd libraries from libs variables as their objects are incorporated into libgcl and as the source directory may not be available at runtime * Remove pcl/pcl_gazonk*lsp build-generated files from source -- Camm Maguire Thu, 15 Jul 2004 14:26:44 -0400 gcl (2.6.2-3) unstable; urgency=low * Fix value stack leak in rare compiled call sequence -- Camm Maguire Tue, 13 Jul 2004 10:17:02 -0400 gcl (2.6.2-2) unstable; urgency=low * New upstream point release -- Camm Maguire Tue, 13 Jul 2004 10:08:53 -0400 gcl (2.6.2-1) unstable; urgency=low * gcc-3.4 support * Proper isnormal default courtesy of Magnus Henoch * gclclean makefile target and other small makefile changes * Proper check for C stack array body address in gbc.c and sgbc.c * New upstream release * acconfig.h update for isnormal default * Fix bug in setting elements (si::aset) of 0 rank arrays uncovered by the random tester * No -fomit-frame-pointer on mingw * Backport minimal ansi-test patches from HEAD to enable running of the random tester * installed tcl/tk patch for mingw * Fix banner license detection code in lsp/gcl_mislib.lsp as 8features* entries are now keywords * o/makefile changes to work around trailing slash -I arguments gcc bug on mingw * Patch to mingwin.c:fix_filename to close long standing 'maxima ignore-errors filename corruption' bug on mingw * Check for too large rank supplied to make-array1 * Fix potential stack overwrite bug in quick_call_sfun/eval.c * Add -mprferred-stack-boundary=8 on amd64, as constant integers used in a call must be retrievable with va_arg(,fixnum) * Revert preferred-stack-boundary option on amd64 as it does not play well with external libraries, also eliminate -m64 to allow for user settings. Cast fixnum constant C arguments in gcl_cmploc.lsp explicitly to (long) to ensure they can be extracted via va_arg(,fixnum) * reenable SA_SIGINFO on amd64 to restore SGC there * Include elf.h in FreeBSD.h * Allow for elf_abi.h in FreeBSD.h * Add README.openbsd file * readme.mingw updates * solaris.h updates for custreloc option * Close possibility of malloc failure due to intervening gbc arising from the misordering of allocation calls * C_GC_OFFSET is 2 on m68k-linux * Add release notes, remove gcl document presumably based on dpANS for now * Fixup bad extern declaration of signals_handled in usig.c -- Camm Maguire Fri, 25 Jun 2004 22:43:52 +0000 gcl (2.6.1-39) unstable; urgency=high * Fix segfault in referencing (sgc_)type_map out of bounds which can occurr when C stack is below heap, as on alpha. * Cleanup compiler warnings on bcmp.c bzero.c and bcopy.c * Clean up compiler warning in file.d * Ensure set TLDFLAGS are used in finding DBEGIN in copnfigure.in, for OpenBSD -- Camm Maguire Fri, 7 May 2004 21:50:03 +0000 gcl (2.6.1-38) unstable; urgency=low * Make *features* entries keywords -- add canonical host cpu and kernel-system to *features*, disable h files specific ADDITIONAL_FEATURES macro in main.c * Fix merge-pathanames bug in concatenating default and supplied directory lists * Minor pathname and *features* fixes * Fix recently introduced configure.in syntax bug * Minor patches to support big gcl images -- all page integers must be long ints, need stack space limits that scale with MAXPAGES at least to allow free_map stack array in sgc_start. FIXME -- right now can handle situations where page numbers are ints, but npage*PAGESIZE is a long, need to handle npage >MAX_INT later. This is to support the 'billion cons element acl2 image' requested by a gcl user * Revert winnt features and debugging aids in configure.in * OpenBSD support, gcc warning cleanups for long page integers -- Camm Maguire Mon, 3 May 2004 21:34:57 +0000 gcl (2.6.1-37) unstable; urgency=high * mprotect pages PROT_EXEC as CLEAR_CACHE step on amd64-linux * Prevent recursive malloc calls for OpenBSD error reporting * Push dummy 0 time for child runtime on windows to be compatible with other platforms for now * Make sure pages are mprotected PROT_EXEC for amd64 support -- Camm Maguire Tue, 13 Apr 2004 21:00:22 +0000 gcl (2.6.1-36) unstable; urgency=low * Improve optimize-maximum-pages algorithm -- Camm Maguire Tue, 6 Apr 2004 03:23:40 +0000 gcl (2.6.1-35) unstable; urgency=low * Fix sigcontext autodetection on sparc -- Camm Maguire Sun, 4 Apr 2004 19:26:48 +0000 gcl (2.6.1-34) unstable; urgency=low * Fix GNU_LD autodetection in configure.in * Eliminate C_INCLUDE_PATH from shell script wrapper * Use lisp rather than 'system touch' to make empty map file in compiler::link * fix small bug when info is passed bad second argument * Don't try to open map file if doesn't stat (macosx) * Add earlier forgotten branch patch to sfaslbfd.c for macosx * Backport new eval-when keyword support from 2.7 to run random tester * Perhormance improvement to gcl_seqlib.lsp -- no inner loop over bignums * Proper contblock/relblock determination when expanding string streams * Proper string type determination for *link-array* * .ini files depend on plt.h * plttest.c cannot depend on include.h * Address longstanding FIXmE in gensym, so that two strings are not allocated for each gensym * Fix rare infinite loop bug in array.c * Import si::info into 'user * , -> # as sed separator * Minro warning removals and fixups * Binary searches through ordered arrays of referred and changed variables for dramatic compiler performance improvement in the large case -- support declarations and thereby optimizations of the form (declare ((vector t) foo)), etc. * Better 'time macro * rebuild pcl_gaz* files * cleanup room report and give more space to modern large heaps * room report formatting * Properly gensymmed time macro * Allow for white space chars in compiled filenames * Autodetect and work around sbrk randomization, e.g. on Fedora 1 * Probe for sbrk before probing for randomized sbrk * Openbsd changes -- maximize data seg resource if possible, avoid mallocing error message when allocation routines fails * Fix sigcontext configure tests * Rename loop-finish -> sloop-finish in sloop package so that sloop and ansi loop can be used simultaneously * Handle arguments which are zero in LCM * Fix typo in configure.in * Improved dotimes macro which avoids unnecessary fixnum garbage generation * Backport of ignorable declaration keyword for new dotimes macro * si::*OPTIMIZE-MAXIMUM-PAGES* support * rebuild pcl generated lisp files -- Camm Maguire Sat, 3 Apr 2004 19:27:18 +0000 gcl (2.6.1-33) unstable; urgency=low * Remove extraneous symbols from plt.h, autodetect and correct for leading underscore in object symbols * complete readline version detection commit * Backport support for new eval-when keywords * Autodetect GNU ld and add -Wl,-Map only when appropriate -- Camm Maguire Wed, 10 Mar 2004 22:51:44 +0000 gcl (2.6.1-32) unstable; urgency=low * Try to automatically determine the form used for the explicitly compiled in external function addresses in plt.c * No need to explicitly write cr-lf on windows * Autodetection of machine on FreeBSD * Updated defs and h files for FreeBSD courtesy of Mark Murray * Minor ifdefs needed for FreeBSD * Refer to exported non-static C stub of fSmake_vector1 in plt.c (needed on ia64) * Readline 4.1/4.3 configure magic -- Camm Maguire Tue, 9 Mar 2004 01:58:43 +0000 gcl (2.6.1-31) unstable; urgency=low * Adjustments to vs_top reset logic to clear (hopefully last) remaining bug found by the random-tester * Allow args-info-referred-vars to match replaced vars, clearing bug report submitted by Matt Kauffman * Rework plt code yet again to be compatible with compiler::link for axiom, and mingw32 -- Camm Maguire Mon, 8 Mar 2004 12:16:46 +0000 gcl (2.6.1-30) unstable; urgency=low * Fix rsym generated symbol tables for 64 bit platforms * Make sure 'unwind' in frame.c does nt go below frs_org * Do not define symbols with no value, either in bfd/rsym, or in plt.c. Generates a clear and explicit error of an undefined symbol when we've missed an address * Define the external symbols known to be written at present in plt.c * fix some more compiler errors found by the random tester -- all related to proper unwinding of temporary reductions of vs_top from te local supremum -- Camm Maguire Sat, 6 Mar 2004 02:05:59 +0000 gcl (2.6.1-29) unstable; urgency=low * Remove implicit dependency on gawk, optimize plt.c a little -- Camm Maguire Wed, 3 Mar 2004 16:08:30 +0000 gcl (2.6.1-28) unstable; urgency=low * make sure bfd fasload initializes dum.sm.sm_object1 for read_fasl_vector * When a tagbody contains ccb reference tags, and hence i itself marked ccb, mark all the clb tags therein ccb too, as the tagbody environment will be consed in c2tagbody-ccb. FIXME -- review this logic carefully * fix typoe in o/sfaslbfd.c * Add code to unwind redefinitions of the stack supremum in c2expr-top (used in c2multiple-value-prog1 and c2multiple-value-call in evaluating arguments) on non-local exit * Use new temporarry variables holding lisp stack supremum for lint * Eliminate extraneous warning message when allocating fewer pages than already allocated * Rework internal plt symbol address capture * Cleanup sfaslelf compiler warning -- Camm Maguire Wed, 3 Mar 2004 00:27:08 +0000 gcl (2.6.1-27) unstable; urgency=low * Modify default banner slightly * Homebrew plt-like mechanism for ensuring that valid internal addresses exist to which undefined symbols in compiled lisp objects referring to external shared libraries can be relocated * Make configure demand gettext when choosing --enable-locbfd * Make sure references to ldb1, a stub conventionally optimized away, can be resonled when optimization is turned off * completion_matches -> rl_completion_matches in gcl_readline.d, which is what is exported in the headers -- Camm Maguire Fri, 27 Feb 2004 23:50:49 +0000 gcl (2.6.1-26) unstable; urgency=low * Rework compiler::*ld-libs*, compiler::link, and unixport/makefile to accomodate mingw need for firstfile.o and lastfile.o * Remove incompatible -fomit-frame-pointer when compiling with -pg profiling * Load sys-proclaim.lisp files forimproved linking and smaller object size across the board, install same for use with compiler::link * Use pathnames instead of strings in compiler::link, also in image init files, for Windows * small mod to unixport/makefile re filtering of firstfile and lastfile * Backport zero divisor error cnditions from HEAD for floor,ceiling,truncate * Default to debug mode on hppa to work around gcc compiler optimization bugs * Add missing m4 and automake files in binutils directory to enable automake and autoconf here * Add mach-o specific files from cvs head to local bfd tree * Add bfd/po makefiles * Macosx defaults in configure.in * bfd make and configure file changes to handle mach-o backend * *gcl-version* -> *gcl-minor-version*,*gcl-extra-version* * Support for more informative banner reading features list * Support for both sigbus and sigsegv in sgbc.c as is customary in .h files * mach-o compatible changes in sfaslbfd.c * Support for new debugging section names in sfaslelf.c * powerpc-macosx h and defs files from cvs head -- Camm Maguire Wed, 25 Feb 2004 23:08:59 +0000 gcl (2.6.1-25) unstable; urgency=low * rl_putc_em a carriage return after invoking readline to ensure the prompt in rl_putc_em_line is cleared. * use standard sgc fault recovery element for hppa as recommended by hppa kernel experts * Store banner in si::*system-banner* for possible modification in compatibly licensed programs * exit with -1 when standard in ends in lisp debug mode * Backport macosx files from cvs HEAD * Document system return codes -- Camm Maguire Fri, 13 Feb 2004 20:44:54 +0000 gcl (2.6.1-24) unstable; urgency=low * Revert unixport/makefile link order fix for windows, breaks compiler::link, find another way * runtime SGC fault recovery test * Protect read/fread in case SGC is enabled with safe (restartable) versions * SGC on for arm and hppa * remove fast-link workaround now fixed for windows * Backport HEAD makefile changes to clean .{c,h,data} files and new_decl.h, remove said from repository (generated files) -- Camm Maguire Thu, 12 Feb 2004 05:56:29 +0000 gcl (2.6.1-23) unstable; urgency=low * Remove calls to init-readline with new automatic readline setup -- Camm Maguire Tue, 27 Jan 2004 20:27:20 +0000 gcl (2.6.1-22) unstable; urgency=low * Build depend on emacs21 | emacsen -- Camm Maguire Fri, 23 Jan 2004 22:01:15 +0000 gcl (2.6.1-21) unstable; urgency=low * Automatic readline initialization * Add watch file * Prevent circular error loops * Prevent automatic optimization added to CFLAGS by autoconf * Rework documentation installation in and outside of Debian * Support user deined predicates at an elementary level in the form '(satisfies foop) in gcl_predlib.lsp * Install binary gcd algorithm for ~10% performance increase * Rescale some default allocation parameters -- bignum allocation by relblocks by default, default growth parameters are 1 (min), 0.1*MAXPAGE (max), 0.5 (increase), 0.3 (percent free), holepage is 4*MAXPAGE/1024, INIT_HOLEPAGE, INIT_NRBPAGE and RB_GETA scale accordingly * Clean windows/sysdir.bat * Check for zero args in new gcd code * Default hole is maxpages/10, holesize configure option added * Fix syntax errors in older reloaction code: sfaslelf.c -- Camm Maguire Fri, 16 Jan 2004 16:57:50 +0000 gcl (2.6.1-20) unstable; urgency=low * Fix gcl-doc doc-base files -- Camm Maguire Tue, 30 Dec 2003 22:30:39 +0000 gcl (2.6.1-19) unstable; urgency=low * Fix bug in compiler::c2labels in which *ccb-vs* was missing a ocal rebind * Remove duplicate tags from compiled C switch statements * Minor merges for DARWIN support * Path to configure to make --enable-emacsdir work * Check for readline/readline.h header before configuring for readline * Improve system bfd library location detection * Make sure external gmp lib is compatible via __GNU_MP_VERSION, else backoff to local gmp build; prepend externally defined CFLAGS into output CFLAGS, FINAL_CFLAGS, and NIFLAGS * Remove --enable-gmp configure option; gmp is required for GCL * Use --enable-emacsdir in debian/rules, make sure --enable-emacsdir and --enable-infodir work when arg contains ${prefix} * Fix typo in chap-6.texi * Make sure to export SGC define from config.h to cmpinclude.h -- Now that we used optimized structures in the compiler, we need at least the definition of SGC_TOUCH there to prevent GBC errors. FIXME -- handle header dependencies more robustly. Thanks to Robert Boyer for the report * Improve SGC define extraction for cmpinclude.h * Fix variable reference errors which were occurring for compiled local functions defined within closure-generating or other environment stack pushing functions when safety is set to 3 (thanks Paul Dietz for the report.). When constructing local functions and closures within a 'mother' function, *ccb-vs* will hold the number of closure environments stacked at the point of each closure creation or call to a local function. This value is stored as the cadr of a list pushed onto *local-funs*, and is read when writing out the C code for the local function or closure, where it is used to initialize *ccb-vs* and *initial-ccb-vs* for subsequent processing. The latter is used as the reference point when addressing variables in wt-ccb-vs, as the former could be still further incremented within the closure or local function itself. Local functions as opposed to closures do not increment *ccb-vs* and do not push the environment. When a local function is defined within a closure-generating flet/labels, or a tagbody or block which pushes the environment, the value of *ccb-vs* written to the list corresponding to the local function can be erroneously incremented beyond the *initial-ccb-vs* value established before any environment pushing operations were processed. It is this latter value which is appropriate for use in wt-ccb-vs, as the local functions, unlike the closures, receive an environment level with the mother generating function. We therefore push *initial-ccb-vs* onto the end the list pushed onto *local-funs* only when defining a local function, and use it to initialize an added optional variable initialize-ccb-vs in t3local-fun and t3local-dcfun, which default to the original ccb-vs. We then bind *initial-ccb-vs* to this new optional parameter instead of the former *ccb-vs, which was only appropriate for closures. * Put in rudimentary logic for the selection of stack vs. heap storage for bignums depending on the frame context. FIXME, this logic is too conservative at present. SETQ_II and SETQ_IO take an additional parameter which is malloc when *unwind-exit* is bound and contains 'frame and alloca otherwise. New macro bignum-expansion-storage. FIXME, ensure that IDECL does not need similar modification. * Cleanup a few compiler warnings in the compiler * Cleanup compiler warning in alloc.c * Eliminate unneeded transformatio of contniguous pages to other pages on save-system. * malloc -> gcl_gmp_alloc in recent setjmp frame protected bignum allocation * Add -Wa,--execstack if on an exec-shield enabled system, can be explicitly added otherwise by setting the CFLAGS variable before the configure step * Better execstack flag handling in configure * Allow for commas in CFLAGS in sed command writing *cc* * Preliminary gprof profiling support * Rework html documentation generation and installation, Closes: #221774 * Remove parentheses from setf class-name info node in chap-7.texi -- Camm Maguire Tue, 30 Dec 2003 16:26:45 +0000 gcl (2.6.1-18) unstable; urgency=low * Portability patches to makefiles to support non-GNU grep (no -q), and non-bash sh, C_INCLUDE_PATH=...;export C_INCLUDE_PATH * copy the global *info* parameter in c1flet and c1labels to prevent accumulation of old data -- FIXME -- make sure there are no other copies required, and eventually replace this global parameter with local variables * Turn on some optimization on hppa, -O only * Make all C defined functions installed into lisp static functions to work around dynamic function descriptors on ia64, Closes: #217484, Closes: #204789, (STATIC_FUNCTION_POINTERS define in config.h) -- Camm Maguire Thu, 6 Nov 2003 15:40:25 +0000 gcl (2.6.1-17) unstable; urgency=low * Repair weak symbol addition to the bfd symbol table in sfasli.c * Be more thorough about adding fun-info to call-local info in gcl_cmpflet.lsp, accompanying simplifications in gcl_cmpeval.lsp (call-global lists have info updated by args already in (c1args args info)), small changes in add-info in gcl_cmpinline.lsp, FIXME -- study rational for *info* special variable in certain places as opposed to more common copy-info -- Camm Maguire Thu, 30 Oct 2003 20:03:22 -0500 gcl (2.6.1-16) unstable; urgency=low * Fix sh syntax in debian/gcl.sh * init_or_load1 -> gcl_init_or_load1 in xgcl-2/sysinit.lsp * Load weak symbols as well as undefined symbols in bfd_build_symbol_table, for the purposes of the static build possibility * Map t and nil stream indicators properly in optimized compiled references to read_char1 and read_byte1 (in read.d) -- Camm Maguire Thu, 23 Oct 2003 16:43:15 +0000 gcl (2.6.1-15) unstable; urgency=low * Remove imod/ifloor functions in cmpaux.c and directly inline their fixed equivalents in gcl_cmpopt.lsp -- Camm Maguire Mon, 13 Oct 2003 15:04:24 +0000 gcl (2.6.1-14) unstable; urgency=low * generate less garbage in add-info (gcl_cmpinline.lsp), enabling maxima compile to complete in a finite time :-) -- Camm Maguire Fri, 10 Oct 2003 22:14:04 +0000 gcl (2.6.1-13) unstable; urgency=low * Fix compiler optimization bug in gcl_cmpopt.lsp -- missing parens around inliner for max and min * collect info structures for local functions in flet and labels processing (gcl_cmpflet.lsp), and pass upwards to call-local and call-global (gcl_cmpeval.lsp) to fix certain inlining bugs in via more proper operation of args-info-changed-vars (gcl_cmpinline.lsp, inline-args, gcl_cmplet.lsp, c2let) * Fix an obviou int overflow in ifloor (o/cmpaux.c), handle more proper fixnum/integer determination from declarations later -- Camm Maguire Fri, 10 Oct 2003 02:34:11 +0000 gcl (2.6.1-12) unstable; urgency=low * Restore mpz_to_mpz{1} in gmp_big.c, can be written by compiler * tk8.4 patches * Prevent destructive modification of bignum arguments in log_op/mp_op in gmp_big.c * Make sure to push stack variables onto newly allocated C variable when inlining args and args cause side effects, in inline-args, gcl_cmpinline.lsp * Fix bug related to gcc-3.3 fixes in set_exponent in num_co.c * Remove pcl_methods.c patch. as is apparently no longer needed, TODO -- make sure VOL modifier is inserted where needed to prevent longjmp clobbers -- Camm Maguire Thu, 2 Oct 2003 14:26:43 +0000 gcl (2.6.1-11) unstable; urgency=low * Add compilation step of compiling all lsp and cmpnew .lsp files from an interpreted only saved_pre_gcl before the creation of saved_gcl - - this enables us to use full optimization on these files while getting the STREF constants right on 32bit and 64bit * remove 'attic' from comment in gcl_loop.lsp * configure changes for sizeof(struct contblock) detection -- Camm Maguire Wed, 24 Sep 2003 16:09:44 +0000 gcl (2.6.1-10) unstable; urgency=low * Mac OSX GET_FULL_PATH_SELF * Preliminary subtypep checking for 'satisfies * preliminary 'satisfies support in subtypep, more predicate type pairs and reverse checking * small compiler change to remove unused C variables from optimized compiled macros * Optional compiler init file is called gcl_cmpinit * fasdmacros.lsp -> gcl_fasdmacros.lsp * All cmpinit.lsp files named gcl_cmpinit.lsp; allow full lisp optimization in all directories * collectfn -> gcl_collectfn in lsp/gcl_auto.lsp * collectfn -> gcl_collectfn in cmpnew/gcl_make-fn.lsp * Make sure makefiles can generate sys-proclaim.lsp, regenerate these files and recompile from lsp * Rebuild with opts enabled * Iterate sys-proclaim/rebuild generation once more * Iterate sys-proclaim/rebuild for pcl and clcs -- Camm Maguire Tue, 23 Sep 2003 19:33:27 +0000 gcl (2.6.1-9) unstable; urgency=low * Close streams in fasldlsym.c -- Camm Maguire Tue, 16 Sep 2003 14:57:20 +0000 gcl (2.6.1-8) unstable; urgency=low * Add processor flag variable to flags in configure.in * Autoadd full path to kcl_self to enable save-system when user moves executable and calls without script wrapper * Add special variables si::*collect-binary-modules* and si::*binary- modules* as a facility for discovering the list of fasloaded objects preceding a save-system is required for a subsequent compiler::link * Add collectfn.lsp to distro * Rename some files and init_ functions to eliminate namespace conflicts when building images with compiler::link * Enable compressed info reading * Make sure no opt flags are set when enable debug is specified * Use NIFlAGS to compile new_init with lower opts on ppc to work around gcc bug, restore full opts to other files -- Camm Maguire Sun, 14 Sep 2003 02:18:28 +0000 gcl (2.6.1-7) unstable; urgency=low * Fix permissions bug in temporary gzipped file handling * Propagate control changes correctly with package extension * Newer standards -- Camm Maguire Tue, 9 Sep 2003 17:06:56 +0000 gcl (2.6.1-6) unstable; urgency=low * Remove build-dependency on autoconf as a temporary work around to Debian autoconf's dependency bug on emacsen-common -- Camm Maguire Tue, 9 Sep 2003 15:29:06 +0000 gcl (2.6.1-5) unstable; urgency=low * Redefine temporary files in elisp/makefile -- Camm Maguire Mon, 8 Sep 2003 21:49:09 +0000 gcl (2.6.1-4) unstable; urgency=low * Fix to sfasli.c to avoid defining symbols in other than *UND* sections * Remove some 64 bit warnings * Turn off def_static on ia64 for now -- its broken -- Camm Maguire Sat, 6 Sep 2003 17:22:10 +0000 gcl (2.6.1-3) unstable; urgency=low * Fix static detection fr ia64; contblock size detection on arm * Fix gcc verion checking in gmp3 subconfigure, esp. for arm * Escape all sgc code with #ifdef SGC -- Camm Maguire Fri, 5 Sep 2003 21:32:47 +0000 gcl (2.6.1-2) unstable; urgency=low * Add windows/install.lsp to clean target * Add in macosx files to stable and cvs head * Fix bad debelper postinst, Closes: #208765 -- Camm Maguire Fri, 5 Sep 2003 13:15:11 +0000 gcl (2.6.1-1) unstable; urgency=low * New upstream release * Type-punning warning fixes * small_fixnum overflow fixes * off by one fix in cerror * Fix compiler error which had not recognized defpackage as a package operation * Fix tkl.lisp call to open-named-socket * Make values-list and nreconc signal errors when they should on dotted lists. * Avoid use of windows.h types as macros. * New config.{sub,guess} * Windows installer updates from CVS HEAD * fix potential longjmp clobber in read.d;add some windows files to main makefile clean target; * Darwin revealed fixes to usig.c and unixtime.c * Fix gbc time calculation in case of recursive gbc calls * Run patch_sharp in LSharp_exclamation_reader to handle new case of defpackage ops at head of fasl vector, required for maxima build * Special symbol Dotnil has ordinary list Cnil for plist and hpack * Small fixes for profiling support * Restore pp() function for debugging; print out undefined symbol names * Small patch for fix xgcl demo (thanks Michael Koehne) * Better bfd symbol table strategy * Fix bfd table symbol counting for combined_table profiling * amd64 linux support * O6 -> O3 * static linking on ia64 to work around current mechanism for runtime generated function descriptors * enable-static configure option * Fix debian/gcl-doc.docs for latest texinfo file splitting policy, Closes: #206017 * Fix typo in o/sfasli.c * Rework debian package structure to handle stable and cvs packages simultaneously * Add gazonk*.lsp to clean target * syntax fix to lsp/gprof.hc * Add support for SGC contblock pages * Fixes to debian/rules * Remove unused definitions of Vcs * Increase default maxpages and stack sizes * Maintain a persisten *system-directory* binding * Push installed /h directory onto -I flags on cc command line * Escape old in-package behavior with #ifdef ANSI_COMMON_LISP * define HAVE_XDR in linux.h * reduce resolution of contblock mark_table in gbc.c to match new minimum granularity introduced via CPTR_ALIGN * Remove exit function in main.c -- Camm Maguire Thu, 4 Sep 2003 02:20:52 +0000 gcl (2.5.3-2) unstable; urgency=low * gcc-3.3 all platforms -- Camm Maguire Mon, 7 Jul 2003 16:10:25 +0000 gcl (2.5.3-1) unstable; urgency=low * New upstream release * Restore object_to_float and object_to_double, cmpaux.c, Closes: #195470. * Remove obsolete functiion multiply-bignum-stack from documentation, si-defs.texi * Unstatic object_to_float, object_to_double -- Camm Maguire Mon, 2 Jun 2003 12:38:03 -0400 gcl (2.5.2-1) unstable; urgency=low * New upstream release * Cleanup xdrfuns.c for Axiom * Reenable xgcl build -- Camm Maguire Thu, 20 Mar 2003 09:15:54 -0500 gcl (2.5.1-1) unstable; urgency=high * some optimization now on hppa * Add RELEASE-2.5.1 file * Add dedication notice to the memory of W. Schelter -- Camm Maguire Sun, 2 Mar 2003 10:20:26 -0500 gcl (2.5.0.cvs20020625-80) unstable; urgency=low * enable japi configure flag, defaults to no * enable -mlongcall on ppc when using gcc 3.3 or higher * int -> fixnum in DEFUN function arguments for safety -- ensures pointers and integers passed by lisp are of same size * MYmake_fixnum macro simplification * ufixnum typedef * Prototypes for cmod et.al. -- restoring maxima build on ia64 * Fix unaligned access message on ia64 generated by DFLT_aet_fix * Integer va_arg uses fixnum * Define __*i3 symbols used by GCL, supplied by libc, and written into some GCL compiled objects, restores ARM build with ANSI image * num_log.c miscompilation on ia64 apparently fixed, Closes: #156291 * Ensure cmpinclude.h up to date in main makefile -- Camm Maguire Sat, 1 Mar 2003 17:33:29 -0500 gcl (2.5.0.cvs20020625-79) unstable; urgency=low * Fix Debian package install bug -- Camm Maguire Thu, 27 Feb 2003 23:17:55 -0500 gcl (2.5.0.cvs20020625-78) unstable; urgency=low * Add config.log config.status and config.cache to clean target * Remove xgcl-2/debian directory * Update clcs/sys-proclaim.lisp -- Camm Maguire Thu, 27 Feb 2003 18:48:38 -0500 gcl (2.5.0.cvs20020625-77) unstable; urgency=low * Lintian cleanups * Don't strip libansi_gcl.a, need .data at end of .o, as with libgcl.a * Take newlines out of doc string for init-cmp-anon * Cleanup gcc-3.2 compiler warning * 64 bit STREF fixes * pcl and clcs need to have C rebuilt afresh, as 64 bit machines write different STREF offsets into the C files * Rework Debian package build a bit * README.Debian explaining the toggling of the ANSI image * Typo in debian/rules * Remove debian/gcl.conffiles -- Camm Maguire Thu, 27 Feb 2003 15:56:11 -0500 gcl (2.5.0.cvs20020625-76) unstable; urgency=low * Debian Priority is optional * Configure lowest common denominator on m68k to m68020 -- gcc-3.2 can't handle m68000 -- no __mulsi3 * Fix bit array bug * Add upgraded-array-element-type * Misc typep and subtypep fixes * Proper error handling in certain array.c functions * First needs exactly one arg * Proper error handlin in LAST * bit array allocation fixes in num_log.c * eliminate Iapply_fun_n1 * Dummy system find-class in traditional image, overwritten by pcl version in ANSI * Invalid variable is a program error, not a symbol is a type error * Attempt at uninterned symbol support as slot names * defstruct changes for ANSI conc-name handling * Rework ansi build to follow existing pattern for traditional image, enabling preliminary ansi support on dlopen systems * Fix broken mingw probe in main makefile * Rename pcl and clcs files to avoid init name conflict on dlopen systems * sys-proclaim for clcs * Compiler goto indentation * Compiler pointer cast in call_or_link_closure * *keep-gaz* compiler variable to save anonymously generated lisp * si::init-cmp-anon function to initialize anonymously generated and compiled lisp from .text section of running executable * Debian/rules builds and ships both images * Check for small fixnum in make_fixnum macro * Pass real integers to array functions to minimize fixnum garbage * Larger SHARP_EQ_CONTEXT_SIZE in read.d * Shadowing-import instead of import dummy symbols into common-lisp in ansi_cl.lisp * Rework object definition in makefiles * Remove old gmp directory * Remove old tests directory * Reinsert JAPI configuration * Spruce up clean target * Use saved_gcl to recompile cmpnew files * Toggle ansi image with GCL_ANSI environment variable * Version 2.5.1 -- Camm Maguire Wed, 26 Feb 2003 21:31:04 -0500 gcl (2.5.0.cvs20020625-75) unstable; urgency=low * Export truename for dlopen systems -- Camm Maguire Fri, 14 Feb 2003 23:31:15 -0500 gcl (2.5.0.cvs20020625-74) unstable; urgency=low * Remove duplicates in apropos a la clisp * Use static where possible, remove unused functions, decrease global symbol count by about 1/3 (~ 600 global functions) * Inline optimize cmod,cplus,ctimes and cdifference like maxima * eliminate make-pure-array from lfun_list.lsp, not defined * Prototypes for all possible compiler generated function calls * relative symlink for cmpinclude.h in Debian package -- Camm Maguire Fri, 14 Feb 2003 20:17:31 -0500 gcl (2.5.0.cvs20020625-73) unstable; urgency=low * typep fixes for class types * m68k Build-depend on gcc-2.95 as a temporary work around to bug 179807 * gcc-3.2 warning cleanups * bfd_boolean syntax support for newer binutils * gcc-3.2 on powerpc can't yet handle -O2 and higher * Reenable gcc-3.2 for m68k and do some guesswork in configure -- Camm Maguire Mon, 10 Feb 2003 13:47:00 -0500 gcl (2.5.0.cvs20020625-72) unstable; urgency=high * Fix to siLbit_array_op for 0 dimension arrays * Fixed aref of short-float vector * nconc can take dotted lists * tailp returns t if first arg is nil * Repair nconc and tailp fixes * varargs->stdarg for gcc 3.3 and higher -- Camm Maguire Sun, 9 Feb 2003 16:57:33 -0500 gcl (2.5.0.cvs20020625-71) unstable; urgency=high * ansi changes to sloop.lsp and conditions.lisp to fix symbol tests * :definition-before-pcl -> definition-before-pcl * Allow spaces in pathnames * Significant fixes to gmp_num_log.c affecting bitwise ops on bignums * Fix test segfault arising from faulty structure-type-included-type- name in gcl-low.lisp ; Thanks Peter * aref1 -> row-major-aref * Fixes to certain numerical functions to handle denormalized floating point numbers * Number of argument check in IapplyVector * Print offset bit vectors correctly * Correct precision for formatting short and long doubles * Added si::modf * Do not trigger error in IapplyVector if max args is zero * Fixes to with-package-iterator to cleanup compiler warnings * :invalid-variable is a type error * No max arg checking if &key or &rest present * proper defun declarations in listlib.lsp * class specifiers in typep, subtypep and coerce * Corrections to allow-other-key processing in bind.c * eval sfuns with argument error checking (in one place) * copy-structure takes only one arg * si::classp, si::class-of, and si::class-precedence-list overwritten by pcl analogs when compiling ansi * recompiled core lsp and compiler files * restore dvi and html doc build for non-mingw -- Camm Maguire Fri, 24 Jan 2003 13:55:11 -0500 gcl (2.5.0.cvs20020625-70) unstable; urgency=high * loop fixes * configure fixes * :common-lisp in *features* * :definition-before-clcs -> definition-before-clcs * protect against sgc segfault within fread in fasdump.c -- fixes m68k acl2 build * SGC for s390 -- Camm Maguire Thu, 5 Dec 2002 08:02:17 -0500 gcl (2.5.0.cvs20020625-69) unstable; urgency=high * eval fix * \-mlong-calls for arm -- Camm Maguire Mon, 25 Nov 2002 08:35:27 -0500 gcl (2.5.0.cvs20020625-68) unstable; urgency=high * enable emacsdir configure option * reordered configure X lib detection for solaris * redo integer declarations for gmp bignums to avoid compiler warnings * Clear large and negative count errors for remove/delete * Loop error fixes * cache flush with page granularity on m68k -- Camm Maguire Thu, 21 Nov 2002 17:44:30 -0500 gcl (2.5.0.cvs20020625-67) unstable; urgency=high * Align cache flushes for powerpc and m68k on 32 byte boundaries, should fix acl2 build * Removed diagnostic SIGILL trapping in cmpaux.c -- Camm Maguire Tue, 12 Nov 2002 23:25:49 -0500 gcl (2.5.0.cvs20020625-66) unstable; urgency=high * Fix SIGILL trap in cmpaux.c -- Camm Maguire Mon, 11 Nov 2002 11:14:07 -0500 gcl (2.5.0.cvs20020625-65) unstable; urgency=high * Miscellaneous Freebsd patches * non-recursive with-package-iterator * map-into fill-pointer fixes * changes to the user-init mechanism for portable acl2 build -- Camm Maguire Sun, 10 Nov 2002 12:33:59 -0500 gcl (2.5.0.cvs20020625-64) unstable; urgency=low * Fix epsilon calculations again to reenable arm build -- Camm Maguire Fri, 1 Nov 2002 07:08:33 -0500 gcl (2.5.0.cvs20020625-63) unstable; urgency=low * Add versioned dependency on the gcc used to build gcl -- Camm Maguire Tue, 29 Oct 2002 16:20:22 -0500 gcl (2.5.0.cvs20020625-62) unstable; urgency=low * with-package-iterator modifications * with-package-iterator uses labels to correctly provide for recursion * Fix doc directory problem with install target in info/makefile * Fix info dir setting in configure * Priority extra -- Camm Maguire Mon, 28 Oct 2002 23:45:07 -0500 gcl (2.5.0.cvs20020625-61) unstable; urgency=low * Placeholder support for optional condition in find-restart * defpackage error on importing non-existent symbols * working with-package-iterator macro * various package errors reported as :package-error * Destructuring-bind fixes * delete-package error fix * pcl functions use pcl-destructuring-bind for now -- fix later * Trigger error if function calls use too many 'values' * Maximum values increased to 50 * Enable previously failing tests in multiple-value-{setq,prog1}.lsp * prototype for system_time_zone_helper * Initial changes for solaris support * make -> $(MAKE) in makefiles * Incorporated main GCL (ANSI) Lisp Documentation in distribution -- Camm Maguire Mon, 28 Oct 2002 04:31:33 -0500 gcl (2.5.0.cvs20020625-60) unstable; urgency=low * Still better acosh, courtesy of Barton Willis * Better epsilon contant determination in ieee case * Implicit tagbody in do-symbols and do-all-symbols * Better epsilon handling in ieee case * Add setf (values ... support * invalid-function errors are type errors * ecase and ccase take t and otherwise clauses * ECASE/CCASE test fixes * setf values fixes to use setf instead of setq when target value is not a symbol * ETYPECASE/CTYPECASE can take t and otherwise * Backout of restart-clusters export * fix handler.lisp * Fix to bfd/GBC interaction -- Camm Maguire Wed, 23 Oct 2002 08:38:08 -0400 gcl (2.5.0.cvs20020625-59) unstable; urgency=low * wrong number of arguments, keyword errors in lambda list bindings, are program errors * acosh fix at -1.0 * New config.sub and config.guess files and automatic updates in binutils, gmp, and gmp3 subdirs -- Camm Maguire Wed, 16 Oct 2002 11:38:56 -0400 gcl (2.5.0.cvs20020625-58) unstable; urgency=low * GENSYM fixes * add complement and constantly * import certain symbols into common-lisp package * Fix makefile bug in install target * Prepend instead of overwrite C_INCLUDE_PATH in shell wrapper * More shell variable fixes in main makefile * Corrected order of push and pushnew * Set bfd_error appropriately * Report function for package-error in condition-definitions.lisp;fix internal-package-error deinition and handling;export *restart- clusters* to user error code specified in handler-case;package-error error formatting changes;dummy optional argument added to compute- restarts (for now);Paul Dietz patch to defpackage.lsp fixing several tests (thanks);export/unexport error handling fixes * Recompile c,h and data files * Fix number of argument errors in debug.lsp;documentation support for packages in defpackage.lsp and module.lsp;do-symbols loops over inherited symbols too in packlib.lsp * Reworked EXTRAS variable handling in unixport/makefile * Build-depend on autotools-dev and automatic update of config.sub and config.guess;newer config.sub and config.guess in cvs tree; Closes: #164526 * Remove stray comments in package.d * elt errors of type type error * bad-sequence limit returns type error -- Camm Maguire Tue, 15 Oct 2002 15:39:19 -0400 gcl (2.5.0.cvs20020625-57) unstable; urgency=low * Capitalization changes to names of special characters;graphic-char-p fix * fix shadowing of existing symbols in package.d * (simple-)base-string not a subtype of (simple-)vector * add package-error condition(preliminary);hash conditions only by the error name, not the format string;pass error types for both correctable and non-correctable situations;eliminate duplicate loading of clcs/package.lisp;Allow t doc-types in documentation (returning nil) for now;fix final type errors in predlib.lsp (regarding base-string);other error functions to pass continuable errors (needs cleaning up);package designators can be characters;delete-package added;make-package doesn't :use lisp by default;in-package returns error if package does not exist instead of making the package(relatively big change -- need to address instances of in-package in .lsp code);call make-package on relevant packages in init_gcl.lsp.in and pcl/sys-package.lisp; * \-ffunction-sections for hppa with no-optimization -- enables first maxima build here * separate lisp variables to specify optimization flags for level 2 and 3 * symbol-name throws a type error on bad input * tk8.2 -> tk8.3 * Fix bug in main makefile * Newlines at end of test files -- Camm Maguire Wed, 9 Oct 2002 15:04:41 -0400 gcl (2.5.0.cvs20020625-56) unstable; urgency=high * ansi-test corrections; extra-libs option to LINK function; LINK doc change; subtypep and string changes to pass more tests * Add method-combination and structure-object symbols for ansi;remove unused variables in debug.lsp;remove in-package system from defstruct.lsp;make-keyword and defmacro temporary function placeholders in destructuring_bind.lsp;predlib changes to fix ansi- test type errors;break-call takes 2 args (sys-proclaim.lisp);char and char-set protected by string dimension not fillpointer in string.d;fix bug in string.d:member_char for vector types;redefine slot reader and writer functions in pcl/impl/gcl/gcl-low.lisp -- Camm Maguire Sat, 5 Oct 2002 14:33:46 -0400 gcl (2.5.0.cvs20020625-55) unstable; urgency=high * Add LINK documentation to info pages * 0 length last support * make-sequence error check for 'null type and non-zero size * Dotted-list support in member * Reworked dotnil definitions and support macros * add compile-file-pathname * setup C_INCLUDE_PATH env variable in gcl shell wrapper * POSITIVE-FIXNUM variable type,simple-error->type error where indicated by various ansi tests, eq->eql in ldiff and tailp;proper lists only in member et. al. * rev keyword for member1 to reverse test arguments * specific-error function to pass a given type of error from lisp * set-exclusive-or preserves order of test arguments * type-errors where appropriate in make-sequence * nil keys accepted in remove/delete et.al. * Reworked linking command line to ensure that certain symbols are resolved in libgcl.a as opposed to certain system libraries, e.g. gmp * new gmp for m68k;no -ffloat-store for m68k a requested by user due to performance impact (will alter test results in maxima accordingly) * libgclp.a for objects to be overriden by the C library if necessary * readably support * boolean type * Missing ansi type support * subtype code for boolean * add missing ansi types as known types * other preliminary subtype code for missing ansi types * rework result-type check in make-sequence * :element-type support in make-string (preliminary) * (char ignores fill-pointer * remove -O4 from debian/rules -- Camm Maguire Thu, 3 Oct 2002 01:52:45 -0400 gcl (2.5.0.cvs20020625-54) unstable; urgency=high * Fix delete et. al. :from-end error; typo in gbc.c * character and string-char equal in type hierarchy * concatenate/make-sequence fixes * merge takes nil key argument * make-sequence checks size against result type * install endp macro for dotted list support -- Camm Maguire Tue, 24 Sep 2002 14:57:44 -0400 gcl (2.5.0.cvs20020625-53) unstable; urgency=high * Sleep with (in principle) microsecond precision * nth-value macro added * \-ffloat\-store and warning cleanups for m68k * Compile hppa with debugging, will get a build but a broken one, ok for now, Closes: #159591 -- Camm Maguire Fri, 20 Sep 2002 09:48:35 -0400 gcl (2.5.0.cvs20020625-52) unstable; urgency=high * Fixed gcc version bug in debian/rules -- Camm Maguire Thu, 12 Sep 2002 18:00:50 -0400 gcl (2.5.0.cvs20020625-51) unstable; urgency=high * static gmp for m68k -- Camm Maguire Thu, 12 Sep 2002 09:33:03 -0400 gcl (2.5.0.cvs20020625-50) unstable; urgency=high * Reworked static gmp target for new libgcl.a;gcc-3.2 for hppa,ia64,and arm;libgmp2-dev for m68k;no rsym with dynsysbfd;build_symbol_table earlier to shrink table size; -- Camm Maguire Thu, 12 Sep 2002 00:39:17 -0400 gcl (2.5.0.cvs20020625-49) unstable; urgency=high * Use old gmp for m68k until can pin down test failure with gmp3 -- Camm Maguire Tue, 10 Sep 2002 00:36:10 -0400 gcl (2.5.0.cvs20020625-48) unstable; urgency=high * Rework build and install so that custom images can be made without the source tree, even when using dlopen -- Camm Maguire Mon, 9 Sep 2002 23:26:47 -0400 gcl (2.5.0.cvs20020625-47) unstable; urgency=high * Install cmpinclude.h in system include directory -- Camm Maguire Thu, 29 Aug 2002 23:31:55 -0400 gcl (2.5.0.cvs20020625-46) unstable; urgency=high * Keep a *much* smaller piece of gmp.h in cmpinclude.h, reducing image size by almost 100k * Check for _SHORT_LIMB and _LONG_LONG_LIMB in configure * Remove build specific include directories from compile command in final executable * Include local regexp.h explicitly in cmpinclude.h, to eliminate intereference with system regexp.h, and to fix bug in which gcl compilation depended on existing build directories * Correctly add directory paths to extra gmp file targets in unixport/makefile for m68k -- Camm Maguire Thu, 29 Aug 2002 21:56:28 -0400 gcl (2.5.0.cvs20020625-45) unstable; urgency=high * Fix typo in rshift target for m68k -- Camm Maguire Wed, 28 Aug 2002 18:02:00 -0400 gcl (2.5.0.cvs20020625-44) unstable; urgency=high * Handle second argument to last; treat dotted lists correctly in ldiff et. al., tailp fix * optional key argument for assoc-if et.al.;eval getf deflt if in setf * Fix infinite loop in assoc-if et.al. * X_LIBS and X_CFLAGS determination in configure script -- Camm Maguire Wed, 21 Aug 2002 18:22:37 -0400 gcl (2.5.0.cvs20020625-43) unstable; urgency=high * Larger ihs stack;fix array-total-size-limit;check negative fillp;allow #P * don't make common_lisp package when not configuring with --enable- ansi * Patch gmp3/mpn/m68k/{l,r}shift.asm, restore gmp3 to m68k build * Dynamic libgmp support, overriding with patched functions from local source where necessary -- Camm Maguire Sun, 18 Aug 2002 12:10:55 -0400 gcl (2.5.0.cvs20020625-42) unstable; urgency=high * copy ansidecl.h and symcat.h in h/ for local bfd builds * localize bfd.h includes to sfaslbfd.c * take bfd/po out of the build loop * import xgcl-2, but don't build by default * oldgmp configure option, and made default for m68k as temporary workaround -- Camm Maguire Mon, 12 Aug 2002 23:49:09 -0400 gcl (2.5.0.cvs20020625-41) unstable; urgency=high * Minor rules revision for i164 -- Camm Maguire Sun, 11 Aug 2002 13:49:03 -0400 gcl (2.5.0.cvs20020625-40) unstable; urgency=high * revamp CONST configure test for certain bfd versions -- Camm Maguire Sun, 11 Aug 2002 12:31:35 -0400 gcl (2.5.0.cvs20020625-39) unstable; urgency=high * gcc-3.1 for ia64 fixes a compilation bug in num_co.c for -O3 and higher -- code takes address of a variable kept in a register * compile num_log.c with -O only on ia64 to work around compiler bug -- Camm Maguire Sun, 11 Aug 2002 08:53:03 -0400 gcl (2.5.0.cvs20020625-38) unstable; urgency=high * check for long c statck addresses, fixing NULL_OR_ON_C_STACK macro for ia64 * Remove error in clean target -- Camm Maguire Sat, 10 Aug 2002 13:20:08 -0400 gcl (2.5.0.cvs20020625-37) unstable; urgency=high * Replace tmpnam and mktemp with less dangerous mkstemp -- Camm Maguire Fri, 9 Aug 2002 19:45:52 -0400 gcl (2.5.0.cvs20020625-36) unstable; urgency=high * Fix rsym compilation when not using bfd -- Camm Maguire Fri, 9 Aug 2002 19:10:16 -0400 gcl (2.5.0.cvs20020625-35) unstable; urgency=high * Don't build bfd/po subdir * Build-depend on automake and gettext -- Camm Maguire Fri, 9 Aug 2002 14:36:58 -0400 gcl (2.5.0.cvs20020625-34) unstable; urgency=high * fix zero length array support * reverse configure order for bfd and libiberty -- Camm Maguire Fri, 9 Aug 2002 11:52:38 -0400 gcl (2.5.0.cvs20020625-33) unstable; urgency=high * chmod +x for subconfigures * dlopen for appropriate arches in debian/rules * add custreloc configure option -- Camm Maguire Fri, 9 Aug 2002 10:16:55 -0400 gcl (2.5.0.cvs20020625-32) unstable; urgency=high * Local bfd build option to prepare for arch-specific patches * Try default gmp3 build on m68k * Fix merge-pathnames -- Camm Maguire Fri, 9 Aug 2002 00:13:16 -0400 gcl (2.5.0.cvs20020625-31) unstable; urgency=high * #undef bool in object.h for some gcc-3.1 installations * New number_tan implementation using real tan, so optimized compiled code will find symbol in -lm -- Camm Maguire Tue, 6 Aug 2002 18:37:52 -0400 gcl (2.5.0.cvs20020625-30) unstable; urgency=high * fix bug in cmpif.lsp and recompile compiler * \-O6 \-fomit\-frame\-pointer for Linux, speed gain of ~ 10% * clean saved_gcl_pcl -- Camm Maguire Mon, 5 Aug 2002 16:34:33 -0400 gcl (2.5.0.cvs20020625-29) unstable; urgency=high * Back out of hppa assembler register flush for hppa, apparently issue is cleared by long/object function declaration fix * Remove ansi2knr.1 man page, Closes: #155067 * hppa still has gc leak, possibly due to faulty setjmp. Try Lamont Jones' latest assembler to flush regs -- Camm Maguire Fri, 2 Aug 2002 20:50:21 -0400 gcl (2.5.0.cvs20020625-28) unstable; urgency=high * SGC support for alpha * generic gmp3 build for m68k * compiler changes to declare all functions as returning object, with functions that actually return long being cast appropriately * back out of m68k hack in eval.c and funlink.c -- Camm Maguire Fri, 2 Aug 2002 18:22:04 -0400 gcl (2.5.0.cvs20020625-27) unstable; urgency=high * Use generic lshift.c in gmp3 for m68k * use SGC for ia64 * m68k workaround, cast (object(*)()) to (long(*)()) in funlink.c and eval.c * GBC register spiil asm for hppa * fix hash_equal declaration error in hash.d -- Camm Maguire Thu, 1 Aug 2002 18:12:49 -0400 gcl (2.5.0.cvs20020625-26) unstable; urgency=high * Remove extra load of tkl.o in install target of main makefile * gcc-3.1 for hppa * Remove gcc version spec for m68k * \-fPIC for hppa, needed for dlopen * cleanup gcc 3.1 warning in funlink.c * cc instead of ld for -shared linking in fasldlsym.c (needed for hppa) -- Camm Maguire Wed, 31 Jul 2002 18:46:54 -0400 gcl (2.5.0.cvs20020625-25) unstable; urgency=high * Move chmod +x gmp3/* into debian/rules * Remove gclm.bat from Debian package * Build-Depend on autoconf, Closes: #154909 -- Camm Maguire Wed, 31 Jul 2002 09:44:20 -0400 gcl (2.5.0.cvs20020625-24) unstable; urgency=high * chmod +x gmp3/configure -- Camm Maguire Wed, 31 Jul 2002 07:55:17 -0400 gcl (2.5.0.cvs20020625-23) unstable; urgency=high * 64bit SGC support * SGC on by default for sparc-linux and mips(el)-linux * Optimized logxor funtion * Check for MP_LIMB_SIZE in fasdump.c, for 64bit support * gbc fix for ia64 * gmp3 import for ia64 * system bzero, bcmp, and bcopy function prototypes -- Camm Maguire Tue, 30 Jul 2002 23:11:58 -0400 gcl (2.5.0.cvs20020625-22) unstable; urgency=high * ElfW macros in rsym*.c for 64bit * Allow for 8 byte gmp mp_limbs -- Camm Maguire Thu, 25 Jul 2002 18:52:37 -0400 gcl (2.5.0.cvs20020625-21) unstable; urgency=high * Support for dlopen object loading where bfd is not yet working -- ./configure --enable-dlopen -- Camm Maguire Thu, 25 Jul 2002 15:08:05 -0400 gcl (2.5.0.cvs20020625-20) unstable; urgency=high * Cleanups for --disable-bfd option -- Camm Maguire Wed, 24 Jul 2002 15:05:28 -0400 gcl (2.5.0.cvs20020625-19) unstable; urgency=high * 64bit fixes -- Camm Maguire Wed, 24 Jul 2002 12:16:42 -0400 gcl (2.5.0.cvs20020625-18) unstable; urgency=high * misc. lintian cleanups, mostly for 64 bit -- Camm Maguire Tue, 23 Jul 2002 23:35:03 -0400 gcl (2.5.0.cvs20020625-17) unstable; urgency=high * Fixed typeo in error.c preventing arm compilation -- Camm Maguire Mon, 22 Jul 2002 17:18:18 -0400 gcl (2.5.0.cvs20020625-16) unstable; urgency=high * Fix bad on_stack_list_vector args -- Camm Maguire Mon, 22 Jul 2002 16:10:16 -0400 gcl (2.5.0.cvs20020625-15) unstable; urgency=high * More lint changes for sundry arches * Fixed bug in Iapply_ap -- Camm Maguire Sat, 20 Jul 2002 23:40:33 -0400 gcl (2.5.0.cvs20020625-14) unstable; urgency=high * include stdarg.h when defining _GNU_SOURCE -- Camm Maguire Sat, 20 Jul 2002 18:47:43 -0400 gcl (2.5.0.cvs20020625-13) unstable; urgency=high * Proper va_dcl declarations -- Camm Maguire Sat, 20 Jul 2002 10:40:02 -0400 gcl (2.5.0.cvs20020625-12) unstable; urgency=high * cvs updates for missing ptrdiff_t -- Camm Maguire Sat, 20 Jul 2002 08:41:37 -0400 gcl (2.5.0.cvs20020625-11) unstable; urgency=high * cvs changes to compile cleanly with -Wall -- Camm Maguire Sat, 20 Jul 2002 02:59:33 -0400 gcl (2.5.0.cvs20020625-10) unstable; urgency=high * Architecture any, though still have some issues -- Camm Maguire Fri, 12 Jul 2002 19:02:09 -0400 gcl (2.5.0.cvs20020625-9) unstable; urgency=high * cvs commits for 64bit support -- Camm Maguire Fri, 12 Jul 2002 18:01:21 -0400 gcl (2.5.0.cvs20020625-8) unstable; urgency=high * NULL_OR_ON_C_STACK macro correction for m68k -- Camm Maguire Fri, 12 Jul 2002 14:37:48 -0400 gcl (2.5.0.cvs20020625-7) unstable; urgency=high * arm is bigendian -- Camm Maguire Wed, 10 Jul 2002 18:04:22 -0400 gcl (2.5.0.cvs20020625-6) unstable; urgency=high * cvs updates for arm build -- Camm Maguire Tue, 9 Jul 2002 16:09:26 -0400 gcl (2.5.0.cvs20020625-5) unstable; urgency=high * CC environment variable setting in debian/rules to aid in porting * gcc 2.95 for m68k -- Camm Maguire Sat, 6 Jul 2002 23:00:23 -0400 gcl (2.5.0.cvs20020625-4) unstable; urgency=high * gcc 3.0 for arm * cachectl header for m68k -- Camm Maguire Mon, 1 Jul 2002 15:47:53 -0400 gcl (2.5.0.cvs20020625-3) unstable; urgency=high * Better libbfd detection for arm/alpha -- Camm Maguire Wed, 26 Jun 2002 17:27:21 -0400 gcl (2.5.0.cvs20020625-2) unstable; urgency=high * s390 support -- Camm Maguire Tue, 25 Jun 2002 21:25:35 -0400 gcl (2.5.0.cvs20020625-1) unstable; urgency=high * CVS updates, new s390 arch -- Camm Maguire Tue, 25 Jun 2002 19:26:36 -0400 gcl (2.5.0.cvs20020610-2) unstable; urgency=high * cvs updates -- Camm Maguire Thu, 13 Jun 2002 08:42:32 -0400 gcl (2.5.0.cvs20020610-1) unstable; urgency=high * cvs updates -- Camm Maguire Wed, 12 Jun 2002 23:04:57 -0400 gcl (2.5.0.cvs20020523-2) unstable; urgency=high * configure updates for better tk detection -- Camm Maguire Fri, 24 May 2002 18:50:22 -0400 gcl (2.5.0.cvs20020523-1) unstable; urgency=high * New upstream release -- Camm Maguire Fri, 24 May 2002 18:50:22 -0400 gcl (2.5.0.cvs20020429-1) unstable; urgency=high * Build-Depend on tk8.2-dev, Closes: #144330 * New cvs updates * Added sparc to arch list, Closes: #143465 -- Camm Maguire Mon, 29 Apr 2002 23:07:36 -0400 gcl (2.5.0.cvs20020219-2) unstable; urgency=medium * flavor ->debian-emacs-flavor in emacsen-startup -- Camm Maguire Mon, 4 Mar 2002 14:29:59 -0500 gcl (2.5.0.cvs20020219-1) unstable; urgency=medium * Updated package descriptions, Closes: #134402 * Static linking of libbfd, Closes: #134647 * Gcl currently only available on i386, arm and m68k as specified in the Architecture control field, Closes: #133912 -- Camm Maguire Tue, 19 Feb 2002 12:04:29 -0500 gcl (2.5.0.cvs-3) unstable; urgency=medium * Build-depend on texi2html, Closes: #133699 -- Camm Maguire Wed, 13 Feb 2002 16:22:35 -0500 gcl (2.5.0.cvs-2) unstable; urgency=medium * Put in versioned dependency on binutils for libbfd support, rebuilt with latest binutils, Closes: #133004 -- Camm Maguire Tue, 12 Feb 2002 13:19:12 -0500 gcl (2.5.0.cvs-1) unstable; urgency=medium * Latest patches from CVS, enabling libbfd relocations, among other things * /etc/emacs/site-start.d/50gcl.el as conffile, Closes: #132137 * limited arm and m68k support -- Camm Maguire Mon, 4 Feb 2002 09:32:29 -0500 gcl (2.5.0-1) unstable; urgency=medium * New maintainer * New upstream release * New release so far builds only on i386, Closes: #116070, Closes: #123371 * New release so far builds only on i386, Closes: #115041 * Gcl must currently use its own copy of gmp, as the upstream version of gmp uses malloc, which interferes with gcl's garbage collection and relocation scheme. The change from malloc to alloca has been suggested to upstream gmp developers. Closes: #108910 * Tcl/Tk support now in. Closes: #113197 -- Camm Maguire Fri, 21 Dec 2001 00:03:43 -0500 gcl (2.4.0-3) unstable; urgency=medium * Make gcl use libgmp3 package. (closes: #108910) * Remove tk support. (closes: #108909) * Fix stupid missing dependency line. (closes: #108907, #108908) * Removed readme.mingw from the debian package, this package is not compiled under mingw (windows gcc port). * Close ITA bug. (closes: #112312) -- Baruch Even Sat, 22 Sep 2001 00:27:14 +0300 gcl (2.4.0-2) unstable; urgency=low * Change tclsh Build-Depends to tcl8.0 because apt is broken. (closes: #99261) -- JP Sugarbroad Wed, 30 May 2001 14:34:53 -0500 gcl (2.4.0-1) unstable; urgency=low * New upstream release -- JP Sugarbroad Sun, 13 May 2001 20:31:01 -0500 gcl (2.3.7+beta3-3) unstable; urgency=low * Move gcl-doc to section doc (closes: #78666) -- JP Sugarbroad Sun, 13 May 2001 20:26:28 -0500 gcl (2.3.7+beta3-2) unstable; urgency=low * Remove alpha from arch list * Move tcl/tk from Depends to Suggests -- JP Sugarbroad Fri, 4 May 2001 16:24:11 -0500 gcl (2.3.7+beta3-1) unstable; urgency=low * New maintainer * Repackaged with debhelper (closes: #42045, #86097, #91475, #91478) * New upstream release (closes: #59577, #71096) * Added sparc+alpha, removed m68k (closes: #87407) -- JP Sugarbroad Mon, 30 Apr 2001 19:07:49 -0500 gcl (2.2.1-6) unstable; urgency=low * Disable stripping of "saved_gcl" binary. (#45778) -- Steve Dunham Fri, 24 Sep 1999 14:39:15 -0400 gcl (2.2.1-5) unstable; urgency=low * Fix m68k build -- Steve Dunham Tue, 6 Jul 1999 09:45:09 -0400 gcl (2.2.1-4) unstable; urgency=low * Fix bug #31718 -- Steve Dunham Fri, 2 Jul 1999 11:11:12 -0400 gcl (2.2.1-3) unstable; urgency=low * Add m68k patches -- Steve Dunham Wed, 16 Dec 1998 14:25:46 -0500 gcl (2.2.1-2) unstable; urgency=low * Compile against libc6. New maintainer. -- Steve Dunham Wed, 5 Nov 1997 10:09:12 -0500 gcl (2.2.1-1) unstable; urgency=low * New upstream release; suggests tcl76, tk42. * gcl-doc contains gcl-si and gcl-tk info pages. * debian/rules: clean target removes temporary files from h and o subdirectories (bug #5984). -- Karl Sackett Fri, 3 Jan 1997 10:16:40 -0600 gcl (2.2-5) unstable; urgency=low * Converted package to 2.1.1.0 standard. * Stripped gcltkaux (bug #5074). * gcl-si and gcl-tk info pages converted to HTML. -- Karl Sackett Tue, 5 Nov 1996 13:30:30 -0600 2.2-4 * add-defs: patched locates for tk.tcl, init.tcl * gcl-tk/tkAppInit.c: patched for tk4.1 support * gcl-tk/tkMain.c: patched for tk4.1 support 2.2-3 * Debian support files now partily architecture independent. There are, however, no add-defs files except for 386-linux. * Rebuilt package to correct corrupted upload problem. 2.2-2 * Removed tk support from distribution. This was written to use tk-3.6 and doesn't support tk-4.0 or tk-4.1. I am not aware of any plans to upgrade the code. (Closes bug #2865) 2.2-1 * Added Debian support files * h/386-linux.defs: set OFLAG = -O2 * h/386-linux.h: undid patch that swaped signal.h for sigcontext.h gcl/debian/compat000066400000000000000000000000021242227143400142440ustar00rootroot000000000000005 gcl/debian/control000066400000000000000000000027651242227143400144630ustar00rootroot00000000000000Source: gcl Section: lisp Priority: optional Maintainer: Camm Maguire Homepage: http://gnu.org/software/gcl Build-Depends: debhelper (>= 5 ), libreadline-dev, m4, tk8.6-dev, libgmp-dev, autotools-dev, libxmu-dev, libxaw7-dev, po-debconf, zlib1g-dev Standards-Version: 3.9.5 Package: gcl Architecture: any Depends: ${shlibs:Depends}, ${misc:Depends}, ${gcc}, debconf (>= 1.2.0), emacs24 | emacsen, ucf Breaks: emacsen-common (<< 2.0.0) Suggests: gcl-doc Description: GNU Common Lisp compiler GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter implemented in C, and complying mostly with the standard set forth in the book "Common Lisp, the Language I". It attempts to strike a useful middle ground in performance and portability from its design around C. . This package contains the Lisp system itself. Documentation is provided in the gcl-doc package. Package: gcl-doc Section: doc Architecture: all Conflicts: gclinfo Replaces: gclinfo Depends: dpkg (>= 1.15.4) | install-info, ${misc:Depends} Description: Documentation for GNU Common Lisp GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter implemented in C, and complying mostly with the standard set forth in the book "Common Lisp, the Language I". It attempts to strike a useful middle ground in performance and portability from its design around C. . This package contains Documentation in info format of both the system internals, as well as the graphical interface currently implemented in Tcl/Tk. gcl/debian/control.000066400000000000000000000027651242227143400145410ustar00rootroot00000000000000Source: gcl Section: lisp Priority: optional Maintainer: Camm Maguire Homepage: http://gnu.org/software/gcl Build-Depends: debhelper (>= 5 ), libreadline-dev, m4, tk8.6-dev, libgmp-dev, autotools-dev, libxmu-dev, libxaw7-dev, po-debconf, zlib1g-dev Standards-Version: 3.9.5 Package: gcl Architecture: any Depends: ${shlibs:Depends}, ${misc:Depends}, ${gcc}, debconf (>= 1.2.0), emacs24 | emacsen, ucf Breaks: emacsen-common (<< 2.0.0) Suggests: gcl-doc Description: GNU Common Lisp compiler GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter implemented in C, and complying mostly with the standard set forth in the book "Common Lisp, the Language I". It attempts to strike a useful middle ground in performance and portability from its design around C. . This package contains the Lisp system itself. Documentation is provided in the gcl-doc package. Package: gcl-doc Section: doc Architecture: all Conflicts: gclinfo Replaces: gclinfo Depends: dpkg (>= 1.15.4) | install-info, ${misc:Depends} Description: Documentation for GNU Common Lisp GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter implemented in C, and complying mostly with the standard set forth in the book "Common Lisp, the Language I". It attempts to strike a useful middle ground in performance and portability from its design around C. . This package contains Documentation in info format of both the system internals, as well as the graphical interface currently implemented in Tcl/Tk. gcl/debian/control.cvs000066400000000000000000000030401242227143400152400ustar00rootroot00000000000000Source: gclcvs Section: lisp Priority: optional Maintainer: Camm Maguire Homepage: http://gnu.org/software/gcl Build-Depends: debhelper (>= 5 ), libreadline-dev, m4, tk8.6-dev, libgmp-dev, autotools-dev, libxmu-dev, libxaw7-dev, po-debconf, zlib1g-dev Standards-Version: 3.9.5 Package: gclcvs Architecture: any Depends: ${shlibs:Depends}, ${misc:Depends}, ${gcc}, debconf (>= 1.2.0), emacs24 | emacsen, ucf Breaks: emacsen-common (<< 2.0.0) Suggests: gclcvs-doc Description: GNU Common Lisp compiler, CVS snapshot GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter implemented in C, and complying mostly with the standard set forth in the book "Common Lisp, the Language I". It attempts to strike a useful middle ground in performance and portability from its design around C. . This package contains the Lisp system itself. Documentation is provided in the gclcvs-doc package. Package: gclcvs-doc Section: doc Architecture: all Conflicts: gclinfo Replaces: gclinfo Depends: dpkg (>= 1.15.4) | install-info, ${misc:Depends} Description: Documentation for GNU Common Lisp, CVS snapshot GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter implemented in C, and complying mostly with the standard set forth in the book "Common Lisp, the Language I". It attempts to strike a useful middle ground in performance and portability from its design around C. . This package contains Documentation in info format of both the system internals, as well as the graphical interface currently implemented in Tcl/Tk. gcl/debian/copyright000066400000000000000000000055071242227143400150100ustar00rootroot00000000000000This package was debianized by JP Sugarbroad on Mon, 30 Apr 2001 19:07:49 -0500. It was downloaded from http://savannah.gnu.org/projects/gcl Upstream Author: Bill Schelter Copyright: This package is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This package 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 Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this package; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. On Debian GNU/Linux systems, the complete text of the GNU Lesser General Public License can be found in `/usr/share/common-licenses/LGPL-2'. The source under xgcl-2 is Copyright (c) 1995 Gordon S. Novak Jr., Hiep Huu Nguyen, William F. Schelter, and The University of Texas at Austin. 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 1, or (at your option) any later version. and ;;********************************************************** ;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ;;and the Massachusetts Institute of Technology, Cambridge, Massachusetts. ;; All Rights Reserved ;;Permission to use, copy, modify, and distribute this software and its ;;documentation for any purpose and without fee is hereby granted, ;;provided that the above copyright notice appear in all copies and that ;;both that copyright notice and this permission notice appear in ;;supporting documentation, and that the names of Digital or MIT not be ;;used in advertising or publicity pertaining to distribution of the ;;software without specific, written prior permission. ;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, ;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS ;;SOFTWARE. ;;***************************************************************** On Debian GNU/Linux systems, the complete text of the GNU General Public License can be found in `/usr/share/common-licenses/GPL-1'. gcl/debian/gcl.lintian-overrides000066400000000000000000000001151242227143400171700ustar00rootroot00000000000000gcl: unstripped-binary-or-object gcl: binary-compiled-with-profiling-enabled gcl/debian/gcl.sh000077500000000000000000000011641242227143400141540ustar00rootroot00000000000000#!/bin/sh EXT=@EXT@ VERS=@VERS@ . /etc/default/gcl$EXT if ! set | grep -q -w GCL_ANSI ; then GCL_ANSI=$DEFAULT_GCL_ANSI ; fi if ! set | grep -q -w GCL_PROF ; then GCL_PROF=$DEFAULT_GCL_PROF ; fi if [ "$GCL_PROF" = "" ] ; then DIR=/usr/lib/gcl-$VERS ; else DIR=/usr/lib/gcl-$VERS-prof ; fi if [ "$GCL_ANSI" = "" ] ; then EXE=saved_gcl; else EXE=saved_ansi_gcl; fi SYS=$DIR/unixport exec $SYS/$EXE -dir $SYS/ -libdir $DIR/ \ -eval '(setq si::*allow-gzipped-file* t)' \ -eval '(setq si::*tk-library* "/usr/lib/tk@TKVERS@")' \ "$@" # other options: -load /tmp/foo.o -load jo.lsp -eval "(joe 3)" gcl/debian/gcl.templates000066400000000000000000000031111242227143400155270ustar00rootroot00000000000000# These templates have been reviewed by the debian-l10n-english # team # # If modifications/additions/rewording are needed, please ask # debian-l10n-english@lists.debian.org for advice. # # Even minor modifications require translation updates and such # changes should be coordinated with translators and reviewers. Template: gcl@EXT@/default_gcl_ansi Type: boolean _Description: Use the work-in-progress ANSI build by default? GCL is in the process of providing an ANSI compliant image in addition to its traditional CLtL1 image still in production use. . Please see the README.Debian file for a brief description of these terms. Choosing this option will determine which image will be used by default when executing 'gcl@EXT@'. . This setting may be overridden by setting the GCL_ANSI environment variable to any non-empty string for the ANSI build, and to the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor will be reported in the initial startup banner. Template: gcl@EXT@/default_gcl_prof Type: boolean _Description: Use the profiling build by default? GCL has optional support for profiling via gprof. . Please see the documentation for si::gprof-start and si::gprof-quit for details. As this build is slower than builds without gprof support, it is not recommended for final production use. . Set the GCL_PROF environment variable to the empty string for more optimized builds, or any non-empty string for profiling support; e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, this will be reported in the initial startup banner. gcl/debian/in.gcl-doc.README.Debian000066400000000000000000000004521242227143400170240ustar00rootroot00000000000000New in 2.6.2 ------------ The gcl.texi files and the resulting html, info, and pdf outputs have been removed pending an enquiry into the copyright and license status of the dpANS documents upon which they are presumably based. -- Camm Maguire , Fri, 9 May 2014 19:08:59 +0000 gcl/debian/in.gcl-doc.doc-base.si000066400000000000000000000006311242227143400167740ustar00rootroot00000000000000Document: gcl@EXT@-si-doc Title: GNU Common Lisp Documentation -- System Internals Author: W. Schelter Abstract: Documentation on GCL-specific Lisp system functions Section: Programming Format: PDF Files: /usr/share/doc/gcl@EXT@-doc/gcl-si*.pdf.gz /usr/share/doc/gcl@EXT@-doc/gcl-si*.pdf.gz Format: HTML Index: /usr/share/doc/gcl@EXT@-doc/gcl-si/index.html Files: /usr/share/doc/gcl@EXT@-doc/gcl-si/*.html gcl/debian/in.gcl-doc.doc-base.tk000066400000000000000000000006271242227143400170040ustar00rootroot00000000000000Document: gcl@EXT@-tk-doc Title: GNU Common Lisp Tk Interface Documentation Author: W. Schelter Abstract: Documentation for Graphical Interface to GCL using TCL/Tk Section: Programming Format: PDF Files: /usr/share/doc/gcl@EXT@-doc/gcl-tk*.pdf.gz /usr/share/doc/gcl@EXT@-doc/gcl-tk*.pdf.gz Format: HTML Index: /usr/share/doc/gcl@EXT@-doc/gcl-tk/index.html Files: /usr/share/doc/gcl@EXT@-doc/gcl-tk/*.html gcl/debian/in.gcl-doc.doc-base.xgcl000066400000000000000000000006531242227143400173220ustar00rootroot00000000000000Document: gcl@EXT@-xgcl-doc Title: GNU Common Lisp Documentation -- System Internals Author: W. Schelter Abstract: Documentation on GCL-specific Lisp system functions Section: Programming Format: Text Files: /usr/share/doc/gcl@EXT@-doc/dwdoc.tex.gz Format: PDF Files: /usr/share/doc/gcl@EXT@-doc/dwdoc.pdf.gz Format: HTML Index: /usr/share/doc/gcl@EXT@-doc/dwdoc/dwdoc1.html Files: /usr/share/doc/gcl@EXT@-doc/dwdoc/*.html gcl/debian/in.gcl-doc.docs000066400000000000000000000000271242227143400156340ustar00rootroot00000000000000faq readme readme.xgcl gcl/debian/in.gcl-doc.info000066400000000000000000000002601242227143400156360ustar00rootroot00000000000000debian/tmp/usr/share/info/gcl@EXT@-si.info debian/tmp/usr/share/info/gcl@EXT@-tk.info debian/tmp/usr/share/info/gcl@EXT@-tk.info-1 debian/tmp/usr/share/info/gcl@EXT@-tk.info-2 gcl/debian/in.gcl-doc.install000066400000000000000000000000461242227143400163530ustar00rootroot00000000000000debian/tmp/usr/share/doc/gcl@EXT@-doc gcl/debian/in.gcl.config000066400000000000000000000007341242227143400154130ustar00rootroot00000000000000#!/bin/sh CONFIGFILE=/etc/default/gcl@EXT@ set -e . /usr/share/debconf/confmodule # Load config file, if it exists. if [ -e $CONFIGFILE ]; then . $CONFIGFILE || true # Store values from config file into # debconf db. db_set gcl@EXT@/default_gcl_ansi $DEFAULT_GCL_ANSI db_set gcl@EXT@/default_gcl_prof $DEFAULT_GCL_PROF fi # Ask questions. db_input medium gcl@EXT@/default_gcl_ansi || true db_input medium gcl@EXT@/default_gcl_prof || true db_go || true gcl/debian/in.gcl.docs000066400000000000000000000000531242227143400150700ustar00rootroot00000000000000ansi-tests/test_results RELEASE-2.6.2.html gcl/debian/in.gcl.emacsen-compat000066400000000000000000000000021242227143400170260ustar00rootroot000000000000000 gcl/debian/in.gcl.emacsen-install000066400000000000000000000023271242227143400172250ustar00rootroot00000000000000#! /bin/sh -e # /usr/lib/emacsen-common/packages/install/#PACKAGE# # Written by Jim Van Zandt , borrowing heavily # from the install scripts for gettext by Santiago Vila # and octave by Dirk Eddelbuettel . FLAVOR=$1 PACKAGE=gcl@EXT@ if [ ${FLAVOR} = emacs ]; then exit 0; fi echo install/${PACKAGE}: Handling install for emacsen flavor ${FLAVOR} #FLAVORTEST=`echo $FLAVOR | cut -c-6` #if [ ${FLAVORTEST} = xemacs ] ; then # SITEFLAG="-no-site-file" #else # SITEFLAG="--no-site-file" #fi FLAGS="${SITEFLAG} -q -batch -l path.el -f batch-byte-compile" ELDIR=/usr/share/emacs/site-lisp/${PACKAGE} ELCDIR=/usr/share/${FLAVOR}/site-lisp/${PACKAGE} # Install-info-altdir does not actually exist. # Maybe somebody will write it. if test -x /usr/sbin/install-info-altdir; then echo install/${PACKAGE}: install Info links for ${FLAVOR} install-info-altdir --quiet --section "" "" --dirname=${FLAVOR} /usr/info/${PACKAGE}.info.gz fi install -m 755 -d ${ELCDIR} cd ${ELDIR} FILES=`echo *.el` cp ${FILES} ${ELCDIR} cd ${ELCDIR} cat << EOF > path.el (setq load-path (cons "." load-path) byte-compile-warnings nil) EOF ${FLAVOR} ${FLAGS} ${FILES} rm -f *.el path.el exit 0 gcl/debian/in.gcl.emacsen-remove000066400000000000000000000007261242227143400170550ustar00rootroot00000000000000#!/bin/sh -e # /usr/lib/emacsen-common/packages/remove/#PACKAGE# FLAVOR=$1 PACKAGE=gcl@EXT@ if [ ${FLAVOR} != emacs ]; then if test -x /usr/sbin/install-info-altdir; then echo remove/${PACKAGE}: removing Info links for ${FLAVOR} install-info-altdir --quiet --remove --dirname=${FLAVOR} /usr/info/#PACKAGE#.info.gz fi echo remove/${PACKAGE}: purging byte-compiled files for ${FLAVOR} rm -rf /usr/share/${FLAVOR}/site-lisp/${PACKAGE} fi gcl/debian/in.gcl.emacsen-startup000066400000000000000000000015041242227143400172550ustar00rootroot00000000000000;; -*-emacs-lisp-*- ;; ;; Emacs startup file for the Debian GNU/Linux #PACKAGE# package ;; ;; Originally contributed by Nils Naumann ;; Modified by Dirk Eddelbuettel ;; Adapted for dh-make by Jim Van Zandt ;; The #PACKAGE# package follows the Debian/GNU Linux 'emacsen' policy and ;; byte-compiles its elisp files for each 'emacs flavor' (emacs19, ;; xemacs19, emacs20, xemacs20...). The compiled code is then ;; installed in a subdirectory of the respective site-lisp directory. ;; We have to add this to the load-path: (setq load-path (cons (concat "/usr/share/" (symbol-name debian-emacs-flavor) "/site-lisp/gcl@EXT@") load-path)) (autoload 'run@EXT@ "gcl@EXT@" "" t) (autoload 'dbl@EXT@ "dbl@EXT@" "" t) gcl/debian/in.gcl.install000066400000000000000000000001011242227143400156000ustar00rootroot00000000000000debian/tmp/usr/lib debian/tmp/usr/bin debian/tmp/usr/share/emacs gcl/debian/in.gcl.manpages000066400000000000000000000000511242227143400157310ustar00rootroot00000000000000debian/tmp/usr/share/man/man1/gcl@EXT@.1 gcl/debian/in.gcl.postinst000066400000000000000000000013561242227143400160320ustar00rootroot00000000000000#!/bin/sh case "$1" in configure) CONFIGFILE=$(tempfile -m 644) set -e . /usr/share/debconf/confmodule if [ "$1" = "configure" ] || [ "$1" = "reconfigure" ] ; then db_get gcl@EXT@/default_gcl_ansi if [ "$RET" = "true" ] ; then DEFAULT_GCL_ANSI=t else DEFAULT_GCL_ANSI= fi db_get gcl@EXT@/default_gcl_prof if [ "$RET" = "true" ] ; then DEFAULT_GCL_PROF=y else DEFAULT_GCL_PROF= fi echo "DEFAULT_GCL_ANSI=$DEFAULT_GCL_ANSI" >> $CONFIGFILE echo "DEFAULT_GCL_PROF=$DEFAULT_GCL_PROF" >> $CONFIGFILE fi ucf --debconf-ok $CONFIGFILE /etc/default/gcl@EXT@ ucfr gcl@EXT@ /etc/default/gcl@EXT@ # chmod 644 /etc/default/gcl@EXT@ esac #DEBHELPER# gcl/debian/in.gcl.postrm000066400000000000000000000006011242227143400154630ustar00rootroot00000000000000case "$1" in purge) for ext in '~' '%' .bak .ucf-new .ucf-old .ucf-dist; do rm -f /etc/default/gcl@EXT@$ext done rm -f /etc/default/gcl@EXT@ if which ucf >/dev/null; then ucf --purge /etc/default/gcl@EXT@ fi if which ucfr >/dev/null; then ucfr --purge gcl@EXT@ /etc/default/gcl@EXT@ fi ;; esac #DEBHELPER# gcl/debian/old.in.gcl-doc.doc-base.main000066400000000000000000000005631242227143400200660ustar00rootroot00000000000000Document: gcl@EXT@-doc Title: GNU Common Lisp Documentation Author: W. Schelter Abstract: A Common Lisp compiler and interpreter based on C Section: Apps/Programming Format: DVI Files: /usr/share/doc/gcl@EXT@-doc/gcl.dvi.gz /usr/share/doc/gcl@EXT@-doc/gcl.dvi Format: HTML Index: /usr/share/doc/gcl@EXT@-doc/gcl/index.html Files: /usr/share/doc/gcl@EXT@-doc/gcl/*.html gcl/debian/po/000077500000000000000000000000001242227143400134645ustar00rootroot00000000000000gcl/debian/po/POTFILES.in000066400000000000000000000000501242227143400152340ustar00rootroot00000000000000[type: gettext/rfc822deb] gcl.templates gcl/debian/po/cs.po000066400000000000000000000144531242227143400144400ustar00rootroot00000000000000# # Translators, if you are not familiar with the PO format, gettext # documentation is worth reading, especially sections dedicated to # this format, e.g. by running: # info -n '(gettext)PO Files' # info -n '(gettext)Header Entry' # # Some information specific to po-debconf are available at # /usr/share/doc/po-debconf/README-trans # or http://www.debian.org/intl/l10n/po-debconf/README-trans # # Developers do not need to manually edit POT or PO files. # msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2007-12-24 13:21+0100\n" "Last-Translator: Miroslav Kure \n" "Language-Team: Czech \n" "Language: cs\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Používat implicitnÄ› ANSI verzi (stále ve vývoji)?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL se nachází ve fázi, kdy kromÄ› tradiÄního obrazu CLtL1 (který se stále " "používá) poskytuje i obraz kompatibilní s ANSI." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Pro struÄný popis tÄ›chto termínů si prosím pÅ™eÄtÄ›te soubor README.Debian. " "Touto odpovÄ›dí urÄujete, který obraz se spustí po zadání „gcl@EXT@“. " #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Toto nastavení můžete pÅ™ebít nastavením promÄ›nné prostÅ™edí GCL_ANSI na " "neprázdný Å™etÄ›zec (použije ANSI verzi) nebo na prázdnou hodnotu (použije " "CLtL1 verzi). Například GCL_ANSI=t gcl@EXT@. AktuálnÄ› použitá verze se " "zobrazí na úvodní obrazovce." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Používat implicitnÄ› profilování?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL nyní podporuje profilování pÅ™es gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Podrobnosti naleznete v dokumentaci si::gprof-start a si::gprof-quit. Tato " "verze je pomalejší než verze bez podpory gprof, tudíž ji nedoporuÄujeme pro " "koncové produkÄní nasazení." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Toto nastavení můžete pÅ™ebít nastavením promÄ›nné prostÅ™edí GCL_PROF na " "neprázdný Å™etÄ›zec (zapne profilování) nebo na prázdnou hodnotu (povolí lepší " "optimalizace). Například GCL_PROF=t gcl@EXT@. Pokud je profilování zapnuto, " "dozvíte se o tom z úvodní obrazovky." #~ msgid "" #~ "GCL is one of the oldest free common lisp systems still in use. Several " #~ "production systems have used it for over a decade. The common lisp " #~ "standard in effect when GCL was first released is known as \"Common Lisp, " #~ "the Language\" (CLtL1) after a book by Steele of the same name providing " #~ "this specification. Subsequently, a much expanded standard was adopted " #~ "by the American National Standards Institute (ANSI), which is still " #~ "considered the definitive common lisp language specification to this " #~ "day. GCL is in the process of providing an ANSI compliant image in " #~ "addition to its traditional CLtL1 image still in production use. Setting " #~ "this variable will determine which image you will use by default on " #~ "executing 'gcl'. You can locally override this choice by setting the " #~ "GCL_ANSI environment variable to any non-empty string for the ANSI build, " #~ "and to the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl. You " #~ "may be interested in reviewing the ANSI test results sketching the level " #~ "of compliance achieved thus far in /usr/share/doc/gcl/test_results.gz. " #~ "The flavor of the build in force will be reported in the initial startup " #~ "banner." #~ msgstr "" #~ "GCL je jedním z nejstarších svobodných systémů common lispu, který se " #~ "dosud používá. NÄ›kolik produkÄních systémů jej používá déle než dekádu. " #~ "PÅ™i prvním vydání GCL byl v platnosti standard common lispu známý jako " #~ "\"Common Lisp, the Language\" (CLtL1) pojmenovaný podle Steelovy knihy " #~ "stejného jména, která tento standard definovala. Americkým národním " #~ "institutem pro standardizaci (ANSI) pak byl pÅ™ijat podstatnÄ› rozšířený " #~ "standard, který se do dneÅ¡ní doby považuje za koneÄnou specifikaci common " #~ "lispu. KromÄ› tradiÄního CLtL1 se GCL snaží nabídnout i verzi odpovídající " #~ "ANSI standardu. Nastavením této promÄ›nné urÄíte, jakým způsobem se má " #~ "binárka 'gcl' chovat. LokálnÄ› můžete toto nastavení pÅ™epsat nastavením " #~ "promÄ›nné prostÅ™edí GCL_ANSI na neprázdný Å™etÄ›zec (zapne ANSI chování) " #~ "nebo na prázdnou hodnotu (zapne CLtL1 chování). Například GCL_ANSI-t gcl. " #~ "AktuálnÄ› vybraný standard bude zobrazen v úvodní obrazovce prostÅ™edí. " #~ "Zajímavé může být porovnání dosud dosažené shody s ANSI standardem v " #~ "souboru /usr/share/doc/gcl/test_results.gz." gcl/debian/po/da.po000066400000000000000000000071411242227143400144130ustar00rootroot00000000000000# Danish translation gcl. # Copyright (C) 2012 gcl & nedenstÃ¥ende oversættere. # This file is distributed under the same license as the gcl package. # Joe Hansen (joedalton2@yahoo.dk), 2012. # msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2012-03-31 12:42+0000\n" "Last-Translator: Joe Hansen \n" "Language-Team: Danish \n" "Language: da\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Brug den foreløbige ANSI bygget som standard?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL er i gang med at tilbyde et ANSI-overholdende aftryk udover det " "traditionelle CLtL1-aftryk som stadig er i produktionsbrug." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Se venligst filen README.Debian for en kort beskrivelse af disse termer. " "Valg af denne indstilling vil bestemme hvilket aftryk som vil blive brugt " "som standard, nÃ¥r der køres »gcl@EXT@«." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Denne indstilling kan overskrives ved at angive miljøvariablen GCL_ANSI til " "enhver streng der ikke er tom for ANSI-bygningen, og til den tomme streng " "for CLtL1-bygningen, f.eks. GCL_ANSI=t gcl@EXT@. Den aktuelt tvungne " "byggevariant vil blive rapporteret i det oprindelige opstartsbanner." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Brug profileringen bygget som standard?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL har valgfri understøttelse for profilering via gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Se venligst dokumentationen for si::gprof-start og si::gprof-quit for " "detaljer. Da denne bygning er langsommere end bygninger uden gprof-" "understøttelse, sÃ¥ anbefales den ikke for endelig produktionsbrug." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Angiv miljøvariablen GCL_PROF til den tomme streng for bedre optimerede " "bygninger, eller enhver streng der ikke er tom for " "profileringsunderstøttelse; f.eks. GCL_PROF=t gcl@EXT@. Hvis profilering er " "aktiveret, vil denne blive rapporteret i det oprindelige opstartsbanner." gcl/debian/po/de.po000066400000000000000000000144321242227143400144200ustar00rootroot00000000000000# Translation of gcl debconf templates to German # Copyright (C) Stefan Bauer , 2007. # Copyright (C) Helge Kreutzmann , 2007, 2008. # This file is distributed under the same license as the gcl package. # msgid "" msgstr "" "Project-Id-Version: gcl 2.6.7-36\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-01-09 11:49+0100\n" "Last-Translator: Stefan Bauer \n" "Language-Team: de \n" "Language: \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=ISO-8859-15\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Verwende standardmäßig den sich in Arbeit befindlichen ANSI-Build?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL ist derzeit dabei, zusätzlich zu dem noch im Einsatz befindlichen " "traditionellen CLtL1-Image ein ANSI-konformes Image bereitzustellen." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Bitte lesen Sie die Datei README.Debian für eine kurze Beschreibung dieser " "Begriffe. Die Wahl dieser Option bestimmen, welches Image standardmäßig " "verwendet wird, wenn »gcl@EXT@« ausgeführt wird." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Diese Einstellung kann mit der Umgebungsvariablen GCL_ANSI überschrieben " "werden. Jede nicht-leere Zeichenkette führt zur ANSI-Erstellung, und die " "leere Zeichenkette führt zum CLtL1-Bau, z.B. GCL_ANSI=t gcl@EXT@. In der " "Startmeldung wird die derzeit erzwungene Bauart berichtet." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Verwende standardmäßig den Profiling-Build?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL besitzt optionale Unterstützung für Profiling mittels Gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Bitte lesen Sie die Dokumentation für si::gprof-start und si::gprof-quit für " "Details. Da ein solches Programm langsamer ist als ein Programm ohne Gprof-" "Unterstützung, wird dies für den Produktiveinsatz nicht empfohlen." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Setzen Sie die Umgebungsvariable GCL_PROF auf die leere Zeichenkette, um ein " "optimiertes Programm zu erhalten oder auf irgendeine nicht-leere " "Zeichenkette, für Profiling-Unterstützung; z.B. GCL_PROF=t gcl@EXT@. Falls " "Profiling aktiviert ist, wird dies in der Startmeldung angezeigt." #~ msgid "" #~ "GCL is in the process of providing an ANSI compliant image in addition to " #~ "its traditional CLtL1 image still in production use. Please see the " #~ "README.Debian file for a brief description of these terms. Setting this " #~ "variable will determine which image you will use by default on executing " #~ "'gcl@EXT@'. You can locally override this choice by setting the GCL_ANSI " #~ "environment variable to any non-empty string for the ANSI build, and to " #~ "the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The " #~ "flavor of the build in force will be reported in the initial startup " #~ "banner." #~ msgstr "" #~ "GCL arbeitet neben dem traditionellen CLtL1-Image für den " #~ "Produktiveinsatz zusätzlich an der Bereitstellung eines kompatiblen ANSI-" #~ "Images. Bitte beachten Sie die README.Debian-Datei für eine kurze " #~ "Beschreibung dieses Themas. Durch diese Variable definieren Sie, welches " #~ "Image voreingestellt bei der Ausführung von »gcl@EXT@« verwendet wird. " #~ "Diese Auswahl kann lokal, durch einen nicht leeren Wert in der " #~ "Umgebungsvariable »GCL_ANSI« für den ANSI-Build, bzw. einen leeren Wert " #~ "für den CLtL1-Build, z.B. GCL_ANSI=t gcl@EXT@ definiert werden. Es " #~ "erfolgt eine Meldung über die aktive Erstellung im einführenden Start-" #~ "Banner." #~ msgid "" #~ "GCL now has optional support for profiling via gprof. Please see the " #~ "documentation for si::gprof-start and si::gprof-quit for details. As this " #~ "build is slower than builds without gprof support, it is not recommended " #~ "for final production use. You can locally override the default choice " #~ "made here by setting the GCL_PROF environment variable to any non-empty " #~ "string for profiling support, and to the empty string for the more " #~ "optimized builds, e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, " #~ "this will be reported in the initial startup banner." #~ msgstr "" #~ "GCL besitzt optionale Unterstützung für Profiling mit gprof. Bitte lesen " #~ "Sie hierzu die Dokumentation von si::gprof-start und si::gprof-quit für " #~ "weiterführende Informationen. Da dieser Build langsamer ist als ohne " #~ "gprof-Unterstützung, wird dieser Weg nicht für den endgültig produktiven " #~ "Einsatz empfohlen. Sie können die hier gemachten Angaben lokal über die " #~ "GCL_PROF-Umgebungsvariable durch einen beliebigen Wert ändern, bzw. durch " #~ "einen leeren Wert für das weitaus anpassungsfähigere Build, z.B. " #~ "GCL_PROF=t gcl@EXT@. Falls Profiling aktiviert ist, erfolgt eine Meldung " #~ "im einführenden Start-Banner." gcl/debian/po/es.po000066400000000000000000000240201242227143400144310ustar00rootroot00000000000000# gcl po-debconf translation to Spanish # Copyright (C) 2005, 2007, 2008 Software in the Public Interest # This file is distributed under the same license as the gcl package. # # Changes: # - Initial translation # César Gómez Martín , 2005 # # - Updates # Rudy Godoy Guillén , 2007 # Francisco Javier Cuadrado , 2008 # # Traductores, si no conoce el formato PO, merece la pena leer la # documentación de gettext, especialmente las secciones dedicadas a este # formato, por ejemplo ejecutando: # # info -n '(gettext)PO Files' # info -n '(gettext)Header Entry' # # Equipo de traducción al español, por favor, lean antes de traducir # los siguientes documentos: # # - El proyecto de traducción de Debian al español # http://www.debian.org/intl/spanish/ # especialmente las notas de traducción en # http://www.debian.org/intl/spanish/notas # # - La guía de traducción de po's de debconf: # /usr/share/doc/po-debconf/README-trans # o http://www.debian.org/intl/l10n/po-debconf/README-trans # msgid "" msgstr "" "Project-Id-Version: gcl 2.6.7-45\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-12-04 20:00+0100\n" "Last-Translator: Francisco Javier Cuadrado \n" "Language-Team: Debian l10n spanish \n" "Language: \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=utf-8\n" "Content-Transfer-Encoding: 8bit\n" "X-Poedit-Language: Spanish\n" "X-Poedit-Country: SPAIN\n" "X-Poedit-SourceCharset: utf-8\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "" "¿Utilizar la generación ANSI todavía en desarrollo de manera predeterminada?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GL está en el proceso de proporcionar una imagen ANSI, además de su imagen " "CLtL1 tradicional que todavía se usa." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Por favor, véase el archivo README.Debian para una descripción corta de " "estos términos. Eligiendo esta opción determinará que imagen se usará de " "manera predeterminada al ejecutar «gcl@EXT@»." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Esta configuración se puede sobrescribir cambiando la variable de entorno " "GCL_ANSI a cualquier cadena de caracteres no vacía para la generación ANSI, " "y a una cadena de caracteres vacía para la generación CLtL1, por ejemplo: " "«GCL_ANSI=t gcl@EXT@». El actual tipo de generación se mostrará en la " "información inicial del arranque." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "¿Utilizar la generación con «profiling» de manera predeterminada?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL permite usar «profiling», de manera opcional, mediante gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Por favor, véase la documentación para los detalles de «si::gprof-start» y " "«si::gprof-quit». Ya que esta generación es más lenta que sin el uso de " "gprof, no se recomienda para su uso final." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Cambie el valor de la variable de entorno GCL_PROF a una cadena de " "caracteres vacía para generación más optimizadas, o a una cadena de " "caracteres no vacía para usar el «profiling», por ejemplo: «GCL_PROF=t " "gcl@EXT@». Si el «profiling» está activado, se mostrará en la información " "inicial del arranque." #~ msgid "" #~ "GCL is in the process of providing an ANSI compliant image in addition to " #~ "its traditional CLtL1 image still in production use. Please see the " #~ "README.Debian file for a brief description of these terms. Setting this " #~ "variable will determine which image you will use by default on executing " #~ "'gcl@EXT@'. You can locally override this choice by setting the GCL_ANSI " #~ "environment variable to any non-empty string for the ANSI build, and to " #~ "the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The " #~ "flavor of the build in force will be reported in the initial startup " #~ "banner." #~ msgstr "" #~ "GCL está en proceso de incorporar una imagen compatible con ANSI en " #~ "adición a su imagen CLtL1 tradicional que todavía se usa en producción. " #~ "Por favor, véase el fichero README de Debian para una breve descripción " #~ "acerca de estos términos. El definir esta variable determinará qué imagen " #~ "utilizar de manera predeterminada cuando ejecute «gcl@EXT@».\n" #~ "Puede anular esta elección localmente definiendo la variable de entorno " #~ "GCL_ANSI a una cadena no vacía para la compilación ANSI, y a una vacía " #~ "para la compilación CLtL1, ejemplo: GCL_ANSI=t gcl@EXT@. La versión de la " #~ "compilación se indicará en el anuncio inicial de arranque." #~ msgid "" #~ "GCL now has optional support for profiling via gprof. Please see the " #~ "documentation for si::gprof-start and si::gprof-quit for details. As this " #~ "build is slower than builds without gprof support, it is not recommended " #~ "for final production use. You can locally override the default choice " #~ "made here by setting the GCL_PROF environment variable to any non-empty " #~ "string for profiling support, and to the empty string for the more " #~ "optimized builds, e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, " #~ "this will be reported in the initial startup banner." #~ msgstr "" #~ "Ahora GCL tiene soporte opcional para perfilado a través de gprof. Por " #~ "favor, mire la documentación de «si::gprof-start» y de «si::gprof-quit» y " #~ "«si::gprof-quit» si desea más detalles. Dado que esta compilación es más " #~ "lenta que otras sin soporte para gprof, no se recomienda usarlo en " #~ "producción. Puede anular esta elección de forma local mediante el " #~ "establecimiento de la variable de entorno GCL_PROF a cualquier cadena no " #~ "vacía para soporte de perfiles, y a la cadena vacía para los paquetes más " #~ "optimizados, es decir GCL_PROF=t gcl. Si el perfilado está activo se " #~ "indicará en el anuncio inicial de arranque." #~ msgid "" #~ "GCL is one of the oldest free common lisp systems still in use. Several " #~ "production systems have used it for over a decade. The common lisp " #~ "standard in effect when GCL was first released is known as \"Common Lisp, " #~ "the Language\" (CLtL1) after a book by Steele of the same name providing " #~ "this specification. Subsequently, a much expanded standard was adopted " #~ "by the American National Standards Institute (ANSI), which is still " #~ "considered the definitive common lisp language specification to this " #~ "day. GCL is in the process of providing an ANSI compliant image in " #~ "addition to its traditional CLtL1 image still in production use. Setting " #~ "this variable will determine which image you will use by default on " #~ "executing 'gcl'. You can locally override this choice by setting the " #~ "GCL_ANSI environment variable to any non-empty string for the ANSI build, " #~ "and to the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl. You " #~ "may be interested in reviewing the ANSI test results sketching the level " #~ "of compliance achieved thus far in /usr/share/doc/gcl/test_results.gz. " #~ "The flavor of the build in force will be reported in the initial startup " #~ "banner." #~ msgstr "" #~ "GCL es uno de los sistemas libres de «common lisp» más antiguos que " #~ "todavía se usan. Varios sistemas en producción han estado usándolo " #~ "durante más de una década. Cuando GCL se liberó por primera vez, el " #~ "estándar «common lisp» se conocía como «Common Lisp, the " #~ "Language» (CLtL1) después de un libro escrito por Steele que llevaba el " #~ "mismo nombre y que proporcionaba esta especificación. Posteriormente se " #~ "adoptó en el Instituto Nacional de Estándares Americano (ANSI) un " #~ "estándar más extendido, que todavía se considera la especificación " #~ "definitiva del lenguaje «common lisp» hasta hoy. GCL está en el proceso " #~ "de proporcionar una imagen conforme a ANSI además de su imagen CltL1 " #~ "tradicional que todavía se usa en producción. Al establecer esta variable " #~ "se determinará la imagen por omisión que usará al ejecutar «gcl». Puede " #~ "anular esta elección de forma local mediante el establecimiento de la " #~ "variable de entorno GCL_ANSI a cualquier cadena no vacía para el paquete " #~ "ANSI, y a la cadena vacía para el paquete CLtL1, i.e. GCL_ANSI=t gcl. " #~ "Quizás esté interesado en revisar los resultados de las pruebas ANSI " #~ "describiendo el nivel de conformidad logrado hasta ahora en /usr/share/" #~ "doc/gcl/test_results.gz. Se informará del tipo de paquete usado en el " #~ "anuncio inicial de arranque." gcl/debian/po/fi.po000066400000000000000000000070231242227143400144240ustar00rootroot00000000000000msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2007-12-29 23:28+0200\n" "Last-Translator: Esko Arajärvi \n" "Language-Team: Finnish \n" "Language: fi\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "X-Poedit-Language: Finnish\n" "X-Poedit-Country: Finland\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Käytetäänkö kehitettävää ANSI-käännöstä oletuksena?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL:n on tarkoitus tarjota ANSI-yhteensopiva kuva perinteisen, vielä " "tuotantokäytössä olevan CLtL1-kuvan lisäksi." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Tiedostosta README.Debian löytyy (englanniksi) näiden termien lyhyet " "kuvaukset. Tämä valinta vaikuttaa siihen mitä kuvaa käytetään oletuksena " "ajettaessa â€gcl@EXT@â€." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Tämä asetus voidaan ohittaa asettamalla GCL_ANSI-ympäristömuuttuja. Jos " "muuttujan arvo on mikä tahansa ei-tyhjä merkkijono, käytetään ANSI-" "käännöstä, ja jos muuttujan arvo on tyhjä merkkijono, käytetään CLtL1-" "käännöstä. Esimerkiksi: GCL_ANSI=t gcl@EXT@. Käytetty pakotettu käännöstapa " "raportoidaan käynnistysruudussa." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Käytetäänkö profilointia oletuksena?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL tukee valinnaisesti profilointia gprofin avulla." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Katso yksityiskohdat (englanniksi) dokumentaatiosta kohdista si::gprof-start " "ja si::gprof-quit. Koska tämä käännös on hitaampi kuin käännökset ilman " "gprof-tukea, tätä ei suositella tuotantokäyttöön." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Aseta GCL_PROF-ympäristömuuttuja tyhjäksi merkkijonoksi käyttääksesi " "optimoidumpia käännöksiä ja miksi tahansa ei-tyhjäksi merkkijonoksi " "käyttääksesi profilointia. Esimerkiksi: GCL_PROF=t gcl@EXT@. Jos profilointi " "on aktivoituna, se raportoidaan käynnistysruudussa." gcl/debian/po/fr.po000066400000000000000000000146631242227143400144450ustar00rootroot00000000000000# Translation of gcl debconf templates to French # Copyright (C) 2007 Sylvain Archenault # This file is distributed under the same license as the iodine package. # # Sylvain Archenault , 2007. msgid "" msgstr "" "Project-Id-Version: gcl 2.6.7-1\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2007-12-23 13:03+0100\n" "Last-Translator: Sylvain Archenault \n" "Language-Team: French \n" "Language: fr\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=ISO-8859-15\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Faut-il utiliser la compilation ANSI par défaut ?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL est en passe de fournir une image respectant la norme ANSI en plus de " "l'image traditionnelle CLtL1, toujours utilisée en production." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Veuillez lire le fichier README.Debian pour une brève description de ces " "termes. Le choix de cette option déterminera quelle image sera utilisée par " "défaut en exécutant « gcl@EXT@ »." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Ce réglage peut être changé en affectant à la variable d'environnement " "GCL_ANSI une chaîne non vide pour la compilation ANSI, et une chaîne vide " "pour la compilation CLtL1, par exemple GCL_ANSI=t gcl@EXT@. Le type de " "compilation sera affiché dans le bandeau de démarrage." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Faut-il utiliser le profilage par défaut ?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL permet optionnellement la gestion du profilage via gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Veuillez vous reporter à la documentation de « si::gprof-start » et « si::" "gprof-quit » pour plus de détails. Comme cet exécutable est plus lent que " "les exécutables sans la gestion de gprof, il n'est pas recommandé de " "l'utiliser en production." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Veuillez affecter une chaîne vide à la variable d'environnement GCL_PROF " "pour des compilations optimisées, ou une chaîne non vide pour avoir la " "gestion du profilage; par exemple GCL_PROF=t gcl@EXT@. Si le profilage est " "activé, cela sera affiché dans le bandeau de démarrage." #~ msgid "" #~ "GCL is in the process of providing an ANSI compliant image in addition to " #~ "its traditional CLtL1 image still in production use. Please see the " #~ "README.Debian file for a brief description of these terms. Setting this " #~ "variable will determine which image you will use by default on executing " #~ "'gcl@EXT@'. You can locally override this choice by setting the GCL_ANSI " #~ "environment variable to any non-empty string for the ANSI build, and to " #~ "the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The " #~ "flavor of the build in force will be reported in the initial startup " #~ "banner." #~ msgstr "" #~ "GCL a pour but de fournir une image conforme à la définition de " #~ "l'ANSI en plus de son image traditionnelle CLtL1 qui est toujours " #~ "utilisée en production. Veuillez consulter le fichier README.Debian " #~ "pour plus d'informations sur ces normes. Ce choix déterminera quelle " #~ "norme vous allez utiliser par défaut lors de l'exécution de " #~ "« gcl@EXT@ ». Vous pouvez localement modifier ce choix en " #~ "affectant une chaîne non vide à la variable d'environnement GCL_ANSI " #~ "pour une compilation respectant la norme définie par l'ANSI, et une " #~ "chaîne vide pour une compilation en accord avec la norme CLtL1, par " #~ "exemple GCL_ANSI=t gcl@EXT@. Le type de compilation sera affiché dans " #~ "le bandeau de démarrage." #~ msgid "" #~ "GCL now has optional support for profiling via gprof. Please see the " #~ "documentation for si::gprof-start and si::gprof-quit for details. As this " #~ "build is slower than builds without gprof support, it is not recommended " #~ "for final production use. You can locally override the default choice " #~ "made here by setting the GCL_PROF environment variable to any non-empty " #~ "string for profiling support, and to the empty string for the more " #~ "optimized builds, e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, " #~ "this will be reported in the initial startup banner." #~ msgstr "" #~ "GCL gÚre désormais le profilage via gprof. Veuillez consulter la " #~ "documentation de si::gprof-start et de si::gprof-quit pour plus " #~ "d'informations. La construction produite avec cette option est plus lente " #~ "que la construction classique. Par conséquent il n'est pas recommandé " #~ "de l'utiliser en production. Vous pouvez localement modifier ce choix en " #~ "affectant à la variable d'environnement GCL_PROF, une chaîne non vide " #~ "pour activer le profilage, ou une chaîne vide pour une compilation " #~ "optimisée, par exemple GCL_PROF=t gcl@EXT@. Si le profilage est " #~ "activé, cela sera affiché dans le bandeau de démarrage." gcl/debian/po/gl.po000066400000000000000000000143611242227143400144330ustar00rootroot00000000000000# Galician translation of gclcvs's debconf templates # This file is distributed under the same license as the gclcvs package. # Jacobo Tarrio , 2007. # msgid "" msgstr "" "Project-Id-Version: gclcvs\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-01-01 13:38+0000\n" "Last-Translator: Jacobo Tarrio \n" "Language-Team: Galician \n" "Language: gl\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "¿Empregar por defecto a versión ANSI que se está a facer?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "Estase a traballar para que GCL forneza unha imaxe ANSI ademáis da imaxe " "CLtL1 que aínda se emprega en produción." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Consulte o ficheiro README.Debian para ver unha descrición breve deses " "termos. Ao establecer esa variable ha determinar a imaxe que ha empregar por " "defecto ao executar \"gcl@EXT@\"." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Pode empregar a outra imaxe establecendo a variable de ambiente GCL_ANSI a " "calquera cadea non baleira para empregar a versión ANSI, e á cadea baleira " "para empregar a versión CLtL1; por exemplo, GCL_ANSI=t gcl@EXT@. Hase " "informar da versión en uso no cartel que aparece ao iniciar o programa." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "¿Empregar por defecto a versión con cronometrado?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL agora ten soporte opcional de cronometrado mediante gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Consulte a documentación de si::gprof-start e si::gprof-quit para máis " "detalles. Xa que esta versión é máis lenta que as que non teñen soporte de " "gprof, non se recomenda que a empregue para o uso en produción." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Pode empregar unha versión distinta á seleccionada establecendo a variable " "de ambiente GCL_PROF a calquera cadea non baleira para empregar o soporte de " "cronometrado, ou á cadea baleira para as versións máis optimizadas; por " "exemplo, GCL_PROF=t gcl@EXT@. Se está activado o cronometrado, hase informar " "diso no cartel que aparece ao iniciar o programa." #~ msgid "" #~ "GCL is in the process of providing an ANSI compliant image in addition to " #~ "its traditional CLtL1 image still in production use. Please see the " #~ "README.Debian file for a brief description of these terms. Setting this " #~ "variable will determine which image you will use by default on executing " #~ "'gcl@EXT@'. You can locally override this choice by setting the GCL_ANSI " #~ "environment variable to any non-empty string for the ANSI build, and to " #~ "the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The " #~ "flavor of the build in force will be reported in the initial startup " #~ "banner." #~ msgstr "" #~ "Estase a traballar para que GCL forneza unha imaxe ANSI ademáis da imaxe " #~ "CLtL1 que aínda se emprega en produción. Consulte o ficheiro README." #~ "Debian para ver unha descrición breve deses termos. Ao estabrecer esa " #~ "variable ha determinar a imaxe que ha empregar por defecto ao executar " #~ "\"gcl@EXT@\". Pode empregar a outra imaxe estabrecendo a variable de " #~ "ambiente GCL_ANSI a calquera cadea non baleira para empregar a versión " #~ "ANSI, e á cadea baleira para empregar a versión CLtL1; por exemplo, " #~ "GCL_ANSI=t gcl@EXT@. Hase informar da versión en uso no cartel que " #~ "aparece ao iniciar o programa." #~ msgid "" #~ "GCL now has optional support for profiling via gprof. Please see the " #~ "documentation for si::gprof-start and si::gprof-quit for details. As this " #~ "build is slower than builds without gprof support, it is not recommended " #~ "for final production use. You can locally override the default choice " #~ "made here by setting the GCL_PROF environment variable to any non-empty " #~ "string for profiling support, and to the empty string for the more " #~ "optimized builds, e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, " #~ "this will be reported in the initial startup banner." #~ msgstr "" #~ "GCL agora ten soporte opcional de cronometrado mediante gprof. Consulte a " #~ "documentación de si::gprof-start e si::gprof-quit para máis detalles. Xa " #~ "que esta versión é máis lenta que as que non teñen soporte de gprof, non " #~ "se recomenda que a empregue para o uso en produción. Pode empregar unha " #~ "versión distinta á seleccionada estabrecendo a variable de ambiente " #~ "GCL_PROF a calquera cadea non baleira para empregar o soporte de " #~ "cronometrado, ou á cadea baleira para as versións máis optimizadas; por " #~ "exemplo, GCL_PROF=t gcl@EXT@. Se está activado o cronometrado, hase " #~ "informar diso no cartel que aparece ao iniciar o programa." gcl/debian/po/it.po000066400000000000000000000073451242227143400144510ustar00rootroot00000000000000# ITALIAN TRANSLATION OF GCL'S PO-DEBCONF FILE. # COPYRIGHT (C) 2009 THE GCL'S COPYRIGHT HOLDER # This file is distributed under the same license as the gcl package. # # Vincenzo Campanella , 2009. # msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2009-11-29 08:39+0100\n" "Last-Translator: Vincenzo Campanella \n" "Language-Team: Italian \n" "Language: it\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "" "Usare in modo predefinito la compilazione ANSI, che è in fase di " "approntamento?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "Accanto all'immagine tradizionale CLtL1, in uso in realtà produttive, GCL " "sta preparando un'immagine conforme ad ANSI." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Per maggiori informazioni consultare il file «README.Debian». La scelta di " "questa opzione determinerà quale immagine verrà utilizzata in modo " "predefinito durante l'esecuzione di «gcl@EXT@»." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Questa impostazione può essere sovrascritta impostando la variabile " "d'ambiente «GCL_ANSI» con una stringa non vuota per la compilazione ANSI e " "con una stringa vuota per la compilazione CLtL1, per esempio: «GCL_ANSI=t " "gcl@EXT@». Il tipo di compilazione attualmente in uso viene mostrato nella " "schermata di avvio." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Usare il profiling in modo predefinito?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL possiede un supporto opzionale per il profiling tramite gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Per maggiori dettagli consultare la documentazione per «si::gprof-start» e " "«si::gprof-quit». Poiché questa compilazione è più lenta, rispetto a quella " "senza supporto per gprof, non è raccomandata per un utilizzo in realtà " "produttive." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Per compilazioni ottimizzate impostare la variabile d'ambiente «GCL_PROF» a " "una stringa vuota, oppure per impostare il supporto al profiling impostarla " "a una stringa non vuota, per esempio «GCL_PROF=t gcl@EXT@». La schermata " "d'avvio indicherà se il profiling è abilitato." gcl/debian/po/ja.po000066400000000000000000000074771242227143400144350ustar00rootroot00000000000000# SOME DESCRIPTIVE TITLE. # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the gcl package. # victory , 2013. # msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2013-07-27 14:28+0000\n" "PO-Revision-Date: 2013-07-27 23:28+0900\n" "Last-Translator: victory \n" "Language-Team: Japanese \n" "Language: ja\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "未完æˆã® ANSI ビルドをデフォルトã§ä½¿ç”¨ã—ã¾ã™ã‹?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL ã¯æœªã ã«ç”Ÿç”£åˆ©ç”¨ã•ã‚Œã¦ã„る従æ¥ã® CLtL1 イメージã«åŠ ãˆã¦ ANSI 準拠ã®ã‚¤ãƒ¡ãƒ¼" "ジをæä¾›ã™ã‚‹éŽç¨‹ã«ã‚ã‚Šã¾ã™ã€‚" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "用語ã«ã¤ã„ã¦ã¯ README.Debian ファイルã«ç°¡å˜ãªèª¬æ˜ŽãŒã‚ã‚Šã¾ã™ã€‚ã“ã®ã‚ªãƒ—ションã®" "é¸æŠžã€Œgcl@EXT@ã€ã‚’実行ã™ã‚‹ã¨ãã«ã©ã®ã‚¤ãƒ¡ãƒ¼ã‚¸ã‚’デフォルトã§åˆ©ç”¨ã™ã‚‹ã®ã‹æ±ºå®šã™ã‚‹" "ã“ã¨ã«ãªã‚Šã¾ã™ã€‚" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "ã“ã®è¨­å®šã¯ã€GCL_ANSI 環境変数㫠ANSI ビルドã§ã¯ç©ºç™½ã§ã¯ãªã„ä»»æ„ã®æ–‡å­—列ã€" "CLtL1 ビルドã§ã¯ç©ºç™½æ–‡å­—列をセットã™ã‚‹ã“ã¨ã§ä¸Šæ›¸ãã§ãã¾ã™ã€‚例ãˆã° GCL_ANSI=t " "gcl@EXT@。ç¾åœ¨å®Ÿè¡Œã—ã¦ã„るビルドã®ç¨®é¡žã¯åˆæœŸã®é–‹å§‹æ™‚ãƒãƒŠãƒ¼ã§å ±å‘Šã•ã‚Œã¾ã™ã€‚" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "デフォルト㧠profiling ビルドを使ã„ã¾ã™ã‹?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "" "GCL ã«ã¯ã‚ªãƒ—ション㧠gprof 経由㮠profiling サãƒãƒ¼ãƒˆãŒã‚ã‚Šã¾ã™ã€‚" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "詳細ã«ã¤ã„ã¦ã¯ si::gprof-start ã‚„ si::gprof-quit ã®æ–‡æ›¸ã‚’見ã¦ãã ã•ã„。ã“ã®ãƒ“" "ルド㯠gprof サãƒãƒ¼ãƒˆã®ãªã„ビルドよりé…ã„ãŸã‚ã€æœ€çµ‚çš„ãªç”Ÿç”£åˆ©ç”¨ã«ã¯ãŠå‹§ã‚ã—ã¾" "ã›ã‚“。" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "ビルドをもã£ã¨æœ€é©åŒ–ã™ã‚‹å ´åˆã¯ GCL_PROF 環境変数ã«ç©ºç™½æ–‡å­—列をã€profiling をサ" "ãƒãƒ¼ãƒˆã•ã›ã‚‹å ´åˆã¯ç©ºç™½ã§ã¯ãªã„ä»»æ„ã®æ–‡å­—列をセットã—ã¦ãã ã•ã„。例ãˆã° GCL_" "PROF=t gcl@EXT@。profiling ãŒæœ‰åŠ¹ãªå ´åˆã€åˆæœŸã®é–‹å§‹æ™‚ãƒãƒŠãƒ¼ã§å ±å‘Šã•ã‚Œã¾ã™ã€‚" gcl/debian/po/nl.po000066400000000000000000000074001242227143400144360ustar00rootroot00000000000000# SOME DESCRIPTIVE TITLE. # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the PACKAGE package. # FIRST AUTHOR , YEAR. # msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-01-01 21:15+0100\n" "Last-Translator: Bart Cornelis \n" "Language-Team: debian-l10n-dutch \n" "Language: \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=utf-8\n" "Content-Transfer-Encoding: 8bit\n" "X-Poedit-Language: Dutch\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Wilt u standaard de in-ontwikkeling-zijnde ansi-compilatie gebruiken?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL is bezig om, aanvullend op het traditionele CLtL1-compilatie dat nog " "steeds in gebruik is, een aan ANSI voldoend compilatie te voorzien." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Meer informatie hierover vindt u in het bestand /usr/share/doc/gcl/README." "Debian . Deze optie bepaalt welk compilatie standaard gebruikt wordt wanneer " "u 'gcl@EXT@' uitvoert. " #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Deze instelling kan altijd overstegen worden door de omgevingsvariabele " "GCL_ANSI in te stellen op een niet-lege string om de ANSI-compilatie te " "bekomen, en op een lege string om de CLtL1-compilatie te bekomen (bv. " "GCL_ANSI=t gcl@EXT@). De momenteel afgedwongen compilatie-soort wordt " "weergegeven in de initiële opstartbanier." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "" "Wilt u standaard een compilatie met ondersteuning voor profilering gebruiken?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL heeft optionele ondersteuning voor profilering via gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Meer informatie vindt u in de documentatie voor si::gprof-start en si::gprof-" "quit . Aangezien compilaties met gprof-ondersteuning trager zijn dan deze " "zonder is dit niet aan te raden voor productie-gebruik." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Om een geoptimaliseerde compilatie te verkrijgen stelt u de " "omgevingsvariabele GCL_PROF in op een lege string, of op een niet-lege " "string als u profilering wilt ondersteunen (bv. GCL_PROF=t gcl@EXT@). Als " "profilering geactiveerd is wordt dit weergegeven in de initiële " "opstartbanier ." gcl/debian/po/pt.po000066400000000000000000000074301242227143400144530ustar00rootroot00000000000000# translation of gcl debconf to Portuguese # Copyright (C) 2007 Américo Monteiro # This file is distributed under the same license as the gcl package. # # Américo Monteiro , 2007. msgid "" msgstr "" "Project-Id-Version: gcl 2.6.7-36\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2007-12-23 16:44+0000\n" "Last-Translator: Américo Monteiro \n" "Language-Team: Portuguese \n" "Language: pt\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "X-Generator: KBabel 1.11.4\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Usar a compilação 'ainda em desenvolvimento' ANSI por prédefinição? " #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL está no processo de disponibilizar uma imagem compatível com ANSI como " "adição à sua imagem tradicional CLtL1 ainda em utilização de produção." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Por favor veja o ficheiro README.Debian para uma breve descrição destes " "termos. Escolher esta opção irá determinar qual imagem será usada por " "prédefinição ao executar 'gcl@EXT@'." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Esta opção pode ser sobreposta ao regular a variável de ambiente GCL_ANSI " "para qualquer string não-vazia para a compilação ANSI, e para uma string " "vazia para a compilação CLtL1, como por exemplo GCL_ANSI=t gcl@EXT@. O tipo " "de compilação actualmente imposto será reportado no banner inicial de " "arranque." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Usar, como pré-definição, a compilação com 'profiling'?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "O GCL tem suporte opcional para 'profiling' via gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Por favor veja a documentação de si::gprof-start e si::gprof-quit para mais " "detalhes. Como esta compilação é mais lenta do que as compilações sem o " "suporte para gprof, não é recomendada para utilização de produção final." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Regule a variável de ambiente GCL_PROF para uma string vazia para mais " "compilações optimizadas, ou para qualquer string não-vazia para suporte de " "'profiling'; como por exemplo GCL_PROF=t gcl@EXT@. Se o 'profiling' estiver " "activo, isto será reportado no banner inicial de arranque." gcl/debian/po/ru.po000066400000000000000000000107721242227143400144610ustar00rootroot00000000000000# translation of ru.po to Russian # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the PACKAGE package. # # Yuri Kozlov , 2008. msgid "" msgstr "" "Project-Id-Version: 2.6.7-36\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-01-03 10:22+0300\n" "Last-Translator: Yuri Kozlov \n" "Language-Team: Russian \n" "Language: ru\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "X-Generator: KBabel 1.11.4\n" "Plural-Forms: nplurals=3; plural=(n%10==1 && n%100!=11 ? 0 : n%10>=2 && n" "%10<=4 && (n%100<10 || n%100>=20) ? 1 : 2);\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "ИÑпользовать разрабатываемую ANSI Ñборку по умолчанию?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "Помимо обычного образа CLtL1, иÑпользуемого в повÑемеÑтной работе, GCL имеет " "практичеÑки готовый образ, ÑоответÑтвующий ANSI." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Краткое опиÑание приведено в файле README.Debian. Данным выбором " "определÑетÑÑ, какой из образов будет иÑпользован по умолчанию при выполнении " "'gcl@EXT@'." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Эта наÑтройка может быть переопределена уÑтановкой переменной Ð¾ÐºÑ€ÑƒÐ¶ÐµÐ½Ð¸Ñ " "GCL_ANSI в непуÑтое значение Ð´Ð»Ñ ANSI Ñборки, а пуÑтым значением выбираетÑÑ " "CLtL1 Ñборка, например GCL_ANSI=t gcl@EXT@. Текущий иÑпользуемый тип Ñборки " "будет показан при первом запуÑке." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "ИÑпользовать по умолчанию профилируемую Ñборку?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL поддерживает необÑзательное профилирование через gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Подробней об Ñтом Ñмотрите в документации на si::gprof-start и si::gprof-" "quit. Так как Ð´Ð°Ð½Ð½Ð°Ñ Ñборка работает медленнее чем без поддержки gprof, её " "не рекомендуетÑÑ Ð¸Ñпользовать в реальной работе." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Задание переменной Ð¾ÐºÑ€ÑƒÐ¶ÐµÐ½Ð¸Ñ GCL_PROF пуÑтого Ð·Ð½Ð°Ñ‡ÐµÐ½Ð¸Ñ Ð²ÐºÐ»ÑŽÑ‡Ð°ÐµÑ‚ более " "оптимизированную Ñборку, а любое непуÑтое -- поддержку профилированиÑ; " "например GCL_PROF=t gcl@EXT@. ЕÑли профилирование включено, то об Ñтом будет " "напиÑано при первом запуÑке." gcl/debian/po/sv.po000066400000000000000000000077641242227143400144720ustar00rootroot00000000000000# translation of gcl_2.6.7-36.1_sv.po to Swedish # Translators, if you are not familiar with the PO format, gettext # documentation is worth reading, especially sections dedicated to # this format, e.g. by running: # info -n '(gettext)PO Files' # info -n '(gettext)Header Entry' # Some information specific to po-debconf are available at # /usr/share/doc/po-debconf/README-trans # or http://www.debian.org/intl/l10n/po-debconf/README-trans # Developers do not need to manually edit POT or PO files. # # Martin Ågren , 2008. msgid "" msgstr "" "Project-Id-Version: gcl_2.6.7-36.1_sv\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-07-24 18:21+0200\n" "Last-Translator: Martin Ågren \n" "Language-Team: Swedish \n" "Language: sv\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=ISO-8859-1\n" "Content-Transfer-Encoding: 8bit\n" "X-Generator: KBabel 1.11.4\n" "Plural-Forms: nplurals=2; plural=(n != 1);\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Använd det ännu inte färdiga ANSI-bygget som standard?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL arbetar på att tillhandahålla en ANSI-godkänd bild förutom dess " "traditionella CLtL1-bild som fortfarande används i produktionsmiljön." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Se README.Debian-filen för en översiktlig beskrivning av dessa termer. När " "du väljer det här alternativet avgörs vilken bild som kommer användas som " "standard när 'gcl@EXT@' körs." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Denna inställning kan överskridas genom att sätta miljövariabeln GCL_ANSI " "till en icke-tom sträng för ANSI-bygget, och till den tomma strängen för " "CLtL1-bygget, t. ex. GCL_ANSI=t gcl@EXT@. Det bygge som för tillfället " "används kommer anges i uppstartsutskriften." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Använd profileringsbygget som standard?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL har valfritt stöd för profilering via gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Se dokumentationen för si::gprof-start och si::gprof-quit för detaljer. " "Eftersom detta bygge är långsammare än byggen utan stöd för gprof, " "rekommenderas det inte för slutlig användning i produktionsmiljö." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Sätt miljövariabeln GCL_PROF till den tomma strängen för mer optimiserade " "byggen, eller en icke-tom sträng för profileringsstöd; t. ex. GCL_PROF=t " "gcl@EXT@. Om profilering är aktiverad, kommer denna rapporteras i den " "ursprungliga uppstartsutskriften." gcl/debian/po/templates.pot000066400000000000000000000045161242227143400162140ustar00rootroot00000000000000# SOME DESCRIPTIVE TITLE. # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the PACKAGE package. # FIRST AUTHOR , YEAR. # #, fuzzy msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" "Language: \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=CHARSET\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" gcl/debian/po/vi.po000066400000000000000000000101141242227143400144370ustar00rootroot00000000000000# Vietnamese translation for GCL. # Copyright © 2007 Free Software Foundation, Inc. # Clytie Siddall , 2007 # msgid "" msgstr "" "Project-Id-Version: gcl 2.6.7-36\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-01-04 16:27+1030\n" "Last-Translator: Clytie Siddall \n" "Language-Team: Vietnamese \n" "Language: vi\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=1; plural=0;\n" "X-Generator: LocFactoryEditor 1.7b1\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Dùng bản xây dá»±ng Ä‘ang phát triển ANSI theo mặc định không?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL Ä‘ang phát triển chức năng cung cấp ảnh tùy theo ANSI thêm vào ảnh CLtL1 " "truyá»n thống vẫn còn được sá»­ dụng trong trÆ°á»ng hợp sản xuất." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Xem tài liệu Äá»c Äi (README.Debian) để tìm mô tả ngắn vá» các thuật ngữ này. " "Bật tùy chá»n này thì xác định ảnh nào cần dùng theo mặc định khi thá»±c hiện " "lệnh « gcl@EXT@ »." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Vẫn còn có thể ghi đè lên thiết lập này bằng cách đặt biến môi trÆ°á»ng « " "GCL_ANSI » thành bắt cứ chuá»—i không rá»—ng cho bản xây dá»±ng ANSI, và cho chuá»—i " "rá»—ng cho bản xây dá»±ng CLtL1, v.d. « GCL_ANSI=t gcl@EXT@ ». Kiểu bản xây dá»±ng " "hiện thá»i được chá»n sẽ được thông báo trên băng cá» khởi chạy đầu tiên." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Dùng bản xây dá»±ng Ä‘o hiệu năng sá»­ dụng theo mặc định không?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL có há»— trợ tùy chá»n để Ä‘o hiệu năng sá»­ dụng thông qua gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Xem tài liệu hÆ°á»›ng dẫn vỠ« si::gprof-start » và « si::gprof-quit » để tìm " "chi tiết. Vì bản xây dá»±ng này chạy chậm hÆ¡n các bản xây dá»±ng không há»— trợ " "gprof, không khuyên bạn sá»­ dụng nó trong trÆ°á»ng hợp sản xuất cuối cùng." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Äặt biến môi trÆ°á»ng « GCL_PROF » thành chuá»—i rá»—ng cho các bản xây dá»±ng tối " "Æ°u hÆ¡n, hoặc cho bất cứ chuá»—i không rá»—ng nào để há»— trợ chức năng Ä‘o hiệu " "năng sá»­ dụng, v.d. « GCL_PROF=t gcl@EXT@ ». Hiệu lá»±c chức năng Ä‘o hiệu năng " "sá»­ dụng thì nó được thông báo trên băng cá» khởi chạy đầu tiên." gcl/debian/rules000077500000000000000000000166351242227143400141410ustar00rootroot00000000000000#!/usr/bin/make -f # Sample debian/rules that uses debhelper. # GNU copyright 1997 by Joey Hess. # # This version is for a hypothetical package that builds an # architecture-dependant package, as well as an architecture-independent # package. # Uncomment this to turn on verbose mode. #export DH_VERBOSE=1 # This is the debhelper compatability version to use. ARCHT:=$(shell dpkg-architecture -qDEB_HOST_ARCH) MCC:=gcc # ifeq ($(ARCHT),alpha) # MCC:=gcc-4.6 # endif # ifeq ($(ARCHT),mips) # MCC:=gcc-4.6 # endif # ifeq ($(ARCHT),mipsel) # MCC:=gcc-4.6 # endif # ifeq ($(ARCHT),ia64) # MCC:=gcc-4.6 # endif # ifeq ($(ARCHT),armel) # MCC:=gcc-4.6 # endif # ifeq ($(ARCHT),armhf) # MCC:=gcc-4.6 # endif #RELOC=locbfd #RELOC?=statsysbfd RELOC?=custreloc ifeq ($(ARCHT),ia64) RELOC=dlopen endif # ifeq ($(ARCHT),ppc64) # RELOC=dlopen # endif #ifeq ($(ARCHT),hppa) #RELOC=dlopen #endif GMP?= DEBUG= #ifeq ($(ARCHT),hppa) #DEBUG=--enable-debug #endif VERS=$(shell echo $$(cat majvers).$$(cat minvers)) #EXT:=cvs CFG:=$(addsuffix /config.,.)# gmp4/configfsf. # Bug in autoconf dependency on emacsen-common workaround #CFGS:=$(addsuffix .ori,configure $(addsuffix guess,$(CFG)) $(addsuffix sub,$(CFG))) CFGS:=$(addsuffix .ori,$(addsuffix guess,$(CFG)) $(addsuffix sub,$(CFG))) $(filter %.guess.ori,$(CFGS)): %.ori: /usr/share/misc/config.guess % ! [ -e $* ] || [ -e $@ ] || cp $* $@ [ $$($< -t | tr -d '-') -le $$(./$* -t | tr -d '-') ] || cp $< $* touch $@ $(filter %.sub.ori,$(CFGS)): %.ori: /usr/share/misc/config.sub % ! [ -e $* ] || [ -e $@ ] || cp $* $@ [ $$($< -t | tr -d '-') -le $$(./$* -t | tr -d '-') ] || cp $< $* touch $@ configure.ori: %.ori: configure.in ! [ -e $* ] || [ -e $@ ] || cp $* $@ cd $(@D) && autoconf touch $@ configure-%-stamp: $(CFGS) dh_testdir ! [ -e unixport/saved_pre_gcl ] || $(MAKE) clean # chmod -R +x gmp4/* [ "$*" != "ansi" ] || FLAGS="--enable-ansi" ; \ [ "$*" != "gprof" ] || FLAGS="--enable-gprof" ; \ [ "$*" != "ansi-gprof" ] || FLAGS="--enable-ansi --enable-gprof" ; \ eval `dpkg-buildflags --export=sh |sed -e 's,-O2,,g' -e 's,-g,,g'` && CC=$(MCC) ./configure \ --host=$$(dpkg-architecture -qDEB_HOST_GNU_TYPE) \ --disable-statsysbfd \ --disable-custreloc \ --disable-dlopen \ --enable-prelink \ --enable-$(RELOC) \ $(GMP) \ $(DEBUG) \ $$FLAGS \ --prefix=/usr \ --mandir=\$${prefix}/share/man \ --enable-infodir=\$${prefix}/share/info \ --enable-emacsdir=\$${prefix}/share/emacs/site-lisp touch $@ build-%-stamp: configure-%-stamp dh_testdir $(MAKE) rm -rf debian/$* mkdir -p debian/$* $(MAKE) install DESTDIR=$$(pwd)/debian/$* [ "$(findstring gprof,$*)" = "" ] || (\ tmp=debian/$*; old=/usr/lib/gcl-$(VERS); new=$$old-prof;\ if [ "$(findstring ansi,$*)" = "" ] ; then i=saved_gcl ; else i=saved_ansi_gcl ; fi;\ mv $$tmp/$$old $$tmp/$$new ;\ echo "(reset-sys-paths \"$$new/\")(si::save-system \"debian/tmp-image\")" | $$tmp/$$new/unixport/$$i &&\ mv debian/tmp-image $$tmp/$$new/unixport/$$i;) touch $@ bclean-stamp: $(MAKE) clean touch $@ ansi-tests/test_results: build-ansi-stamp $(MAKE) $@ build: build-arch build-indep build-arch: build-stamp build-indep: build-stamp build-stamp: build-gprof-stamp build-ansi-gprof-stamp build-trad-stamp build-ansi-stamp ansi-tests/test_results touch $@ debian/control.rm: rm -f `echo $@ | sed 's,\.rm$$,,1'` debian/control: debian/control.rm cp debian/control.$(EXT) debian/control clean: debian/control debian/gcl.templates dh_testdir dh_testroot rm -f *stamp debconf-updatepo $(MAKE) clean dh_clean rm -rf debian/gprof debian/ansi-gprof debian/trad debian/ansi $(INS) debian/substvars debian.upstream rm -rf *stamp for i in $(CFGS) ; do ! [ -e $$i ] || mv $$i $${i%.ori} ; done INS:=$(shell for i in debian/in.* ; do echo $$i | sed 's,in.,,1' ; done |sed "s,gcl,gcl$(EXT),g") $(INS): debian/gcl$(EXT)% : debian/in.gcl% cat $< | sed 's,@EXT@,$(EXT),g' >$@ install: install-stamp install-stamp: build-stamp debian/control $(INS) dh_testdir dh_testroot dh_clean -k dh_installdirs mkdir -p debian/tmp cp -a debian/ansi/* debian/tmp/ cp -a debian/trad/* debian/tmp/ cp -a debian/gprof/* debian/tmp/ cp -a debian/ansi-gprof/* debian/tmp/ mv debian/tmp/usr/share/emacs/site-lisp debian/tmp/usr/share/emacs/foo mkdir -p debian/tmp/usr/share/emacs/site-lisp mv debian/tmp/usr/share/emacs/foo debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT) cat debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/gcl.el |\ sed "s,(provide 'gcl),(provide 'gcl$(EXT)),1" >tmp &&\ mv tmp debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/gcl$(EXT).el [ "$(EXT)" = "" ] || rm debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/gcl.el cat debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/dbl.el |\ sed "s,(provide 'dbl),(provide 'dbl$(EXT)),1" >tmp &&\ mv tmp debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/dbl$(EXT).el [ "$(EXT)" = "" ] || rm debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/dbl.el [ "$(EXT)" = "" ] || \ for i in debian/tmp/usr/share/info/*.info*; do \ mv $$i $$(echo $$i | sed "s,gcl,gcl$(EXT),g"); done mv debian/tmp/usr/share/doc debian/tmp/usr/share/foo mkdir -p debian/tmp/usr/share/doc/gcl-doc mv debian/tmp/usr/share/foo/* debian/tmp/usr/share/doc/gcl-doc rmdir debian/tmp/usr/share/foo [ "$(EXT)" = "" ] || \ mv debian/tmp/usr/share/doc/gcl-doc debian/tmp/usr/share/doc/gcl$(EXT)-doc [ "$(EXT)" = "" ] || \ (cat debian/tmp/usr/share/man/man1/gcl.1 |sed -e 's, gcl , gcl$(EXT) ,g' 's, GCL , GCL$(EXT) ,g' >debian/foo && \ mv debian/foo debian/tmp/usr/share/man/man1/gcl$(EXT).1) cat debian/tmp/usr/lib/gcl-$(VERS)/gcl-tk/demos/index.lsp | \ sed "s,$$(pwd)/debian/tmp,,1" >debian/foo mv debian/foo debian/tmp/usr/lib/gcl-$(VERS)/gcl-tk/demos/index.lsp rm -f debian/tmp/usr/bin/*.exe debian/tmp/usr/bin/*.bat find debian/tmp -type f -name "*.lsp" -exec chmod ugo-x {} \; find debian/tmp -type f -name "*.lisp" -exec chmod ugo-x {} \; find debian/tmp -type f -name "*.el" -exec chmod ugo-x {} \; find debian/tmp -type f -name "*.tcl" -exec chmod ugo-x {} \; rm -f debian/tmp/usr/bin/gcl TKVERS=$$(cat bin/gcl | grep /tk | head -1l | sed "s,.*/tk\([0-9.]*\)\").*,\1,1"); \ cat debian/gcl.sh | sed -e "s,@EXT@,$(EXT),g" \ -e "s,@VERS@,$(VERS),g" \ -e "s,@TKVERS@,$$TKVERS,g" >debian/tmp/usr/bin/gcl$(EXT) chmod 0755 debian/tmp/usr/bin/gcl$(EXT) rm -rf debian/tmp/usr/lib/gcl-$(VERS)/info dh_install touch $@ # Build architecture-independent files here. # Pass -i to all debhelper commands in this target to reduce clutter. binary-indep: build install dh_testdir -i dh_testroot -i dh_installdocs -i dh_installinfo -i dh_installchangelogs ChangeLog -i dh_link -i dh_compress -i dh_fixperms -i dh_installdeb -i dh_gencontrol -i dh_md5sums -i dh_builddeb -i binary-arch: build install #debian/substvars dh_testdir -a dh_testroot -a dh_installdocs -a -XRELEASE-2.6.2.html dh_installemacsen -a dh_installman -a dh_installdebconf -a sed -i -e 's,@EXT@,$(EXT),g' debian/gcl$(EXT)/DEBIAN/templates dh_installchangelogs ChangeLog -a dh_strip -a -Xlibgcl -Xlibansi_gcl \ -Xgcl-$(VERS)-prof/unixport/saved_gcl -Xgcl-$(VERS)-prof/unixport/saved_ansi_gcl dh_lintian -a dh_link -a dh_compress -a dh_fixperms -a dh_installdeb -a dh_shlibdeps -a dh_gencontrol -a -u"-Vgcc=$(MCC)" dh_md5sums -a dh_builddeb -a binary: binary-indep binary-arch .PHONY: build clean binary-indep binary-arch binary install configure .PRECIOUS: configure-trad-stamp configure-ansi-stamp configure-gprof-stamp configure-ansi-gprof-stamp gcl/debian/source/000077500000000000000000000000001242227143400143465ustar00rootroot00000000000000gcl/debian/source/format000066400000000000000000000000141242227143400155540ustar00rootroot000000000000003.0 (quilt) gcl/debian/source/include-binaries000066400000000000000000000000611242227143400175030ustar00rootroot00000000000000info/gcl-si.pdf info/gcl-tk.pdf xgcl-2/dwdoc.pdf gcl/debian/texi.awk000077500000000000000000000004751242227143400145340ustar00rootroot00000000000000#!/usr/bin/awk -f /^@defun/ { a=split($0,A,"("); b=split($0,B,")"); if (a==b) print ; else { i=1; c=$0; } next; } { if (i) { sub("^ *",""); c=c " " $0; a=split(c,A,"("); b=split(c,B,")"); if (a==b) { print c; c=""; i=0; } } else print; } gcl/debian/upstream/000077500000000000000000000000001242227143400147065ustar00rootroot00000000000000gcl/debian/upstream/signing-key.asc000066400000000000000000000125501242227143400176250ustar00rootroot00000000000000-----BEGIN PGP PUBLIC KEY BLOCK----- Version: GnuPG v1 mQGiBD1mWk0RBADdQYIiaNJJOHAZdBpzOBm31v5AlQa1jjYx1W6zKd+ECqZVdonw e+CP/qpVCUXRYmQ3v/ZYpINtcRR2IckTQCs4fvYUAuQir2cpKmRqImnGhzFJ1pd9 Rf2aqPspycMx9IlqKkeY1LwNahitQ93YwyCT1HUCTB0hIuNMtFNte18DpwCgwbYP bBuLYCG/8g+MqoG7SBhN4hkEANafxrX2EEwUCpQlKGkw4P18wCinbs7tjgXwL7SK WV9qpIDkUEnW2cnzfDBrNW24LtHt0qMsGa8sCJW30ZPUv0sebsyzVTJR0O5g6Lpi zlznB1LtmbkDdd79R4Qrs01k+2OK2K0r54xnOlL+ZZQFamP3jvTZAKxyUGI2Fiqu 1O7OA/4xp5/WNyuIUWUho+nfhp0sakzAiC1aBHLtAvhL470sBm3xojM6w3vicTT2 7rnzS1teeUnCOMK+CUzzITXHrnljCkyg8d6QqtlWJCc4T6tTYJNOuWte3AckYDaF 4HhJbwNamrDGKQJ0kYOqtquz5WE8EjkxwglRQSrGanxMXnCsB7QgQ2FtbSBNYWd1 aXJlIDxjYW1tQGVuaGFuY2VkLmNvbT6IXwQTEQIAFwUCPWZaTQULBwoDBAMVAwID FgIBAheAABIJEHMxtcBX8EXcB2VHUEcAAQFCkQCeL84DKju0u23VHI2a9S3CZwpw cEMAn03Jgjje37YEbLCnfh/JN4zhcUeFiQCVAwUQPXktv1RjAAQhp2rpAQEynwP5 AZT5Fmlc6FbnVeusUNz1jtEKysdFc7TBFZSdWK2ftjuQiiiYgLOSM6kLpc6DJxLU 0gc6FmQCme1G3wnQFpi5GXFlYcW5mfe3V5/0Paxcc/CijULb4IRU41KO3tTy7wpY NARRB5I+MeLT39bpqljO0b7PRETncVnXgkm5PEJGV3C0HkNhbW0gTWFndWlyZSA8 Y2FtbUBkZWJpYW4ub3JnPohgBBMRAgAgBQJJmevSAhsjBgsJCAcDAgQVAggDBBYC AwECHgECF4AACgkQczG1wFfwRdxZywCeLfMYW3CQAi8e0C8NAauuIpZJx+wAoJAW eBe0arj/lrwecpn26l63nC5KuQENBD1mWk4QBADRBvXyQ0uxFCkac7ZVSuwEJrbw NdhS3ossQi+gm8aDPSokKFASs75SLNQMfIRhyToGcyplP75OYaMxvyih7DFGBLoB kzCuhBJ09VgLC0BiuJAtEI5orQf9sNt7CwBEG2KZ/X4oHXmKitgP0F4xff9XociT ZusPI90z9yg2treJ4wADBQP/aDZ839IYpwL6ZDZ8faVtgMz65lKaFkLzi/2pHWao SEWYiGcLozizNt+w+qcyMGUDNkDMtTY0Y9cbC8Dn7r/0/CZW1UQ2D3fSeAfsgxEE PnYYFiFr0Xyi+oDu7fkcV9wQdqLZ6OvR0SZqoJwLdmJqjTzz1TJTOfdTcSV/+POJ qCuITgQYEQIABgUCPWZaTgASCRBzMbXAV/BF3AdlR1BHAAEBn/kAn2saGr0hmMfO Nn4j36onyp18oNqYAKCTJZU26kWZcORo+FbyOMQ3+Yd8EZkBogQ6A9NcEQQAiUvw 61oHv/VZvl8uo5hTAaka2HEfECf5aMvG7N1ytUXzKTldnyEBGiqOdbLtF1wL2SUV rdhX0VhH0fi19K2graTGqSQYzdA7uIIOQHOAZ5py5mKQr9zFkKyf5W4RKAbTIUAS uTlSy1NiyKPMXdBlu0f5rkl/m5KODlf1nVtDposAoPuMTY9/D/cOqzB4fmEQ6gMG M2/PA/9nHj4Mow5EkvSLsuAkn/mpI0Rv+ly1pmKJtbsJZIs1PWk/J47TRVigUgft LOlfYMAHXwfF6svodOKF0eOaBjeZmyu1KnDDy9EWWhZwdoT08AD664/bbN1goNzE XFlfD83yPWa1VrPNME2fq6jdY/WKZB5+viKu7yaMGGwQfjg9EwP/QCbz4cZvUiF5 SmlI3u8+wgThk3DXnL9L3GlOASacET6wRFX6C3HYnRBTB0EypYJoUPIj7rt/Ptyl CRHQtMUuSouyq/Smj5ybw8kvGRRH4SgfoghjL+q+sVGwIZiUQXu+g96vSSBuQTE2 x8iZ8mXpPud7jjMc98CfjiB9/ujnqK+0MEVyaWMgU2hhcmtleSA8c2hhcmtleUBz dXBlcmsucGh5c2ljcy5zdW55c2IuZWR1PohfBBMRAgAXBQI6A9NcBQsHCgMEAxUD AgMWAgECF4AAEgkQclUlAyIk+rwHZUdQRwABAcGdAJ45RrdVItJxXhDiCWeXpHKq DfkBIQCg97TpqcIbuDGD1r8gkSb6ErXA+4SJAJUDBRA6L65Bj/xAXv1aZ80BAVlU A/oD8wBcQeTD3HzeBcK6SVygQZlQS2g8v7H4G91Fu9yTESbDdYLjmybniGwTgS7q 0/RbQDRCmh+fyBD38CmB2B23VdpXRYaChDeKTP+Lvg+mQn9zdMFkERD2/W40+TID 1g7lafk3XDe+dOX59Ie0qeCXcccsv8OfhJwoEwHKPC9ZeIhGBBARAgAGBQI87l/I AAoJEHIxQb2lt4IBM5MAnj9wqSGdaLTfHAQb7xk36abh0vboAJwIGkIMfE7HkvbX 9nXqefmNfrns3IhGBBARAgAGBQI9eSPnAAoJEHMxtcBX8EXcnq8An2DneOdg2qBr xF5ZBzEfGBcZHMbCAJ0Z+QKVo1/XQUVcHbGrHo+kF4IfmrQhRXJpYyBTaGFya2V5 IDxzaGFya2V5QGRlYmlhbi5vcmc+iF8EExECABcFAjo5dzoFCwcKAwQDFQMCAxYC AQIXgAASCRByVSUDIiT6vAdlR1BHAAEBo0MAoKXjeu7EYrx9uSrlC6rQHavvmq1u AJsFXSfzM+lgT5lO9a3K0/N+Wr4ZRIhGBBARAgAGBQI87l/fAAoJEHIxQb2lt4IB 8BgAn3ZJz4t/JBnRhEB2I0BA5CiIxKtAAKCf5FHs+3/1vYmhtAX3ouSWyN0jFIhG BBARAgAGBQI9eSPtAAoJEHMxtcBX8EXci7YAnRnwG8BddR4vdcvNGewRxCxweOrz AKCgcm8lYWrd0Ubz4/CtelbxA16yV7kBDQQ6A9NrEAQAyXOKw6Zg+VjOiw10ZKtP mQNmkEA5qUcGgcXKIPwwZ8sMZLzsqzdSM6UVwlN/1D/kH9U5Lkh1LqUxQ+NVC5Qm bGV+Wq52I9id/lpYycfxNkjURk/wXnOdFCY55pJiS2851DiCBpNC/ClFZZe1Yhdd HhUFnJrGRjaKTMoKI3sWUDsAAwYEAIuBP5eMx8I4qzVrt9tgDEx9LZZyd18jqC42 FcMesLMdUi/UKOzrSr/tQ/eiOVMai/RUMmtoyvJzm6bt4UsO54Ynhhul4ySreB4h 4TA7C9vKYTvPmZ5hsOAmguhtvkGOiN+7cXUa35xpL1dbBjelJR8cSFJtAQn2PKkJ JeS6N4LHiE4EGBECAAYFAjoD02sAEgkQclUlAyIk+rwHZUdQRwABAS1yAJwO6YAP f1tU5MvrXRbHC52/dn82kgCgkxPi+HiFgqOc1FCfMByu9ZvzwGaZAaIEPKkVqhEE AMqWl8BYusXdZEt7EE7gDfTtYgCCREiy3B2jTERJ4DXP0hPQDxBOQh6AW0JCtcxT vuNOZnAlMqXKPvV4tc55dSYTBYW6U2ySN+xrHi9GvS9k5JjpsZdstS5MVkTppOS0 nTEBw8KofAHBfFpwisCsz38P5ehLnbpm1M7WNXGxmvDTAKDFxuwQL9S8gRUhXIS3 kAOkDW2eTwP+I5Xil4aIAUnw/JVUaP7wRGUYnFnIisgPftZ+k+R/RfirSlnpPMZr cqC8JpR0Zm2jQ7jSzTdjj4yFM0PTdUg3mUo5IANd31XshDO7utppX8QBQ9c9PYml PSVZTRLiDT50HB4rjsoLTlYQOMsFxG4v9v6ybKCvhmZRvD1J97Q5EEsD/3V+Kor5 8j72RZwrjTspT7roljxyly5D/p6dqiNFLOHjjfuj3SYah7TAlAxtb7CFGsPdNJJf jZvb//IzZw7XNG1EU9+PaV6mbTZNbrXavbKrIkz6AnLB9GDFE1oDWv7c2b5v5HVv SO/hakFEDcgxSPzkMVkc7wGOq+6kClG8z2DMtC1CcmlhbiBSIEZ1cnJ5IChUcnVz dCBObyBPbmUpIDxmYnJpYW5AbmFjLm5ldD6IZQQTEQIAHQUCPKkVqgUJBaOagAUL BwoDBAMVAwIDFgIBAheAABIJEHIxQb2lt4IBB2VHUEcAAQHvmwCfV6KEnp4tIKHz dZwBGsqnlKSBkpcAmgNdv300le8RtsGdhsDCRT6cUl1TiEYEEBECAAYFAjzqw3EA CgkQclUlAyIk+rw0sgCg6jCNQKL71DqAifPm6o07tkkYoc0An3duMoIdm9g2qV2d OSOpJn63WXKoiEYEEBECAAYFAj15JjIACgkQczG1wFfwRdyRHQCeK2xhxX1ccxDG DzMYZKivG5uUdBoAnRJ62vbPCyQ1I9ihAf1nzygCdxrytC1CcmlhbiBSIEZ1cnJ5 IChUcnVzdCBObyBPbmUpIDxiZnVycnlAbmFjLm5ldD6IZQQTEQIAHQUCPUsJiQUJ BaOagAULBwoDBAMVAwIDFgIBAheAABIJEHIxQb2lt4IBB2VHUEcAAQHzcACfeVya lc6NRe3Kle9aX9AXxljfdnUAniXqub/sS6WetxJwKrivk3WhyQnEiEYEEBECAAYF Aj15JjgACgkQczG1wFfwRdxRyACgv7su7KfZvI07M31IcMtS0PHL4L4AoL5wr/os n198CXGT8C5eXCRBVa8zuQENBDypFbgQBAC3VMeu+Qsa4IlZzzvFeB9sbnIr7e6P TWuTR3EUnOzEd/h5k/bDdLW11uDnXyhbMSOXzGJaB9HbW5NXUuHIzTEwDzP+/hSJ HNhc3YXREOs4YMrexeTgKEE3RFJ/ulTJ2EvTVdb7+uwKEMctKC+xaK/cIiRZt8Fg Da1KjYBnpr5DvwADBQP5AaCubKcP0z202ys6EuvY/xIgYxJ95x/ermkV91cur7e1 J9NqLOdbgj/yLcco9T92IBMm7zAnzDEtPC7UaqvrtuISvWc+z48Lk19AN7JOOH+g 2oIvspF4Gj2RVc7vijh7gMav5tIflZxqNi2U/QFYqgVTnE0facclV3w2IpMPUpyI VAQYEQIADAUCPKkVuAUJBaOagAASCRByMUG9pbeCAQdlR1BHAAEB+GUAn0etwV2m fUKduxyMlCzpoCtLBzy3AJ99bcVPGhgGkpMktMMRlLjPXiLgGA== =tBlv -----END PGP PUBLIC KEY BLOCK----- gcl/debian/watch000066400000000000000000000001631242227143400140770ustar00rootroot00000000000000version=2 options=pasv,pgpsigurlmangle=s/$/.sig/ ftp://ftp.gnu.org/pub/gnu/gcl gcl-([0-9.]*).tar.gz debian uupdate gcl/doc/000077500000000000000000000000001242227143400123715ustar00rootroot00000000000000gcl/doc/bignum000066400000000000000000000046661242227143400136110ustar00rootroot00000000000000 A directory mp was added to hold the new multi precision arithmetic code. The layout and a fair amount of code in the mp directory is an enhanced version of gpari version 34. The gpari c code was rewritten to be more efficient, and gcc assembler macros were added to allow inlining of operations not possible to do in C. On a 68K machine, this allows the C version to be as efficient as the very carefully written assembler in the gpari distribution. For the main machines, an assembler file (produced by gcc) based on this new method, is included. This is for sites which do not have gcc, or do not wish to compile the whole system with gcc. Bignum arithmetic is much faster now. Many changes were made to cmpnew also, to add 'integer' as a new type. It differs from variables of other types, in that storage is associated to each such variable, and assignments mean copying the storage. This allows a function which does a good deal of bignum arithmetic, to do very little consing in the heap. An example is the computation of PI-INV in scratchpad, which calculates the inverse of pi to a prescribed number of bits accuracy. That function is now about 20 times faster, and no longer causes garbage collection. In versions of AKCL where HAVE_ALLOCA is defined, the temporary storage growth is on the C stack, although this often not so critical (for example it makes virtually no difference in the PI-INV example, since in spite of the many operations, only one storage allocation takes place. Below is the actual code for PI-INV On a sun3/280 (cli.com) Here is the comparison of lucid and akcl before and after on that pi-inv. Times are in seconds with multiples of the akcl time in parentheses. On a sun3/280 (cli.com) pi-inv akcl-566 franz lucid old kcl/akcl ---------------------------------------- 10000 3.3 9.2(2.8 X) 15.3 (4.6X) 92.7 (29.5 X) 20000 12.7 31.0(2.4 X) 62.2 (4.9X) 580.0 (45.5 X) (defun pi-inv (bits &aux (m 0)) (declare (integer bits m)) (let* ((n (+ bits (integer-length bits) 11)) (tt (truncate (ash 1 n) 882)) (d (* 4 882 882)) (s 0)) (declare (integer s d tt n)) (do ((i 2 (+ i 2)) (j 1123 (+ j 21460))) ((zerop tt) (cons s (- (+ n 2)))) (declare (integer i j)) (setq s (+ s (* j tt)) m (- (* (- i 1) (- (* 2 i) 1) (- (* 2 i) 3))) tt (truncate (* m tt) (* d (the integer (expt i 3)))))))) gcl/doc/c-gc000066400000000000000000000025251242227143400131310ustar00rootroot00000000000000 We have implemented garbage collection of the c stack. Thus any new cons or other data type, may be safely left on the c stack or in a register, without fear of lossage due to garbage collection. This enables us to write smaller faster code. We have implemented a scheme for putting frequently used variables, and those inside loops, into registers. For example the compiled sloop.lsp file now has text size 48704, but had text size 53120 or 1.09 times larger. If functions are proclaimed to be of fixed number of args, the code is also substantially better. For example if you have the code: (proclaim '(function memb (t t) t)) (defun memb (a b) (sloop for v on b when (eq (car v) a) do (return v))) If we consider calls where a is the 4'th element of b, then memb runs two times faster than before: On a sun 3-50 19.6 seconds for 1,000,000 iterations, as opposed to 39.6 seconds without the new modifications to c-gc and the compiler. (defun try (n a b) (sloop for i below n do (memb a b))) Currently if the variable compiler::*c-gc* is not nil, the compiler outputs code under the assumption that c-gc is working. Very bad results would occur if such object code were loaded into a kcl which did not examine the c stack. Also if you are wishing to produce C code for use in an implementation without c-gc you should set *c-gc* to nil. gcl/doc/c-gc.doc000066400000000000000000000021641242227143400136740ustar00rootroot00000000000000 We have implemented garbage collection of the c stack. Thus any new cons or other data type, may be safely left on the c stack or in a register, without fear of lossage due to garbage collection. This enables us to write smaller faster code. We have implemented a scheme for putting frequently used variables, and those inside loops, into registers. For example the compiled sloop.lsp file now has text size 48704, but had text size 53120 or 1.09 times larger. If functions are proclaimed to be of fixed number of args, the code is also substantially better. For example if you have the code: (proclaim '(function memb (t t) t)) (defun memb (a b) (sloop for v on b when (eq (car v) a) do (return v))) If we consider calls where a is the 4'th element of b, then memb runs two times faster than before: On a sun 3-50 19.6 seconds for 1,000,000 iterations, as opposed to 39.6 seconds without the new modifications to c-gc and the compiler. (defun try (n a b) (sloop for i below n do (memb a b))) Currently if the variable compiler::*c-gc* is not nil, the compiler outputs code under the assumption that c-gc is working. gcl/doc/compile-file-handling-of-top-level-forms000066400000000000000000000236311242227143400221030ustar00rootroot00000000000000Forum: Compiler Issue: COMPILE-FILE-HANDLING-OF-TOP-LEVEL-FORMS References: CLtL pages 66-70, 143 Category: CLARIFICATION Edit history: V1, 07 Oct 1987 Sandra Loosemore V2, 15 Oct 1987 Sandra Loosemore V3, 15 Jan 1988 Sandra Loosemore V4, 06 May 1988 Sandra Loosemore V5, 20 May 1988 Sandra Loosemore V6, 09 Jun 1988 Sandra Loosemore V7, 16 Dec 1988 Sandra Loosemore (Comments from Pitman, change DEFCONSTANT, etc.) V8, 31 Dec 1988 Sandra Loosemore (CLOS additions, etc.) V9, 23 Jan 1989 Sandra Loosemore (remove the CLOS additions again) Status: Proposal CLARIFY passed Jan 89 Problem Description: Standard programming practices assume that, when calls to defining macros such as DEFMACRO and DEFVAR are processed by COMPILE-FILE, certain side-effects occur that affect how subsequent forms in the file are compiled. However, these side-effects are not mentioned in CLtL, except for a passing mention that macro definitions must be ``seen'' by the compiler before it can compile calls to those macros correctly. In order to write portable programs, users must know exactly which defining macros have compile-time side-effects and what those side-effects are. Inter-file compilation dependencies are distinct from, and not addressed by, this issue. Proposal: COMPILE-FILE-HANDLING-OF-TOP-LEVEL-FORMS:CLARIFY (1) Clarify that defining macros such as DEFMACRO or DEFVAR, appearing within a file being processed by COMPILE-FILE, normally have compile-time side effects which affect how subsequent forms in the same file are compiled. A convenient model for explaining how these side effects happen is that the defining macro expands into one or more EVAL-WHEN forms, and that the calls which cause the compile-time side effects to happen appear in the body of an (EVAL-WHEN (COMPILE) ...) form. (2) The affected defining macros and their specific side effects are as follows. In each case, it is identified what users must do to ensure that their programs are conforming, and what compilers must do in order to correctly process a conforming program. DEFTYPE: Users must ensure that the body of a DEFTYPE form is evaluable at compile time if the type is referenced in subsequent type declarations. The compiler must ensure that the DEFTYPE'd type specifier is recognized in subsequent type declarations. If the expansion of a type specifier is not defined fully at compile time (perhaps because it expands into an unknown type specifier or a SATISFIES of a named function that isn't defined in the compile-time environment), an implementation may ignore any references to this type in declarations and/or signal a warning. DEFMACRO, DEFINE-MODIFY-MACRO: The compiler must store macro definitions at compile time, so that occurrences of the macro later on in the file can be expanded correctly. Users must ensure that the body of the macro is evaluable at compile time if it is referenced within the file being compiled. DEFUN: DEFUN is not required to perform any compile-time side effects. In particular, DEFUN does not make the function definition available at compile time. An implementation may choose to store information about the function for the purposes of compile-time error-checking (such as checking the number of arguments on calls), or to enable the function to be expanded inline. DEFVAR, DEFPARAMETER: The compiler must recognize that the variables named by these forms have been proclaimed special. However, it must not evaluate the initial value form or SETQ the variable at compile time. DEFCONSTANT: The compiler must recognize that the symbol names a constant. An implementation may choose to evaluate the value-form at compile time, load time, or both. Therefore users must ensure that the value-form is evaluable at compile time (regardless of whether or not references to the constant appear in the file) and that it always evaluates to the same value. DEFSETF, DEFINE-SETF-METHOD: The compiler must make SETF methods available so that it may be used to expand calls to SETF later on in the file. Users must ensure that the body of DEFINE-SETF-METHOD and the complex form of DEFSETF are evaluable at compile time if the corresponding place is referred to in a subsequent SETF in the same file. The compiler must make these SETF methods available to compile-time calls to GET-SETF-METHOD when its environment argument is a value received as the &ENVIRONMENT parameter of a macro. DEFSTRUCT: The compiler must make the structure type name recognized as a valid type name in subsequent declarations (as for DEFTYPE) and make the structure slot accessors known to SETF. In addition, the compiler must save enough information about the structure type so that further DEFSTRUCT definitions can :INCLUDE a structure type defined earlier in the file being compiled. The functions which DEFSTRUCT generates are not defined in the compile time environment, although the compiler may save enough information about the functions to code subsequent calls inline. The #S reader syntax may or may not be available at compile time. DEFINE-CONDITION: The rules are essentially the same as those for DEFSTRUCT; the compiler must make the condition type recognizable as a valid type name, and it must be possible to reference the condition type as the parent-type of another condition type in a subsequent DEFINE-CONDITION in the file being compiled. DEFPACKAGE: All of the actions normally performed by this macro at load time must also be performed at compile time. (3) The compile-time side effects may cause information about the definition to be stored differently than if the defining macro had been processed in the "normal" way (either interpretively or by loading the compiled file). In particular, the information stored by the defining macros at compile time may or may not be available to the interpreter (either during or after compilation), or during subsequent calls to COMPILE or COMPILE-FILE. For example, the following code is nonportable because it assumes that the compiler stores the macro definition of FOO where it is available to the interpreter: (defmacro foo (x) `(car ,x)) (eval-when (eval compile load) (print (foo '(a b c)))) A portable way to do the same thing would be to include the macro definition inside the EVAL-WHEN: (eval-when (eval compile load) (defmacro foo (x) `(car ,x)) (print (foo '(a b c)))) Rationale: The proposal generally reflects standard programming practices. The primary purpose of the proposal is to make an explicit statement that CL supports the behavior that most programmers expect and many implementations already provide. The primary point of controversy on this issue has been the treatment of the initial value form by DEFCONSTANT, where there is considerable variance between implementations. The effect of the current wording is to legitimize all of the variants. Current Practice: Many (probably most) Common Lisp implementations, including VaxLisp and Lucid Lisp, are already largely in conformance. In VaxLisp, macro definitions that occur as a side effect of compiling a DEFMACRO form are available to the compiler (even on subsequent calls to COMPILE or COMPILE-FILE), but are not available to the interpreter (even within the file being compiled). By default, Kyoto Common Lisp evaluates *all* top level forms as they are compiled, which is clearly in violation of the behavior specified on p 69-70 of CLtL. There is a flag to disable the compile-time evaluation, but then macros such as DEFMACRO, DEFVAR, etc. do not make their definitions available at compile-time either. Cost to implementors: The intent of the proposal is specifically not to require the compiler to have special knowledge about each of these macros. In implementations whose compilers do not treat these macros as special forms, it should be fairly straightforward to use EVAL-WHENs in their expansions to obtain the desired compile-time side effects. Cost to users: Since CLtL does not specify whether and what compile-time side-effects happen, any user code which relies on them is, strictly speaking, nonportable. In practice, however, most programmers already expect most of the behavior described in this proposal and will not find it to be an incompatible change. Benefits: Adoption of the proposal will provide more definite guidelines on how to write programs that will compile correctly under all CL implementations. Discussion: Reaction to a preliminary version of this proposal on the common-lisp mailing list was overwhelmingly positive. More than one person responded with comments to the effect of "but doesn't CLtL already *say* that somewhere?!?" Others have since expressed a more lukewarm approval. It has been suggested that this proposal should also include PROCLAIM. However, since PROCLAIM is not a macro, its compile-time side effects cannot be handled using the EVAL-WHEN mechanism. A separate proposal seems more appropriate. Item (3) allows for significant deviations between implementations. While there is some sentiment to the effect that the compiler should store definitions in a manner identical to that of the interpreter, other people believe strongly that compiler side-effects should be completely invisible to the interpreter. The author is of the opinion that since this is a controversial issue, further attempts to restrict this behavior should be considered as separate proposals. It should be noted that user-written code-analysis programs must generally treat these defining macros as special forms and perform similar "compile-time" actions in order to correctly process conforming programs. gcl/doc/contributors000066400000000000000000000025661242227143400150620ustar00rootroot00000000000000 sgi port was done by Eric Raible raible@orville.nas.nasa.gov thanks to Blewett (blewett@cinnamon.att.com) for help in the initial stage of the sun4 port. Thanks to gabor@vuse.vanderbilt.edu for a good deal of work on the hp port. Thanks to riley@att.com for several suggestions, fixes and bug reports. Thanks to andrew@COMP.VUW.AC.NZ for several suggestions and help with hp bsd. Thanks to Doug Katzman for parts of the Iris 4D port. Thanks to pierson@encore.com for an encore port [which I unfortunately did not integrate yet]. Thanks for Mike Sundt at washington, for updates on the vax port. Thanks to Richard Harris harrisr@turing.cs.rpi.edu for many bug reports and fixes, as well as error handling code (available from him), and for work on pcl. Thanks to BABECOOL for the gpari code. gene@corwin.CCS.Northeastern.EDU (gene cooperman) several bugs and bug fixes. Thanks to luke tierney luke@umnstat.stat.umn.edu for a bug fix. tomwe@comm.mot.com (Thomas Weigert) for the mac2 port to aux. Thanks to Noritake Yonezawa for NeXT port (yone@vcdew25.lsi.tmg.nec.CO.JP) Thanks to Rami Charif rcharif@math.utexas.edu for much of the work on the dos port Thanks to Bob Boyer boyer@cs.utexas.edu for innumerable suggestions and encouragement Thanks to Matteo Frigo who did work on an early linux port. Thanks to Bill Metzenthen for linux elf work (billm@jacobi.maths.monash.edu.au) gcl/doc/debug000066400000000000000000000017121242227143400134030ustar00rootroot00000000000000New Debugging Features: Search-stack: (:s "cal") or (:s 'cal) searches the stack for a frame whose function or special form has a name containing "cal", moves there to display the local data. Break-locals: :bl displays the args and locals of the current function. (:bl 4) does this for 4 functions. (si:loc i) accesses the local(i): slot. the *print-level* and *print-depth* are bound to si::*debug-print-level* Recall that kcl permits movement to previous frame (:p) and next frame (:n). These also take numeric args eg. (:p 7) moves up 7 frames. If functions are interpreted, the arg values are displayed together with their names. If the functions are using the C stack (ie proclaimed functions), very little information is available. Note you must have space < 3 in your optimize proclamation, in order for the local variable names to be saved by the compiler. To Do: add setf method for si:loc. add restart capability from various spots on the stack. gcl/doc/enhancements000066400000000000000000000143431242227143400147710ustar00rootroot00000000000000 @chapter Loading Object Code We will outline some of the features of the object loader, by William Schelter. When you do @code{(load "foo.o")} the output from the C compiler, must be loaded into static space in the running KCL, and references to external symbols must be resolved. Originally KCL used the loader from the underlying lisp system, calling it in a subshell, to produce yet another file, which had the correct references to externals. This was then read into kcl. The data vector (a lisp readable vector at the end of the object file) was also read into KCL. Unfortunately some operating systems (such as System V) do not supply a loader capable of doing this relocation, and in any event it is fairly slow. Also there was no possiblity of incrementally adding new external C symbols to an already running lisp, and then having future files refer to them. For example you might have a function @code{search1} written in C, which you wished to access directly in subsequently loaded files. This was not possible since the loader only knew about the addresses of the external symbols in the original saved image. The new scheme builds a list of the external symbols into a table called @code{c_table}. This table is built by examining the current image. It will be built automatically with the first call to load. Subsequent calls just use this table. Of course there is the additional benefit, that it is easy to add additional symbols to the table. For example if you have a file @file{try.c} which looks like @code@{init_code() add_symbols(joe,&joe,pete,&pete,NULL); @} joe(x) object x @{...@} pete() @{...@} } then joe and pete will be added to the symbol table of the current kcl. You may refer to them as external variables in subsequent files, and these files will load correctly, referencing these variables. It is an error apply add_symbol twice, to the same variable. The loading of files has speeded up considerably, so that a small file with only a few small functions in it, can be loaded in less than .05 seconds. @chapter Metering and Profiling KCL utilities have been added, by W. Schelter, to allow one to determine the percentage of time spent in individual functions. Usage involves deciding which block of code one wishes to profile, that is to say what address range, and then allocating an appropriate size @code{*profile-array*}. For example in the Sun version, if you have loaded a few object files, then if you wish to meter all of kcl and the files which you loaded you could allocate a 1 megabyte array. This would give a roughly 2 to one reduction relative to the code address range. Note that the loader prints out the address at which code is loaded. There is also a function @code{si@:function-start (fun)} which returns the start address of a compiled function. In the above example after loading the file lsp/profile.o you could do @code{(si:set-up-profile 1000000)} This allocates the 1 megabyte array, and also reads in the c symbol table, if this has not already been done. It also gets the addresses of all compiled function objects currently in the image, and keeps them in a table. This table is called @code{combined_table} at the C level. The function @code{si:set-up-combined (size-of-table)} sets up a combined table for the lisp and C functions. This function is called by the previous @code{si:set-up-profile} function, with a default size-of-table of 6000. Now to turn profiling on you do @code{(si::prof 0 90)}. This will start metering all addresses in the range of 0 (the first arg) to 1,000,000 * (256/90), where 90 is the second arg. To display the data collected so far you can invoke @code{si::display-profile} with no arguments. In order to clear the profile array you run @code{(si::clear)}. A call of @(si::prof 500000 256) would profile the code in the address range of 500,000 to 1,500,000. You may switch the profiler off by specifying a 0 mapping, ie @code{si::prof 0 0)}. It can then be restarted by supplying a nonzero second argument. Of course if you start up again with a scale different from the previous one, without clearing the profile array, you will have gibberish. The argument list to the last call of @{si::prof} is stored in the variable @code{si::*current-profile*}. Unless one is using a one to one mapping of the profile array to the code, there is a possibility of quantization errors. There is also the possibility of overflowing a slot in the profile array, if the mapping is very coarse, or if the interval being measured is very long. @code{ 0.08% ( 9): _eql 15.26% ( 1822): _equal 0.01% ( 1): _Fquote 0.01% ( 1): SET 0.04% ( 5): _parse_key 0.01% ( 1): _Fcond ... 0.50% ( 60): RELIEVE-HYPS1 0.03% ( 4): REMAINDER 0.01% ( 1): REMOVE-*2*IFS 0.03% ( 3): REMOVE-TRIVIAL-EQUATIONS 4.35% ( 520): REWRITE 0.47% ( 56): REWRITE-CAR-V&C-APPLY$ ...} is a sample of the output. The first column represents percentage of total time spent with the program counter in the range starting at this function, up to the next named function. The second column is the actual number of times that a profile interrupt landed in this section of the code. Note the default display is by address, and as mentioned before, one should beware of overlaps, in a coarse mapping. Functions for which there were no ticks, are not displayed. Note we did not sort the output, since we wished to leave it in address order. It is possible (because of roundoff if the second arg to prof is small) that some calls could be credited to the adjacent function. This could be spotted more easily if the order is by address. It is trivial to sort the table by ticks in gnu emacs using the command sort-columns. Have the point set at the beginning of column, in the first line and the mark at the end of the column in the last line. Unfortunately the System V loader likes to separate the original C functions of KCL, from those incrementally loaded, by about 2 megabytes. This makes it awkward to meter both ranges simultaneously without using a very large profile array. It is probably reasonable to rewrite the basic interrupt call, to handle such an address configuration. This has not yet been done. Of course you can always make two runs, and combine the information for the two ranges. gcl/doc/fast-link000066400000000000000000000122461242227143400142110ustar00rootroot00000000000000 Description of Fast Link option for KCL Author: Bill Schelter When we refer to times of function calls, without other qualification, we will be referring to the simplest possible function of no args returning nil: (defun foo () nil). This provides a good general indication of the timing of all functions. The original KCL function calling system, distinguishes between functions defined in the same file, proclaimed functions, as well as having different calling mechanisms for different safety levels. Some disadvantages were that calling across files always took at least 50mu, in spite of proclamations or safety. Function calls inside a file either were fast (10 mu (or 3mu for proclaimed)) at safety 0 but incapable of being traced or redefined, or else as slow as cross file compilation. We wished to have a scheme which would allow tracing and redefinition, of all calls, as well very fast calling. In order to do this we set up links in the calls, and these are modified at the first call to the function, if the function is compiled. Recompiling tracing, or redefining, undoes the link. (use-fast-links t) turns this feature on, and it is on by default. An argument of nil turns it off, so that all calls go through the function symbol. Some timings on the fast link compiling provided in this version of kcl. FILEA: (proclaim '(optimize (safety 0))) (proclaim '(function blue() t)) (proclaim '(function blue1 (t) t)) (proclaim '(function blue2 (t t) t)) (proclaim '(function blue-same-file() t)) (defun test-blue (n) (sloop for i below n do (blue))) (defun test-blue1 (n) (sloop for i below n do (blue1 nil))) (defun test-blue2 (n) (sloop for i below n do (blue2 nil nil))) (defun test-blue-same-file (n) (sloop for i below n do (blue-same-file))) FILEB: (defun blue () nil) (defun blue1 (x)x nil) (defun blue2 (x y) x y Compile and load FILEA then FILEB. Timings: We timed the invocation of blue,blue1, and blue2 by executing the loops in fileA. We subtracted the time for one empty loop iteration (2.7mu). Call New Old (blue) 3.03 60.5 (blue1 x) 4.1 62.2 (blue2 x y) 5.1 64.3 (blue-same-file) 3.03 2.73 As can be seen all calls of blue are substantially speeded up, except for the calls in the same file, which are slightly slowed down. There is however the advantage, that the calls in the same file can now be traced or redefined. Also it is conceivable that the program might want to change a definition dynamically. It is no longer necessary to recompile the whole file. They are handled in exactly the same manner as the non local calls. Since most software projects consist of more than one file, and since it is customary to move key routines to a basic files at the beginning of the system, we feel the importance of having fast calls across files is important. For example in MAXIMA, there are 380 calls to ptimes, with naturally the large majority being in files other than the basic definition. It is useful if the other calls can be made faster too. Also when debugging some chunk of MAXIMA code, it is useful to be able to trace ptimes, without having to load in new definitions and recompile. Disadvantages: The link table data takes up approximately 10 words, independent of the number of calls in a file to that function. Space: I made a file with (defun try (a b) a b (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) ) I compared the size with various settings of *fast-link-compile* and with proclaiming foos. DIFF means the size above the case with all calls to FOOS removed. text data bss dec DIFF FLC proclaimed Case SAMEFILE 1076 0 28 1104 836 nil nil I nil 1308 0 32 1340 892 nil nil Ia t 1296 4 28 1328 1060 t nil II nil 1436 4 32 1472 1056 t nil IIa t 684 4 28 716 448 t t III nil 244 0 24 268 0 t ; calls removed. IV nil 384 0 32 416 0 nil ;cals removed V t The reason II is bigger than I is that the vs_top and vs_base settings are being performed in the file, in exactly the same manner as if the definition for foos were in the file. FLC=nil with definition of foos in the same file would also be higher. Should probably have a type of proclamation which would favor the case I call in cases where speed is irrelevant. But then why not go with III.. Appendix: Notes: 1)Empty loop takes 2.70 seconds for 1,000,000 iterations. 2)blue-same-file or blue >(time (test-blue 1000000)) real time : 5.750 secs run time : 5.733 secs NIL >(trace blue) (BLUE) >(test-blue 2) 1> (BLUE) <1 (BLUE NIL) 1> (BLUE) <1 (BLUE NIL) NIL >(trace blue-same-file) (BLUE-SAME-FILE) >(test-blue-same-file 2) 1> (BLUE-SAME-FILE) <1 (BLUE-SAME-FILE NIL) 1> (BLUE-SAME-FILE) <1 (BLUE-SAME-FILE NIL) NIL gcl/doc/format000066400000000000000000000026051242227143400136070ustar00rootroot00000000000000 We have added a user extensible feature to the common lisp function format. For some applications, for example in maxima, it is very desirable to be able to define a new control character, so that (format t "~%The polynomial ~m is not zero" polynomial) would work. It is desirable to extend format itself, since then calls to the error and other functions which use format will work correctly. For example: (error "~%The polynomial ~m is not zero" polynomial) For an application to do this we would evaluate the following: (setf (get 'si::*indent-formatted-output* (char-code #\m)) 'maxima-print) (defun maxima-print (item stream colon atsign &rest l) colon atsign l ;ignoring these (internal-maxima-print item stream)) Note this extension is case sensitive, so that to have this apply to capital M as well, the property for (char-code #\M) must be added as well. A call with "~:m" would make colon=1 and atsign=0. A call with "~@m" would make colon=0 and atsign=1. To Do: The &rest l is currently unused, a future addition will probably store into l the current column of the format output stream. This also implies that new print functions should return what they think is the new column. Since I believe that 98% of the current calls to format do not use column information in an important way, this is probably not worth the additional hair involved. Numeric args are not passed. gcl/doc/funcall-comp000066400000000000000000000016741242227143400147040ustar00rootroot00000000000000 In AKCL version 1.78 I observe the following times (defun joe () nil) (setq cfun #'joe) (setq symbol 'joe) after compilation (on a sun3/280) Form AKCL 1.78 KCL (joe) 6.1 7.7 (funcall cfun) 9.5 14.0 (funcall symbol) 13.7 17.8 (joe1) 2.1 2.5 times are in microseconds per call. joe1 is the same as joe but with (proclaim '(function joe1 () t)) The functions were in the same file, although this would not make a difference for AKCL. A typical timing loop is (defun foo1 (x n) (sloop for i below n do (funcall x))) (defun foo2 ( n) (sloop for i below n do (joe))) (defun foo3 ( n) (sloop for i below n do (joe1))) (time (foo1 #'joe 100000)) (time (foo1 'joe 100000)) (time (foo2 100000)) Note: An AKCL version >= 1.78 will be released in a few days when I finish checking over the 8 and 16 bit arrays which have been added. gcl/doc/funcall.lsp000066400000000000000000000064501242227143400145420ustar00rootroot00000000000000 I have been trying to improve funcall so that functions of a fixed number of args can be funcalled with almost the same speed as they can be called if the name is laid down in the file. Basically I have made functions with a fixed number of args, first class compiled-function objects, and removed the si::cdefn property stuff. It is no longer necessary to have a global version of the function, since one can now use the C stack version anywhere. I have made compiled function objects slightly smaller, but with more information. So the number of args and there types is encoded in these C functions. It will soon be possible to do fast cross file calling of functions with mixed fixnum and general args and one return value. After these changes: A comparison of calling a fixed arg function of 1 argument: (the second time for KCL is for when the function is in a separate file). LUCID AKCL KCL funcall 8.3 3.54 18.8 (funcall x nil) where x = #'foo Direct call 7.44 2.78 3.16(23.4) (foo nil) (proclaim '(function foo (t) t)) (defun line1 (x n) (sloop for i below n with y do (setq y (funcall x nil)))) (defun line2 (n) (sloop for i below n with y do (setq y (foo nil)))) (defun foo (x) x nil) It is able to detect that only one value from the funcall is desired, because of the setq. In general the following macro can be used to inform the compiler of this. (defmacro vfuncall (x &rest args) `(the (values t) (funcall ,x ,@ args))) We can not lay down the new funcall code if multiple values might be desired: (defun joe (x) (funcall x nil)) will have its number of values returned depend on x. (defun joe (x) (the (values t) (funcall x nil))) or (defun joe (x) (setq x (funcall x nil))) would allow it however. Unfortunately GCL is much slower if the function to be funcalled does not happen to be a compiled function which was compiled while proclaimed with a fixed number of args and one value. Still there are a number of critical applications where it is useful to have a very fast funcall. I have no useful heuristic at the moment for 'guessing' which kind of funcall I should lay down: One optimized for C stack or one optimized for Lisp stack. I can only detect when it is safe to lay down a C stack one. However if the function in question uses the lisp stack, and is called via the C stack, the call will be twice as slow as it used to be. This is very unfortunate! At the cost of space I could avoid this, but the new funcall takes up less space than the old one and I hate to lay down two types in the code just in case.... The check as to type is being laid down, but a trick is used to keep space different minimal. SPACE: I have also noted some size differences (as reported by size *.o) where the amounts are the 'dec' = decimal representation of text+data+bss in the object file. This is what gets loaded. There is still room for improvement here. Most of the difference is due to the fact that functions of fixed args only need one entry now. Before: After: 31340 basis.o 28348 76584 code-1-a.o 63212 94136 code-b-d.o 79136 93372 code-e-m.o 75384 125172 code-n-r.o 10524 77148 code-s-z.o 61840 15620 events.o 14504 4036 genfact.o 3464 27908 io.o 24544 9132 ppr.o 8340 42668 sloop.o 40484 gcl/doc/makefile000066400000000000000000000003461242227143400140740ustar00rootroot00000000000000# a facility for displaying DOC files and completing on them # requires gnu emacs, to be in the search path # A directory on peoples search path. ELISP=gcl.el dbl.el ansi-doc.el lisp-complete.el sshell.el -include ../makedefs gcl/doc/multiple-values000066400000000000000000000051531242227143400154500ustar00rootroot00000000000000 Proclaimed functions of a fixed number of args are much more efficient. It is still possible to pass multiple values efficiently (but not quite with the CL semantics) Here are two examples, one using ordinary multiple-value-setq and the other our-multiple-value-setq. For 1,000,000 calls: Type : CL 2 values our 2 values 1 value Time : 7.9 sec 3.5 2.35 name : foo-mv foo-our-mv foo Uses : multiple-value-setq our-multiple-value-setq Only 1 value passed. (defun foo-mv (n) (let (x y) (sloop for i below n do (multiple-value-setq(x y) (goo-mv))))) (defun goo-mv () (values 1 2)) And then an equivalent one: (proclaim '(function foo-our-mv (t) t)) (proclaim '(function goo-our-mv () t)) (defun foo-our-mv (n) (let (x y) (sloop for i below n do (our-multiple-value-setq (x y) (goo-our-mv))) (list x y))) (defun goo-our-mv () (our-values 1 2)) The times: >(time (foo-our-mv 1000000)) real time : 3.617 secs run time : 3.583 secs (1 2) >(time (foo-mv 1000000)) real time : 8.033 secs run time : 7.800 secs (1 2) Here are the our-mv macros: (use-package "SLOOP") (defmacro our-values (a &rest l) (or (< (length l) (length *vals*)) (error "too many values")) `(prog1 ,a ,@ (sloop for v in l for u in *vals* collect `(setq ,u ,v)))) (defmacro our-multiple-value-setq ((x &rest l) form) (or (< (length l) (length *vals*)) (error "too many values")) `(prog1 (setq ,x ,form) ,@ (sloop for w in *vals* for v in l collect `(setq ,v ,w)))) (defvar *vals* '(*val1* *val2* *val3* *val4* *val5* *val6* *val7* *val8* *val9* *val10*)) (defvar *val1* nil) (defvar *val2* nil) (defvar *val3* nil) (defvar *val4* nil) (defvar *val5* nil) (defvar *val6* nil) (defvar *val7* nil) (defvar *val8* nil) (defvar *val9* nil) (defvar *val10* nil) ;; Note that this method does not penalize ordinary calls at all. ;; It is not the same as the common lisp multiple values in general: ;; 1) The information on how many values are being passed is not ;; recorded [ unless of course that number is one of the values ! ] ;; 2) If you ask for more values than were specified you will get ;; a random value. Common lisp values would say you get nil. ;; Now it is true that it would be possible to make AKCL pass multiple ;; values more efficiently, but this is really a large overhaul of the ;; system. There are lots of system functions, hand coded using the ;; old scheme. I have been thinking about ways to do this for the ;; last little while, but have not settled on anything. Bill gcl/doc/profile000066400000000000000000000024501242227143400137550ustar00rootroot00000000000000 We have added a facility for determining the proportional amount of time spent executing compiled lisp defined functions, as well as internal c defined functions. This system works under Unix BSD or System V. To use this code load the file lsp/profile.o. SET-UP-PROFILE &optional (array-size 100000)(max-funs 6000) must be called to allocate space for storing the profile information as it is collected, and also to build a list of the functions from the symbol table of the executable (defaults to "saved_kcl"). Once this has been done a call to PROF (start scale) START will correspond to the beginning of the profile array, and the SCALE will mean that 256 bytes of code correspond to SCALE bytes in the profile array. Thus if the profile array is 1,000,000 bytes long and the code segment is 5 megabytes long you can profile the whole thing using a scale of 50 Note that long runs may result in overflow, and so an understating of the time in a function. With a scale of 128 a sample loop overflowed some slots at 6,000,000 times through the loop. There is very little slowdown in execution during profiling. No special compilation is necessary. To display the result do (si::display-profile) To turn off profiling use (si::prof 0 0). (si::clear-profile) clears the profile array for a new run. gcl/dos/000077500000000000000000000000001242227143400124115ustar00rootroot00000000000000gcl/dos/dostimes.c000077500000000000000000000004451242227143400144120ustar00rootroot00000000000000#include #include #ifdef __ZTC__ #define HZ 100 #endif times(x) struct tms *x; { int hz; struct rusage ru; getrusage(RUSAGE_SELF,&ru); hz = ru.ru_utime.tv_sec * HZ + (ru.ru_utime.tv_usec *HZ)/1000000; x->tms_utime = hz; x->tms_stime = hz; return 0; } gcl/dos/dum_dos.c000077500000000000000000000002651242227143400142150ustar00rootroot00000000000000#define DUM(a) int a(int n) { printf("dummy " #a " call %d\n",n); return 0;} DUM(profil) /* DUM(alarm) */ DUM(getpid) DUM(getuid) DUM(popen) DUM(pclose) DUM(getpwuid) DUM(getpwnam) gcl/dos/makefile000066400000000000000000000004071242227143400141120ustar00rootroot00000000000000.SUFFIXES: .o .c HDIR = ../h OFLAG = -O ODIR = . -include ../makedefs DOS_ODIR=. CFLAGS = -I. -I$(HDIR) $(ODIR_DEBUG) .s.o: $(CC) -c $(OFLAG) $(CFLAGS) $*.c .c.o: $(CC) -c $(OFLAG) $(CFLAGS) $*.c OBJS = $(EXX_DOS) all: $(OBJS) clean: rm -f $(OBJS) gcl/dos/read.s000077500000000000000000000020201242227143400135050ustar00rootroot00000000000000/* This is file READ.S */ /* ** Copyright (C) 1991 DJ Delorie, 24 Kirsten Ave, Rochester NH 03867-2954 ** ** This file is distributed under the terms listed in the document ** "copying.dj", available from DJ Delorie at the address above. ** A copy of "copying.dj" should accompany this file; if not, a copy ** should be available from where this file was obtained. This file ** may not be distributed without a verbatim copy of "copying.dj". ** ** This file is distributed WITHOUT ANY WARRANTY; without even the implied ** warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */ .text .globl _read _read: pushl %eax movl $0,%eax cmp 8(%esp),%eax /* Is it stdin */ jne NotStdin cmp _interrupt_flag,%eax /* Any SIGINT Interrupt pending ? */ je NoInterrupt call _sigalrm NoInterrupt: NotStdin: popl %eax pushl %ebx pushl %esi pushl %edi movl 16(%esp),%ebx movl 20(%esp),%edx movl 24(%esp),%ecx movb $0x3f,%ah int $0x21 popl %edi popl %esi popl %ebx jb syscall_error ret gcl/dos/readme000077500000000000000000000003361242227143400135760ustar00rootroot00000000000000 This is the remnants of the port of akcl to dos under djgpp (version 1.06) Unfortunately djgpp has changed and so it is not so straightforward to make gcl work .. I would be happy if someone else does it! Bill Schelter gcl/dos/sigman.s000077500000000000000000000024171242227143400140620ustar00rootroot00000000000000 .globl _SignalManager _SignalManager: pushl %ebp movl %esp,%ebp /*------------------------------------------------------------------- ** Save all registers **-----------------------------------------------------------------*/ pushl %eax pushl %ebx pushl %ecx pushl %edx pushl %esi pushl %edi pushf pushl %es pushl %ds /* pushl %ss*/ pushl %fs pushl %gs /*-----------------------------------------------------------------*/ movl 4(%ebp), %eax shl $2, %eax movl _SignalTable(%eax), %ebx call %ebx /*------------------------------------------------------------------- ** Restore registers **-----------------------------------------------------------------*/ popl %gs popl %fs /* popl %ss*/ popl %ds popl %es popf popl %edi popl %esi popl %edx popl %ecx popl %ebx popl %eax /*------------------------------------------------------------------*/ popl %ebp add $4, %esp ret /* resume program */ gcl/dos/signal.c000077500000000000000000000060701242227143400140400ustar00rootroot00000000000000/* This is file signal.c ** ** Copyright (C) 1992 Rami EL CHARIF and William SCHELTER ** rcharif@ma.utexas.edu wfs@cs.utexas.edu ** ** Signal package for djgpp versions 1.05, 1.06 ** version 0.0 alpha 03/30/1992 ** ** Send your comments or bugs report to ** rcharif@ma.utexas.edu or wfs@cs.utexas.edu ** ** This file is distributed WITHOUT ANY WARRANTY; without even the implied ** warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */ #include #include #include unsigned long SignalTable[_NSIG + 1] = { (unsigned long)SIG_DFL, /* SIGHUP */ (unsigned long)SIG_DFL, /* SIGINT +*/ (unsigned long)SIG_DFL, /* SIGQUIT */ (unsigned long)SIG_DFL, /* SIGILL */ (unsigned long)SIG_DFL, /* SIGABRT */ (unsigned long)SIG_DFL, /* SIGTRAP */ (unsigned long)SIG_DFL, /* SIGIOT */ (unsigned long)SIG_DFL, /* SIGEMT */ (unsigned long)SIG_DFL, /* SIGFPE */ (unsigned long)SIG_DFL, /* SIGKILL */ (unsigned long)SIG_DFL, /* SIGBUS */ (unsigned long)SIG_DFL, /* SIGSEGV +*/ (unsigned long)SIG_DFL, /* SIGSYS */ (unsigned long)SIG_DFL, /* SIGPIPE */ (unsigned long)SIG_DFL, /* SIGALRM */ (unsigned long)SIG_DFL, /* SIGTERM */ (unsigned long)SIG_DFL, /* SIGURG */ (unsigned long)SIG_DFL, /* SIGSTOP */ (unsigned long)SIG_DFL, /* SIGTSTP */ (unsigned long)SIG_DFL, /* SIGCONT */ (unsigned long)SIG_DFL, /* SIGCHLD */ (unsigned long)SIG_DFL, /* SIGCLD */ (unsigned long)SIG_DFL, /* SIGTTIN */ (unsigned long)SIG_DFL, /* SIGTTOU */ (unsigned long)SIG_DFL, /* SIGIO */ (unsigned long)SIG_DFL, /* SIGPOLL */ (unsigned long)SIG_DFL, /* SIGXCPU */ (unsigned long)SIG_DFL, /* SIGXFSZ */ (unsigned long)SIG_DFL, /* SIGVTALRM */ (unsigned long)SIG_DFL, /* SIGPROF */ (unsigned long)SIG_DFL, /* SIGWINCH */ (unsigned long)SIG_DFL, /* SIGUSR1 */ (unsigned long)SIG_DFL /* SIGUSR2 */ }; SignalHandler signal(int sig, SignalHandler action) { extern void SignalManager(); union REGS in, out; SignalHandler hsigOld; in.h.ah = 1; in.h.al = sig; SignalTable[sig] = in.x.dx = (long)action; in.x.cx = (long)SignalManager; int86(0xfa, &in, &out); hsigOld = (SignalHandler)out.x.dx; return hsigOld; } void SigInst() { union REGS in, out; extern void SignalManager(); in.h.ah = 0; in.h.al = 0; in.x.dx = (long)SignalManager; #ifdef DEBUG_SIG printf("\nSignal Manager = %ld, %lx", in.x.dx, in.x.dx); #endif int86(0xfa, &in, &out); } #ifndef NO_SIG_ALARM unsigned int alarm(int culSeconds) { union REGS in, out; if (!culSeconds) { in.h.ah = 3; /* Reset alarm */ int86(0xfa, &in, &out); } else { in.h.ah = 2; in.x.dx = culSeconds; int86(0xfa, &in, &out); } return in.x.cx; } #else unsigned int alarm(int n) { return 0; } #endif gcl/dos/signal.h000077500000000000000000000113761242227143400140520ustar00rootroot00000000000000/* This is file signal.h */ /* This file may have been modified by DJ Delorie (Jan 1991). If so, ** these modifications are Coyright (C) 1991 DJ Delorie, 24 Kirsten Ave, ** Rochester NH, 03867-2954, USA. */ /* This may look like C code, but it is really -*- C++ -*- */ /* Copyright (C) 1989 Free Software Foundation written by Doug Lea (dl@rocky.oswego.edu) This file is part of GNU CC. GNU CC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY. No author or distributor accepts responsibility to anyone for the consequences of using it or for whether it serves any particular purpose or works at all, unless he says so in writing. Refer to the GNU CC General Public License for full details. Everyone is granted permission to copy, modify and redistribute GNU CC, but only under the conditions described in the GNU CC General Public License. A copy of this license is supposed to have been given to you along with GNU CC so you can know your rights and responsibilities. It should be in a file named COPYING. Among other things, the copyright notice and this notice must be preserved on all copies. */ #ifndef _signal_h #pragma once #ifdef __cplusplus extern "C" { #endif /* This #define KERNEL hack gets around bad function prototypes on most */ /* systems. If not, you need to do some real work... */ /******************* * #define KERNEL * #include * #undef KERNEL ********************/ #ifndef _signal_h #define _signal_h 1 #endif /* The Interviews folks call this SignalHandler. Might as well conform. */ /* Beware: some systems think that SignalHandler returns int. */ typedef void (*SignalHandler) (); extern SignalHandler signal(int sig, SignalHandler action); extern SignalHandler sigset(int sig, SignalHandler action); extern SignalHandler ssignal(int sig, SignalHandler action); extern int gsignal (int sig); extern int kill (int pid, int sig); #ifndef hpux /* Interviews folks claim that hpux doesn't like these */ struct sigvec; extern int sigsetmask(int mask); extern int sigblock(int mask); extern int sigpause(int mask); extern int sigvec(int sig, struct sigvec* v, struct sigvec* prev); #endif /* The Interviews version also has these ... */ #define SignalBad ((SignalHandler)-1) #define SignalDefault ((SignalHandler)0) #define SignalIgnore ((SignalHandler)1) #ifdef __cplusplus } #endif #define _SIGNAL_H /** #include **/ #ifdef _SIGNAL_H /* This file defines the fake signal functions and signal number constants for 4.2 or 4.3 BSD-derived Unix system. */ #define SIG_DFL 0 #if 0 /*#ifndef SIG_DFL*/ /* Fake signal functions. These lines MUST be split! m4 will not change them otherwise. */ #define SIG_ERR /* Error return. */ \ ((void EXFUN((*), (int sig))) -1) #define SIG_DFL /* Default action. */ \ ((void EXFUN((*), (int sig))) 0) #define SIG_IGN /* Ignore signal. */ \ ((void EXFUN((*), (int sig))) 1) #endif /* Signals. */ #define SIGHUP 1 /* Hangup (POSIX). */ #define SIGINT 2 /* Interrupt (ANSI). */ #define SIGQUIT 3 /* Quit (POSIX). */ #define SIGILL 4 /* Illegal instruction (ANSI). */ #define SIGABRT SIGIOT /* Abort (ANSI). */ #define SIGTRAP 5 /* Trace trap (POSIX). */ #define SIGIOT 6 /* IOT trap (4.2 BSD). */ #define SIGEMT 7 /* EMT trap (4.2 BSD). */ #define SIGFPE 8 /* Floating-point exception (ANSI). */ #define SIGKILL 9 /* Kill, unblockable (POSIX). */ #define SIGBUS 10 /* Bus error (4.2 BSD). */ #define SIGSEGV 11 /* Segmentation violation (ANSI). */ #define SIGSYS 12 /* Bad argument to system call (4.2 BSD)*/ #define SIGPIPE 13 /* Broken pipe (POSIX). */ #define SIGALRM 14 /* Alarm clock (POSIX). */ #define SIGTERM 15 /* Termination (ANSI). */ #define SIGURG 16 /* Urgent condition on socket (4.2 BSD).*/ #define SIGSTOP 17 /* Stop, unblockable (POSIX). */ #define SIGTSTP 18 /* Keyboard stop (POSIX). */ #define SIGCONT 19 /* Continue (POSIX). */ #define SIGCHLD 20 /* Child status has changed (POSIX). */ #define SIGCLD SIGCHLD /* Same as SIGCHLD (System V). */ #define SIGTTIN 21 /* Background read from tty (POSIX). */ #define SIGTTOU 22 /* Background write to tty (POSIX). */ #define SIGIO 23 /* I/O now possible (4.2 BSD). */ #define SIGPOLL SIGIO /* Same as SIGIO? (SVID). */ #define SIGXCPU 24 /* CPU limit exceeded (4.2 BSD). */ #define SIGXFSZ 25 /* File size limit exceeded (4.2 BSD). */ #define SIGVTALRM 26 /* Virtual alarm clock (4.2 BSD). */ #define SIGPROF 27 /* Profiling alarm clock (4.2 BSD). */ #define SIGWINCH 28 /* Window size change (4.3 BSD, Sun). */ #define SIGUSR1 30 /* User-defined signal 1 (POSIX). */ #define SIGUSR2 31 /* User-defined signal 2 (POSIX). */ #endif /* included. */ #define _NSIG 32 /* Biggest signal number + 1. */ #endif gcl/elisp/000077500000000000000000000000001242227143400127405ustar00rootroot00000000000000gcl/elisp/add-default.el000066400000000000000000000001671242227143400154400ustar00rootroot00000000000000 ;;;BEGIN gcl addition (autoload 'dbl "dbl" "Make a debugger to run lisp, maxima and or gdb in" t) ;;;END gcl addition gcl/elisp/ansi-doc.el000077500000000000000000000061071242227143400147660ustar00rootroot00000000000000;; Copyright William F. Schelter. 1994 ;; Licensed by GNU public license. ;; This file contains function find-ansi-doc which finds documentation in the ;; standard common lisp ansi documentation (1350 pages!), and puts it on ;; the screen at the correct page using xdvi. If there is more than one ;; reference it successively finds them. You need dpANS2/*.dvi ;; dpANS2/index.idx from parcftp.xerox.com (13.1.64.94) You also need ;; xdvi. You may gzip the .dvi files and it will unzip them into tmp ;; as needed. (defvar ansi-doc-dir "/usr/local/doc/dpANS2") (defvar ansi-doc-alist nil) (defun create-index-el-from-index-idx () (interactive) (let (tem) (cond ((not ansi-doc-alist) (setq tem (concat ansi-doc-dir "/index.el")) (or (file-exists-p tem) (progn (shell-command (concat "echo '(setq ansi-doc-alist (quote (( ' > " tem)) (shell-command (concat "cat " ansi-doc-dir "/index.idx " "| sed " " -e 's/\\!9\\([A-Z]\\):\\([^\\!]*\\)\\!\\!/)(\"\\2\" \\1/g' " " -e 's:{$\\\\spLT \\$}:<:g' " " -e 's:{$\\\\spGT $}:>:g' " " -e 's:\\\\&:\\&:g' " " -e 's:\\([0-9]\\),:\\1:g'" " -e 's:\\([A0-9][0-9]*\\)--\\([0-9][0-9]*\\):(\\1 . \\2):g'" " | sort -r " " >> " tem)) (shell-command (concat "echo '))))' >> " tem)))) )))) (defun maybe-gzip-to-tmp (file &optional dir) "If file exists with .gz added to it, then unzip it to /tmp and return that file otherwise return file" (let (tmp-file) (cond ((file-exists-p (concat file ".gz")) (setq tmp-file (file-name-nondirectory file)) (or (file-exists-p tmp-file) (progn (message "gzipping %s in /tmp for future use" file) (shell-command (concat "gzip -dc < " file ".gz > " tmp-file )))) tmp-file) (t file)))) (defun find-ansi-doc () "Find the documentation in the ansi draft on a particular function or topic. If there are several pieces of documentation then go through them successively. Requires copying the " (interactive ) (let (x tem name lis first chap tmp-chap) (or ansi-doc-alist (progn (create-index-el-from-index-idx ) (load (concat ansi-doc-dir "/index.el")))) (setq name (completing-read "Doc on: " ansi-doc-alist nil t)) (progn (setq ans nil) (setq lis ansi-doc-alist) (while lis (cond ((equal (car (car lis)) name) (setq ans (append ans (cdr (cdr (car lis))))))) (setq lis (cdr lis))) ) (setq tem ans) (if (cdr tem) (setq first "First") (setq first "")) (while tem (setq x (car tem)) (setq chap (concat ansi-doc-dir (downcase (format "/chap-%s.dvi" (car x))))) (setq chap (maybe-gzip-to-tmp chap)) (message "%s Doc in Chapter %s page %s) %s .." first (car x) (cdr x)) (if (cdr tem) (setq first "Next") (setq next "Final")) (shell-command (concat "xdvi -expert -xoffset .2 -yoffset -.2 " " -paper 7.2x8.5 " " -display " (or x-display-name ":0") " -geometry -2-2 +" (+ (cdr x) 2)" " chap )) (setq tem (cdr tem)) ) ) (message nil) ) gcl/elisp/dbl.el000077500000000000000000000545321242227143400140370ustar00rootroot00000000000000;; Run gcl,maxima,gdb etc under Emacs all possibly all in one buffer. ;; ;; This file is part of GNU Emacs. ;; Copyright (C) 1998 William F. Schelter ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility ;; to anyone for the consequences of using it or for whether it serves ;; any particular purpose or works at all, unless he says so in writing. ;; Refer to the GNU Emacs General Public License for full details. ;; Everyone is granted permission to copy, modify and redistribute GNU ;; Emacs, but only under the conditions described in the GNU Emacs ;; General Public License. A copy of this license is supposed to have ;; been given to you along with GNU Emacs so you can know your rights and ;; responsibilities. It should be in a file named COPYING. Among other ;; things, the copyright notice and this notice must be preserved on all ;; copies. ;; Description of DBL interface: ;; A facility is provided for the simultaneous display of the source code ;; in one window, while using dbl to step through a function in the ;; other. A small arrow in the source window, indicates the current ;; line. ;; Starting up: ;; In order to use this facility, invoke the command DBL to obtain a ;; shell window with the appropriate command bindings. You will be asked ;; for the name of a file to run. Dbl will be invoked on this file, in a ;; window named *dbl-foo* if the file is foo. ;; M-s steps by one line, and redisplays the source file and line. ;; You may easily create additional commands and bindings to interact ;; with the display. For example to put the dbl command next on \M-n ;; (def-dbl :next "\M-n") ;; This causes the emacs command dbl-next to be defined, and runs ;; dbl-display-frame after the command. ;; dbl-display-frame is the basic display function. It tries to display ;; in the other window, the file and line corresponding to the current ;; position in the dbl window. For example after a dbl-step, it would ;; display the line corresponding to the position for the last step. Or ;; if you have done a backtrace in the dbl buffer, and move the cursor ;; into one of the frames, it would display the position corresponding to ;; that frame. ;; dbl-display-frame is invoked automatically when a filename-and-line-number ;; appears in the output. (require 'sshell) (require 'smart-complete) (define-key sshell-mode-map "\ep" 'smart-complete) (define-key sshell-mode-map "\M-p" 'smart-complete) (require 'gcl) (autoload 'maxima-mode "maxima-mode" "Major mode for editing maxima code and interacting with debugger" t) (autoload 'gcl-mode "gcl" "Major mode for editing maxima code and interacting with debugger" t) (or (rassoc 'maxima-mode auto-mode-alist) (setq auto-mode-alist (cons '("\\.ma?[cx]\\'" . maxima-mode) auto-mode-alist)) ) (or (rassoc 'gcl-mode auto-mode-alist) (setq auto-mode-alist (cons '("\\.li?sp\\'" . gcl-mode) auto-mode-alist)) ) (defvar dbl-prompt-pattern "\\(^\\|\n\\)[^ >]*[>$)%#:][>]*[ ]*" ; "(^|\n)\\[^ >]*[>$)%#:][>]*[ ]*+" "A regexp to recognize the prompt for dbl or dbl+.") ; (defvar downcase-filenames-for-dbl (string-match "nt[45]" system-configuration) "Force the case to be lower when sending a break command" ) (defvar dbl-subshell-switches (list "bash" (if (string-match "nt[45]" system-configuration) '("--noediting" "-i") '("-i")) ) "Alternating list of regexp for the shell name, and list of switches to pass" ) (defvar dbl-filter-accumulator nil) (defvar dbl-mode-map nil "Keymap for dbl-mode.") (if dbl-mode-map nil (setq dbl-mode-map (copy-keymap sshell-mode-map)) (define-key dbl-mode-map "\C-cl" 'dbl-find-and-display-line) ) (define-key ctl-x-map " " 'dbl-break) ;(define-key ctl-x-map "&" 'send-dbl-command) ;;Of course you may use `def-dbl' with any other dbl command, including ;;user defined ones. (defmacro def-dbl (name key &optional doc) (let* ((fun (intern (format "dbl-%s" (read name)))) ) (list 'progn (list 'defun fun '(arg) (or doc "") '(interactive "p") (list 'dbl-call name 'arg)) (list 'define-key 'dbl-mode-map key (list 'quote fun))))) (def-dbl ":step %p" "\M-s" "Step one source line with display") (def-dbl ":step %p" "\C-c\C-s" "Step one source line with display") (def-dbl ":stepi %p" "\C-c\t" "Step one instruction with display") (def-dbl ":next %p" "\M-n" "Step one source line (skip functions)") (def-dbl ":next %p" "\C-c\C-n" "Step one source line (skip functions)") (def-dbl ":r" "\M-c" "Continue with display") (def-dbl ":finish" "\C-c\C-f" "Finish executing current function") (def-dbl ":up %p" "\C-cu" "Go up N stack frames (numeric arg) with display") (def-dbl ":down %p" "\C-cd" "Go down N stack frames (numeric arg) with display") (defun dbl-mode () "Major mode for interacting with an inferior Lisp or Maxima process. It is like an ordinary shell, except that it understands certain special redisplay commands sent by the process, such as redisplay a source file in the other window, positioning a little arrow `==>', at a certain line, typically the line where you are stopped in the debugger. It uses completion based on the form of your current prompt, allowing you to keep separate the commands you type at the debugger level and the lisp or maxima level. The source files should be viewed using gcl mode for lisp, and maxima-mode for maxima. \\{dbl-mode-map} \\[dbl-display-frame] displays in the other window the last line referred to in the dbl buffer. \\[dbl-:step] and \\[dbl-:next] in the dbl window, call dbl to step and next and then update the other window with the current file and position. o If you are in a source file, you may select a point to break at, by doing \\[dbl-break]. Commands: Many commands are inherited from shell mode. Additionally we have: \\[dbl-display-frame] display frames file in other window \\[dbl-:step] advance one line in program \\[dbl-:next] advance one line in program (skip over calls). \\[send-dbl-command] used for special printing of an arg at the current point. C-x SPACE sets break point at current line. You may also enter keyword break commands. :a show-break-variables :b simple-backtrace :bds break-bds :bl break-locals :blocks break-blocks :break insert a break point here :bs break-backward-search-stack :bt dbl-backtrace :c break-current :delete (lambda (&rest l) (iterate-over-bkpts l delete) (values)) :disable [n1 .. nk] disable break points. [see :info :bkpt] :down [n] move n frames down :enable [n1 n2 ..nk] enable break points :env describe-environment :fr [n] show this frame :fs break-forward-search-stack :functions break-functions :go break-go :h break-help :help break-help :ihs ihs-backtrace :info :bkpt show break points. :loc loc :m break-message :n break-next :next step-next :p break-previous :q break-quit :r resume :resume (lambda () resume) :s search-stack :step step-into :t throw-macsyma-top :up move up one frame :vs break-vs " (interactive) (kill-all-local-variables) (setq major-mode 'dbl-mode) (setq mode-name "Inferior Dbl") (setq mode-line-process '(": %s")) (use-local-map dbl-mode-map) (make-local-variable 'last-input-start) (setq last-input-start (make-marker)) (make-local-variable 'last-input-end) (setq last-input-end (make-marker)) (make-local-variable 'dbl-last-frame) (setq dbl-last-frame nil) (make-local-variable 'dbl-last-frame-displayed-p) (setq dbl-last-frame-displayed-p t) (make-local-variable 'dbl-delete-prompt-marker) (setq dbl-delete-prompt-marker nil) (make-local-variable 'dbl-filter-accumulator) (setq dbl-filter-accumulator nil) (make-local-variable 'shell-prompt-pattern) (setq shell-prompt-pattern dbl-prompt-pattern) (run-hooks 'sshell-mode-hook 'dbl-mode-hook)) (defvar current-dbl-buffer nil) (defvar dbl-command-name (if (file-exists-p "/bin/bash") "/bin/bash" "/bin/sh") "Pathname for executing dbl.") (defun dbl (p) "Makes a dbl buffer, suitable for running an inferior gcl. You are prompted for a name for the buffer. After the shell starts you should start up your lisp program (eg gcl). The bufferd has special keybindings for stepping and viewing sources. Enter the debug loop with (si::dbl) or :dbl in a debug loop. " (interactive "p") (let ( tem (dir default-directory) ;; important for winnt version of emacs (binary-process-input t) (binary-process-output nil) switches (name (concat "dbl" (if (equal p 1) "" p) "")) ) (switch-to-buffer (concat "*" name "*")) (or (bolp) (newline)) (insert "Current directory is " default-directory "\n") (let ((tem dbl-subshell-switches) switches) (while tem (cond ((string-match (car tem) dbl-command-name) (setq switches (nth 1 tem)) (setq tem nil)) (t (setq tem (nthcdr 2 tem))))) (apply 'make-sshell name dbl-command-name nil switches)) (dbl-mode) (make-local-variable 'sshell-prompt-pattern) (setq sshell-prompt-pattern dbl-prompt-pattern) (goto-char (point-min)) (insert " Welcome to DBL a Debugger for Lisp, Maxima, Gdb and others. You start your program as usually would in a shell. For Lisp and Maxima the debugger commands begin with a ':', and there is completion. Typing ':' should list all the commands. In GCL these are typed when in the debugger, and in Maxima they may be typed at any time. To see the wonderful benefits of this mode, type C-h m. Note you may also use this mode to run gdb. In fact I often debug MAXIMA over GCL using gdb, thus having three debuggers at once. To run gdb and enable the automatic line display, you must supply the `--fullname' keyword as in: gdb your-file --fullname ") (goto-char (point-max)) (set-process-filter (get-buffer-process (current-buffer)) 'dbl-filter) (set-process-sentinel (get-buffer-process (current-buffer)) 'dbl-sentinel) (dbl-set-buffer))) (defun dbl-set-buffer () (cond ((eq major-mode 'dbl-mode) (setq current-dbl-buffer (current-buffer))))) ;; This function is responsible for inserting output from DBL ;; into the buffer. ;; Aside from inserting the text, it notices and deletes ;; each filename-and-line-number; ;; that DBL prints to identify the selected frame. ;; It records the filename and line number, and maybe displays that file. (defun dbl-filter (proc string) (let ((inhibit-quit t)) (set-buffer (process-buffer proc)) (goto-char (point-max)) (insert string) (goto-char (point-max)) )) (defun dbl-filter (proc string) (let ((inhibit-quit t)) (if dbl-filter-accumulator (dbl-filter-accumulate-marker proc (concat dbl-filter-accumulator string)) (dbl-filter-scan-input proc string)) )) (defun dbl-filter-accumulate-marker (proc string) (setq dbl-filter-accumulator nil) (if (> (length string) 1) (if (= (aref string 1) ?\032) (let ((end (string-match "\n" string))) (if end (progn (setq me string) (cond ((string-match "\032\032\\([A-Za-z]?:?[^:]*\\):\\([0-9]*\\):[^\n]+\n" string) (setq dbl-last-frame (cons (match-string 1 string) (string-to-int (match-string 2 string)))) (cond ((equal (cdr dbl-last-frame) 0) ;(message "got 0") ;(sit-for 1) (setq overlay-arrow-position nil) (setq dbl-last-frame nil) ) (t (setq dbl-last-frame-displayed-p nil)) ))) (dbl-filter-scan-input proc (substring string (1+ end)))) (setq dbl-filter-accumulator string))) (dbl-filter-insert proc "\032") (dbl-filter-scan-input proc (substring string 1))) (setq dbl-filter-accumulator string))) (defun dbl-filter-scan-input (proc string) (if (equal string "") (setq dbl-filter-accumulator nil) (let ((start (string-match "\032" string))) (if start (progn ;; to do fix this so that if dbl-last-frame ;; changed, then set the current text property.. ;; (dbl-filter-insert proc (substring string 0 start)) (dbl-filter-accumulate-marker proc (substring string start)) ) (dbl-filter-insert proc string))))) (defun dbl-filter-insert (proc string) (let (moving output-after-point (old-buffer (current-buffer)) start) (set-buffer (process-buffer proc)) ;; test to see if we will move the point. We want that the ;; window-point of the buffer, should be equal to process-mark. (setq moving (>= (window-point (get-buffer-window (process-buffer proc))) (- (process-mark proc) 0))) (setq output-after-point (< (point) (process-mark proc))) (unwind-protect (save-excursion ;; Insert the text, moving the process-marker. (goto-char (process-mark proc)) (setq start (point)) (insert string) (set-marker (process-mark proc) (point)) ; (setq bill (cons (list 'hi (process-mark proc) (marker-position (process-mark proc)) (point)) bill)) (dbl-maybe-delete-prompt) ;; Check for a filename-and-line number. (dbl-display-frame ;; Don't display the specified file ;; unless (1) point is at or after the position where output appears ;; and (2) this buffer is on the screen. (or output-after-point (not (get-buffer-window (current-buffer)))) ;; Display a file only when a new filename-and-line-number appears. t) ) (if moving (set-window-point (get-buffer-window (process-buffer proc)) (process-mark proc))) (set-buffer old-buffer)) )) (defun dbl-sentinel (proc msg) (cond ((null (buffer-name (process-buffer proc))) ;; buffer killed ;; Stop displaying an arrow in a source file. (setq overlay-arrow-position nil) (set-process-buffer proc nil)) ((memq (process-status proc) '(signal exit)) ;; Stop displaying an arrow in a source file. (setq overlay-arrow-position nil) ;; Fix the mode line. (setq mode-line-process (concat ": " (symbol-name (process-status proc)))) (let* ((obuf (current-buffer))) ;; save-excursion isn't the right thing if ;; process-buffer is current-buffer (unwind-protect (progn ;; Write something in *compilation* and hack its mode line, (set-buffer (process-buffer proc)) ;; Force mode line redisplay soon (set-buffer-modified-p (buffer-modified-p)) (if (eobp) (insert ?\n mode-name " " msg) (save-excursion (goto-char (point-max)) (insert ?\n mode-name " " msg))) ;; If buffer and mode line will show that the process ;; is dead, we can delete it now. Otherwise it ;; will stay around until M-x list-processes. (delete-process proc)) ;; Restore old buffer, but don't restore old point ;; if obuf is the dbl buffer. (set-buffer obuf)))))) (defun dbl-refresh () "Fix up a possibly garbled display, and redraw the arrow." (interactive) (redraw-display) (dbl-display-frame)) (defun dbl-display-frame (&optional nodisplay noauto) "Find, obey and delete the last filename-and-line marker from DBL. The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n. Obeying it means displaying in another window the specified file and line." (interactive) (dbl-set-buffer) (and dbl-last-frame (not nodisplay) (or (not dbl-last-frame-displayed-p) (not noauto)) (progn (dbl-display-line (car dbl-last-frame) (cdr dbl-last-frame)) (setq dbl-last-frame-displayed-p t)))) ;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen ;; and that its line LINE is visible. ;; Put the overlay-arrow on the line LINE in that buffer. (defun dbl-find-file (file) (cond ((file-exists-p file) (find-file-noselect file)) ((get-buffer file)) (t (find-file-noselect file)))) (defvar dbl-dirs nil) (defun search-path (file dirs) (let ((paths (symbol-value dirs)) true-file) (cond ((file-exists-p file) (setq true-file file)) (t (while paths (let ((tem (expand-file-name file (or (car paths) default-directory)))) (if (file-exists-p tem) (setq true-file tem)) (setq paths (cdr paths)))))) (cond (true-file) (t (setq paths (symbol-value dirs)) (set dirs (append paths (list (file-name-directory (read-file-name (format "%s = %s, add path :" dirs paths)))))) (search-path file dirs))))) (defun dbl-find-line () "If the current buffer has a process, then look first for a file-line property, and if none, then search for a regexp. If a non process buffer, just return current file and line number. " (interactive) (save-excursion (end-of-line) (cond ((get-buffer-process (current-buffer)) (cond ((save-excursion (beginning-of-line) (get-text-property (point) 'file-line))) ((progn (end-of-line) (re-search-backward " \\([^: ]+\\):\\([0-9]+\\)" 300 nil)) (setq file (buffer-substring (match-beginning 1) (match-end 1))) (setq line (buffer-substring (match-beginning 2) (match-end 2))) (setq line (read line)) (and (integerp line) (setq file (search-path file 'dbl-dirs)) (list file line))))) (t (list (buffer-file-name) (+ 1 (count-lines (point)))))))) (defun dbl-find-and-display-line () (interactive) (let ((res (dbl-find-line))) (and res (apply 'dbl-display-line res)))) (defun dbl-display-line (true-file line) (let* ((buffer (dbl-find-file true-file)) (window (display-buffer buffer t)) (pos)) (save-excursion (set-buffer buffer) (save-restriction (widen) (goto-line line) (setq pos (point)) (setq overlay-arrow-string "=>") (or overlay-arrow-position (setq overlay-arrow-position (make-marker))) (set-marker overlay-arrow-position (point) (current-buffer))) (cond ((or (< pos (point-min)) (> pos (point-max))) (widen) (goto-char pos)))) (set-window-point window overlay-arrow-position))) (defvar dbl-gdb-command-alist '((":step %p" . "step %p") (":next %p" . "next %p") (":stepi" . "stepi %p") (":r" . "r") (":finish" . "finish") (":up %p" . "up %p") ( ":down %p" . "down %p"))) (defun dbl-call (command numeric) "Invoke dbl COMMAND displaying source in other window." (interactive) (save-excursion (goto-char (point-max)) (beginning-of-line) (let (com) (cond ((or (looking-at "(gdb") (member major-mode '(c-mode c++-mode))) (if (setq com (assoc command dbl-gdb-command-alist)) (setq command (cdr com)))))) ;; to do put in hook here to recognize whether at ;; maxima or lisp level. (setq command (dbl-subtitute-% command numeric)) (goto-char (point-max)) (setq dbl-delete-prompt-marker (point-marker)) (dbl-set-buffer) (send-string (get-buffer-process current-dbl-buffer) (concat command "\n")))) (defun dbl-subtitute-% (command n) (let* (result (in-dbl (get-buffer-process (current-buffer))) file-line ) (cond ((string-match "%[fl]" command) (cond (in-dbl (setq file-line (dbl-find-line))) (t (setq file-line (list (buffer-file-name) (+ 1 (count-lines (point))))))))) (while (and command (string-match "\\([^%]*\\)%\\([adeflp]\\)" command)) (let ((letter (string-to-char (substring command (match-beginning 2)))) subst) (cond ((eq letter ?p) (setq subst (if n (int-to-string n) ""))) ((eq letter ?f) (setq subst (or (car file-line) "unknown-file"))) ((eq letter ?l) (setq subst (if (cadr file-line) (int-to-string (cadr file-line)) "unknown-line"))) ((eq letter ?a) (setq subst (dbl-read-address)))) (setq result (concat result (substring command (match-beginning 1) (match-end 1)) subst))) (setq command (substring command (match-end 2)))) (concat result command))) (defun dbl-maybe-delete-prompt () (if (and dbl-delete-prompt-marker (> (point-max) (marker-position dbl-delete-prompt-marker))) (let (start) (goto-char dbl-delete-prompt-marker) (setq start (point)) (beginning-of-line) (delete-region (point) start) (setq dbl-delete-prompt-marker nil)))) (defun dbl-break () "Set DBL breakpoint at this source line." (interactive) (cond ((eq major-mode 'lisp-mode) (save-excursion (end-of-line) (let (name at where) (setq where (point)) (mark-defun) (search-forward "(def") (forward-sexp 2) (setq at (point)) (forward-sexp -1) (setq name (buffer-substring (point) at)) (beginning-of-line) (setq name (format "(si::break-function '%s %s t)" name (count-lines 1 where))) (other-window 1) (if (get-buffer-process (current-buffer)) (setq current-dbl-buffer (current-buffer))) (message name) (send-string (get-buffer-process current-dbl-buffer) (concat name "\n")) (other-window 1) ))) (t (let ((file-name (file-name-nondirectory buffer-file-name)) (line (save-restriction (widen) (1+ (count-lines 1 (point)))))) (and downcase-filenames-for-dbl (setq file-name (downcase file-name))) (send-string (get-buffer-process current-dbl-buffer) (concat "break " file-name ":" line "\n")))))) (defun dbl-read-address() "Return a string containing the core-address found in the buffer at point." (save-excursion (let ((pt (dot)) found begin) (setq found (if (search-backward "0x" (- pt 7) t)(dot))) (cond (found (forward-char 2)(setq result (buffer-substring found (progn (re-search-forward "[^0-9a-f]") (forward-char -1) (dot))))) (t (setq begin (progn (re-search-backward "[^0-9]") (forward-char 1) (dot))) (forward-char 1) (re-search-forward "[^0-9]") (forward-char -1) (buffer-substring begin (dot))))))) (defvar dbl-commands nil "List of strings or functions used by send-dbl-command. It is for customization by you.") (defun send-dbl-command (arg) "This command reads the number where the cursor is positioned. It then inserts this ADDR at the end of the dbl buffer. A numeric arg selects the ARG'th member COMMAND of the list dbl-print-command. If COMMAND is a string, (format COMMAND ADDR) is inserted, otherwise (funcall COMMAND ADDR) is inserted. eg. \"p (rtx)%s->fld[0].rtint\" is a possible string to be a member of dbl-commands. " (interactive "P") (let (comm addr) (if arg (setq comm (nth arg dbl-commands))) (setq addr (dbl-read-address)) (if (eq (current-buffer) current-dbl-buffer) (set-mark (point))) (cond (comm (setq comm (if (stringp comm) (format comm addr) (funcall comm addr)))) (t (setq comm addr))) (switch-to-buffer current-dbl-buffer) (goto-char (dot-max)) (insert-string comm))) (provide 'dbl) gcl/elisp/doc-to-texi.el000077500000000000000000000103201242227143400154150ustar00rootroot00000000000000 (load "../gcl-tk/convert.el") ;(let ((i 2000)) (while (> i 0) (do-one) (setq i (- i 1)))) (defun get-match (i) (buffer-substring (match-beginning i) (match-end i))) (defun list-matches (l) (let (ans) (while l (setq ans (cons (get-match (car l)) ans))) (nreverse ans))) (defun do-one () (interactive) () (beginning-of-line) (re-search-forward "" nil t) (let ((beg (point)) def (end (save-excursion (re-search-forward "" nil t) (point)))) (cond ((looking-at "F\\([^\n]+\\)\n\\([^\n]+\\) in \\([A-Z_a-z]+\\) package[:]?[\n ]\\(Args\\|Syntax\\): ") (let ((fun (get-match 1)) (type (get-match 2)) (package (get-match 3)) args body) (goto-char (match-end 0)) (cond ((equal (get-match 4) "Syntax") (setq args "") (beginning-of-line)) (t (setq args (progn (let ((beg (point))) (forward-sexp 1) (buffer-substring beg (point))))))) (setq body (buffer-substring (point) (- end 1))) (delete-region beg end ) (save-excursion (get-buffer-create package) (set-buffer package) (goto-char (point-max)) (insert (if (equal type "Function") (setq def "@defun") (concat (setq def "@deffn") " {" type "}")) " " fun " " args "\nPackage:" package "\n" body) (insert "\n@end " (substring def 1) "\n") ))) ((looking-at "V\\([^\n]+\\)\n\\([^\n]+\\) in \\([A-Z_a-z]+\\) package:\n") (let ((fun (get-match 1)) (type (get-match 2)) (package (get-match 3)) args body) (goto-char (match-end 0)) (setq body (buffer-substring (point) (- end 1))) (delete-region beg end ) (save-excursion (get-buffer-create package) (set-buffer package) (goto-char (point-max)) (insert (if (string-match "^\\*" fun) (setq def "@defvar") (concat (setq def "@defvr")" {Constant}")) " " fun " " "\nPackage:" package "\n" body ) (insert "\n@end " (substring def 1) "\n"))))))) (defun do-some () (interactive) (while (re-search-forward "{Constant}" nil t) (let* ((tem (read-char )) (u (cdr (assoc tem '((?s . "{Special Variable}") (?d . "{Declaration}")))))) (if u (replace-match u))))) (setq b-alist '((?n . "number.texi") (?s . "sequence.texi") (?c . "character.texi") (?l . "list.texi") (?i . "io.texi") (?a . "internal.texi") (?f . "form.texi") (?C . "compile.texi") (?S . "symbol.texi") (?t . "system.texi") (?d . "structure.texi") (?I . "iteration.texi") (?u . "user-interface.texi") (?d . "doc.texi") (?b . "type.texi") )) (defun try1 () (interactive) (while (re-search-forward "\n@def" nil t) (let ((beg (match-beginning 0)) me tem (end (save-excursion (re-search-forward "\n@end def[a-z]+" nil t) (point)))) (sit-for 0 300) (setq tem (read-char )) (cond ((setq tem (cdr (assoc tem b-alist))) (setq me (buffer-substring beg end)) (delete-region beg end) (forward-char -2) (save-excursion (get-buffer-create tem) (set-buffer tem) (goto-char (point-max)) (insert me "\n"))))))) (setq xall (mapcar 'cdr b-alist)) ;(let ((all xall)) (while all (set-buffer (car all)) (write-file (car all)) (setq all (cdr all)))) ;(let ((all xall)) (while all (find-file (car all)) (setq all (cdr all)))) (let ((all xall) x) (while all (set-buffer (car all)) (goto-char (point-min)) (insert "@node " (setq x (capitalize (car all))) "\n@chapter "x"\n") (write-file (car all)) (set-buffer "gcl-si.texi")(goto-char (point-max)) (insert "\\n@include " (car all) "\n") (setq all (cdr all)))) (let ((all xall) x) (while all (switch-to-buffer (car all)) (goto-char (point-min)) (insert "@node " (setq x (capitalize (car all))) "\n@chapter "x"\n") (save-buffer) (set-buffer "gcl-si.texi")(goto-char (point-max)) (insert "\\n@include " (car all) "\n") (setq all (cdr all)))) (let ((all xall) x) (while all (switch-to-buffer (car all)) (goto-char (point-min)) (insert "@node " (setq x (capitalize (car all))) "\n@chapter "x"\n") (save-buffer) (set-buffer "gcl-si.texi")(goto-char (point-max)) (insert "\\n@include " (car all) "\n") (setq all (cdr all)))) gcl/elisp/gcl.el000077500000000000000000000266531242227143400140460ustar00rootroot00000000000000;; Copyright William F. Schelter. 1994 ;; Licensed by GNU public license. ;; You should copy isp-complete.el to the emacs/lisp directory. ;; Some commands and macros for dealing with lisp ;; M-X run : run gcl or another lisp ;; m-c-x ; evaluate defun in the other window or in the last lisp which you were using. ;; m-c-x ; with a numeric arg : compile the current defun in the other window ;; m-c-d ; disassemble in other window. ;; M-x macroexpand-next : macro expand the next sexp in other window. ;; C-h d Find documentation on symbol where the cursor is. ;; C-h / Find documentation on all strings containing a given string. ;; M-p complete the current input by looking back through the buffer to see what was last typed ;; using this prompt and this beginning. Useful in shell, in lisp, in gdb,... (setq lisp-mode-hook 'remote-lisp) (autoload 'lisp-complete "lisp-complete" nil t) (autoload 'smart-complete "smart-complete" nil t) ;(global-set-key "p" 'lisp-complete) (global-set-key "p" 'smart-complete) (defun remote-lisp (&rest l) (and (boundp 'lisp-mode-map) lisp-mode-map (progn (define-key lisp-mode-map "\e\C-d" 'lisp-send-disassemble) (define-key lisp-mode-map "\e\C-x" 'lisp-send-defun-compile) (make-local-variable 'lisp-package) (setq lisp-package nil) (and (boundp 'remote-lisp-hook) (funcall remote-lisp-hook)) ))) (defvar search-back-for-lisp-package-p nil) ;; look at the beginning of buffer to try to find an in package statement (defun get-buffer-package () "Returns what it thinks is the lisp package for the current buffer. It caches this information in the local variable `lisp-package'. It obtains the information from searching for the first in-package from the beginning of the file. Since in common lisp, there is only supposed to be one such statement, it should be able to determine this. By setting lisp-package to t, you may disable its search. This will also disable the automatic inclusion of an in-package statement in the tmp-lisp-file, used for sending forms to the current lisp-process." (cond ((eq lisp-package t) nil) (search-back-for-lisp-package-p (save-excursion (cond ((re-search-backward "^[ \t]*(in-package " nil t) (goto-char (match-end 0)) (read (current-buffer)))))) (lisp-package lisp-package) (t (setq lisp-package (let (found success) (save-excursion (goto-char (point-min)) (while (not found) (if (and (setq success (search-forward "(in-package " 1000 t)) (not (save-excursion (beginning-of-line) (looking-at "[ \t]*;")))) (setq found (read (current-buffer)))) (if (>= (point) 980) (setq found t)) (or success (setq found t)) )) found))))) (defun run (arg) "Run an inferior Lisp process, input and output via buffer *lisp*." (interactive "sEnter name of file to run: ") (require 'sshell) ;; in emacs 19 uncomment: ;;(require 'inf-lisp) (setq lisp-mode-hook 'remote-lisp) (switch-to-buffer (make-sshell (concat arg "-lisp") arg nil "-i")) (make-local-variable 'shell-prompt-pattern) (setq sshell-prompt-pattern "^[^#%)>]*[#%)>]+ *") (cond ((or (string-match "maxima" arg) (string-match "affine" arg) (save-excursion (sleep-for 2) (re-search-backward "maxima" (max 1 (- (point) 300)) t))) (require 'maxima-mode) (inferior-maxima-mode) (goto-char (point-max)) ) (t (if (boundp 'inferior-lisp-mode) (inferior-lisp-mode) (funcall lisp-mode-hook)) ))) (defun lisp-send-disassemble (arg) (interactive "P") (if arg ( lisp-send-defun-compile "disassemble-h") ( lisp-send-defun-compile "disassemble")) ) (defvar time-to-throw-away nil) (defvar telnet-new-line "") (defun lisp-send-defun-compile (arg) "Send the current defun (or other form) to the lisp-process. If there is a numeric arg, the form (compile function-name) is also sent. The value of lisp-process will be the process of the other exposed window (if there is one) or else the global value of lisp-process. If the ...received message is not received, probably either the reading of the form caused an error. If the process does not have telnet in its name, then we write a tmp file and load it. If :sdebug is in *features*, then si::nload is used instead of ordinary load, in order to record line information for debugging. The value of `lisp-package' if non nil, will be used in putting an in-package statement at the front of the tmp file to be loaded. `lisp-package' is determined automatically on a per file basis, by get-buffer-package. " (interactive "P") (other-window 1) (let* ((proc (or (get-buffer-process (current-buffer)) lisp-process)) def beg (this-lisp-process proc) (lisp-buffer (process-buffer this-lisp-process)) fun) (other-window 1) (save-excursion (end-of-defun) (let ((end (dot)) (buffer (current-buffer)) (proc (get-process this-lisp-process))) (setq lisp-process proc) (beginning-of-defun) (save-excursion (cond ((and arg (looking-at "(def")) (setq def t)) (t (setq arg nil))) (cond (def (forward-char 2)(forward-sexp 1) (setq fun (read buffer)) (setq fun (prin1-to-string fun)) (message (format "For the lisp-process %s: %s" (prin1-to-string this-lisp-process) fun))))) (cond ((equal (char-after (1- end)) ?\n) (setq end (1- end)) )) (setq beg (dot)) (my-send-region this-lisp-process beg end) )) (send-string this-lisp-process (concat ";;end of form" "\n" telnet-new-line)) (cond (arg (if (numberp arg) (setq arg "compile")) (send-string this-lisp-process (concat "(" arg "'" fun ")" telnet-new-line)))) (and time-to-throw-away (string-match "telnet"(buffer-name (process-buffer proc))) (dump-output proc time-to-throw-away)) (cond (nil ;(get-buffer-window lisp-buffer) (select-window (get-buffer-window lisp-buffer)) (goto-char (point-max))) (t nil)))) (fset 'lisp-eval-defun (symbol-function 'lisp-send-defun-compile)) (defvar telnet-new-line "") (defvar tmp-lisp-file (concat "/tmp/" (user-login-name) ".lsp")) (defun get-buffer-clear (name) (let ((cb (current-buffer)) (buf (get-buffer-create name))) (set-buffer buf) (erase-buffer) (set-buffer cb) buf)) (defmacro my-with-output-to-temp-buffer (name &rest body) (append (list 'let (list (list 'standard-output (list 'get-buffer-clear name)))) body)) (defun my-send-region (proc beg end) (cond ((or (string-match "telnet" (process-name proc))) (send-region proc beg end)) (t (let ((package (get-buffer-package))) (save-excursion (my-with-output-to-temp-buffer "*tmp-gcl*" (if (and package (not (eq package t))) (prin1 (list 'in-package package))) (princ ";!(:line ") (prin1 (let ((na (buffer-file-name (current-buffer)))) (if na (expand-file-name na) (buffer-name (current-buffer)))) ) (princ (- (count-lines (point-min) (+ beg 5)) 1)) (princ ")\n") (set-buffer "*tmp-gcl*") (write-region (point-min) (point-max) tmp-lisp-file nil nil))) (write-region beg end tmp-lisp-file t nil) (message "sending ..") (send-string proc (concat "(lisp::let ((*load-verbose* nil)) (#+sdebug si::nload #-sdebug load \"" tmp-lisp-file "\")#+gcl(setq si::*no-prompt* t)(values))\n ") ) (message (format "PACKAGE: %s ..done" (if (or (not package) (eq package t)) "none" package))) )))) (defun dump-output (proc seconds) "dump output for PROCESS for SECONDS or to \";;end of form\"" (let ((prev-filter (process-filter proc)) (already-waited 0)) (unwind-protect (progn (set-process-filter proc 'dump-filter) (while (< already-waited seconds) (sleep-for 1)(setq already-waited (1+ already-waited)))) (set-process-filter proc prev-filter)))) (defun dump-filter (proc string) ; (setq she (cons string she)) (let ((ind (string-match ";;end of form" string))) (cond (ind (setq string (substring string (+ ind (length ";;end of form")))) (message "... received.") (setq already-waited 1000) (set-process-filter proc prev-filter) (cond (prev-filter (funcall prev-filter proc string)) (t string))) (t "")))) ;;(process-filter (get-process "lisp")) (defun macroexpand-next () "macroexpand current form" (interactive) (save-excursion (let ((beg (point))) (forward-sexp ) (message "sending macro") (let* ((current-lisp-process (or (get-buffer-process (current-buffer)) (prog2 (other-window 1) (get-buffer-process (current-buffer)) (other-window 1))))) (send-string current-lisp-process "(macroexpand '") (send-region current-lisp-process beg (point) ) (send-string current-lisp-process ")\n"))))) (defun delete-comment-char (arg) (while (and (> arg 0) (looking-at comment-start)) (delete-char 1) (setq arg (1- arg)))) (defun mark-long-comment () (interactive) (let ((at (point))) (beginning-of-line) (while(and (not (eobp)) (or (looking-at comment-start) ;(looking-at "[ ]*\n") )) (forward-line 1)) (set-mark (point)) (goto-char at) (while(and (not (bobp)) (or (looking-at comment-start) ;(looking-at "[ ]*\n") )) (forward-line -1)) (or (bobp )(forward-line 1)))) (defun fill-long-comment () (interactive) (mark-long-comment) (let ((beg (min (dot) (mark))) (end (max (dot) (mark))) (n 0)m) (narrow-to-region beg end) (goto-char (point-min)) (while (looking-at ";") (forward-char 1)) (setq n (- (point) beg)) (goto-char (point-min)) (while (not (eobp)) (setq m n) (while (> m 0) (cond ((looking-at ";") (delete-char 1) (cond ((looking-at " ")(delete-char 1)(setq m 0))) (setq m (- m 1))) (t (setq m 0)))) (forward-line 1)) (fill-region (dot-min) (dot-max)) (goto-char (point-min)) (while (not (eobp)) (cond ((looking-at "\n") nil) (t(insert ";; "))) (forward-line 1)) (goto-char (point-min)) (set-mark (point-max)) (widen))) (defun comment-region (arg) "Comments the region, with a numeric arg deletes up to arg comment characters from the beginning of each line in the region. The region stays, so a second comment-region adds another comment character" (interactive "P") (save-excursion (let ((beg (dot)) (ok t)(end (mark))) (comment-region1 beg end arg)))) (defun comment-region1 (beg end arg) (let ((ok t)) (cond((> beg end) (let ((oth end)) (setq end beg beg oth)))) (narrow-to-region beg end) (goto-char beg) (unwind-protect (while ok (cond (arg (delete-comment-char arg)) (t (insert-string comment-start))) (if (< end (dot)) (setq ok nil) (if (search-forward "\n" end t) nil (setq ok nil))) ) (widen)))) (defun trace-expression () (interactive) (save-excursion (forward-sexp ) (let ((end (point))) (forward-sexp -1) (other-window 1) (let* ((proc (get-buffer-process (current-buffer))) (current-lisp-process (or proc lisp-process))) (other-window 1) (message "Tracing: %s" (buffer-substring (point) end)) (send-string current-lisp-process "(trace ") (send-region current-lisp-process (point) end) (send-string current-lisp-process ")\n"))))) (defun gcl-mode () (interactive) (lisp-mode) ) (provide 'gcl)gcl/elisp/makefile000066400000000000000000000014261242227143400144430ustar00rootroot00000000000000 -include ../makedefs install: mkdir -p $(DESTDIR)$(EMACS_SITE_LISP) cp *.el $(DESTDIR)$(EMACS_SITE_LISP) if [ "$(EMACS_DEFAULT_EL)" != "" ] ; then \ if test -f "$(DESTDIR)${EMACS_DEFAULT_EL}" ; then \ cat $(DESTDIR)${EMACS_DEFAULT_EL} | sed -e '/BEGIN gcl/,/END gcl/d' > $(DESTDIR)$(EMACS_SITE_LISP)/temp_emacs_default ; \ mv $(DESTDIR)${EMACS_DEFAULT_EL} $(DESTDIR)${EMACS_DEFAULT_EL}.prev ; \ rm -f $(DESTDIR)${EMACS_DEFAULT_EL}c ; \ cat add-default.el >> $(DESTDIR)$(EMACS_SITE_LISP)/temp_emacs_default ; cp $(DESTDIR)$(EMACS_SITE_LISP)/temp_emacs_default $(DESTDIR)${EMACS_DEFAULT_EL} ; \ rm -f $(DESTDIR)$(EMACS_SITE_LISP)/temp_emacs_default ; else \ cp add-default.el $(DESTDIR)${EMACS_DEFAULT_EL} ; fi ; \ chmod a+r $(DESTDIR)${EMACS_DEFAULT_EL} ; fi gcl/elisp/man1-to-texi.el000077500000000000000000000331161242227143400155140ustar00rootroot00000000000000;;;;if you are in a buffer which has a man page you can try ;; M-x doit, to do an at least partial conversion of tcl tk man pages to ;; texinfo ;; file for converting the tcl/tk man pages to texinfo and suitable for gcl/tk ; .bp begin new page ; .br break output line here ; .sp n insert n spacing lines ; .ls n (line spacing) n=1 single, n=2 double space ; .na no alignment of right margin ; .ce n center next n lines ; .ul n underline next n lines ; .sz +n add n to point size ; ; Requests ; Request Cause If no Explanation ; Break Argument ; ; .B t no t=n.t.l.* Text is in bold font. ; .BI t no t=n.t.l. Join words, alternating bold ; and italic. ; .BR t no t=n.t.l. Join words, alternating bold ; and roman. ; .DT no .5i 1i... Restore default tabs. ; .HP i yes i=p.i.* Begin paragraph with hanging ; indent. Set prevailing indent to i. ; .I t no t=n.t.l. Text is italic. ; .IB t no t=n.t.l. Join words, alternating italic ; and bold. ; ; .IP x i yes x="" Same as .TP with tag x. ; .IR t no t=n.t.l. Join words, alternating italic ; and roman. ; .IX t no - Index macro, for Sun internal ; use. ; .LP yes - Begin left-aligned paragraph. ; Set prevailing indent to .5i. ; .PD d no d=.4v Set vertical distance between ; paragraphs. ; .PP yes - Same as .LP. ; .RE yes - End of relative indent. ; Restores prevailing indent. ; .RB t no t=n.t.l. Join words, alternating roman ; and bold. ; .RI t no t=n.t.l. Join words, alternating roman ; and italic. ; .RS i yes i=p.i. Start relative indent, ; increase indent by i. Sets prevailing indent to ; .5i for nested indents. ; .SB t no - Reduce size of text by 1 ; point, make text boldface. ; .SH t yes - Section Heading. ; .SM t no t=n.t.l. Reduce size of text by 1 ; point. ; .SS t yes t=n.t.l. Section Subheading. ; .TH n s d f m ; yes - Begin reference page n, of ; section s; d is the date of the most ; recent change. If present, f ; is the left page footer; m is the ; main page (center) header. ; Sets prevailing indent and tabs to .5i. ; .TP i yes i=p.i. Begin indented paragraph, with ; the tag given on the next text ; line. Set prevailing indent ; to i. ; ; .TX t p no - Resolve the title abbreviation ; t; join to punctuation mark (or text) p. * ; n.t.l. = next text line; p.i. = prevailing ; indent ; .HS name section [date [version]] ; Replacement for .TH in other man pages. See below for valid ; section names. ; ; .AP type name in/out [indent] ; Start paragraph describing an argument to a library procedure. ; type is type of argument (int, etc.), in/out is either "in", "out", ; or "in/out" to describe whether procedure reads or modifies arg, ; and indent is equivalent to second arg of .IP (shouldn't ever be ; needed; use .AS below instead) ; ; .AS [type [name]] ; Give maximum sizes of arguments for setting tab stops. Type and ; name are examples of largest possible arguments that will be passed ; to .AP later. If args are omitted, default tab stops are used. ; ; .BS ; Start box enclosure. From here until next .BE, everything will be ; enclosed in one large box. ; ; .BE ; End of box enclosure. ; ; .VS ; Begin vertical sidebar, for use in marking newly-changed parts ; of man pages. ; ; .VE ; End of vertical sidebar. ; ; .DS ; Begin an indented unfilled display. ; ; .DE ; End of indented unfilled display. ; (defun do-replace (lis &optional not-in-string) (let (x case-fold-search) (while lis (setq x (car lis)) (setq lis (cdr lis)) (goto-char (point-min)) (message "doing %s " x) (while (re-search-forward (nth 0 x) nil t) (and not-in-string (progn (forward-char -1) (not (in-a-string)))) (let ((f (nth 1 x))) (cond ((stringp f) (replace-match f t)) (t (let ((i 0) ans) (while (match-beginning i) (setq ans (cons (buffer-substring (match-beginning i) (match-end i)) ans)) (setq i (+ i 1))) (setq ans (nreverse ans)) (goto-char (match-beginning 0)) (delete-region (match-beginning 0) (match-end 0)) (apply f ans))))))))) (defun doit () (interactive) (texinfo-mode) (goto-char (point-min)) (do-replace '(("@" "@@") ("^[.]VS\n" "") ("^[.]VE\n" "") )) (goto-char (point-min)) (insert "@setfilename foo.info") (insert "\n") (do-tables) ; (do-nf) (do-replace '( (".SH \"SEE ALSO\"\n\\([^\n]*\\)" "@xref{\\1}") ("^[.]SH NAME" "") ("^'[\\]\"[^\n]*\n" "") ("^'[/]\"[^\n]*\n" "") ("^[.]so[^\n]+\n" "") ("[.]HS \\([^ \n]+\\)\\([^\n]*\\)\n" "@node \\1\n@subsection \\1\n") ("^[.]VS\n" "") ("^[.]VE\n" "") (".nf\nName:\t\\([^\n]*\\)\nClass:\t\\([^\n]*\\)\nCommand-Line Switch:\t\\([^\n]*\\)\n.fi\n" do-keyword) ("Name:\t\\([^\n]*\\)\nClass:\t\\([^\n]*\\)\nCommand-Line Switch:\t\\([^\n]*\\)\n" do-keyword) ("Name:\t\\([^\n]*\\)\n" "@*@w{ Name: @code{\\1}}\n") ("Class:\t\\([^\n]*\\)\n" "@*@w{ Class: @code{\\1}}\n") ("Command-Line Switch:\t\\([^\n]*\\)\n" "@*@w{ Keyword: @code{\\1}}\n") ("[\\]-\\([a-z]\\)" ":\\1") ("^[.]nf\n" "@example\n") ("^[.]fi\n" "@end example\n") ("^[.]ta[^\n]*\n" do-ta) ("^[.]IP\n" "\n") ("[\\]f\\([A-Z]\\)\\([^\\\n]*\\)[\\]f" do-font) ("^\\([^\n]+\\)\n[.]br" "@*@w{\\1}@*") ("^[.]SH \\([^\n]*\\)" (lambda (a0 a1) (insert "@unnumberedsubsec " (capitalize a1)))) ("[\\]fR" "") ("^[.]BS" "@cartouche") ("^[.]BE" "@end cartouche") ("^[.]sp \\([0-9]\\)" "@sp \\1") ("^[.]sp" "@sp 1") ("^[.]LP\n" "\n\n") ("^[.][LP]P" "") ("^[.]DS[^\n]*\n" "\n@example\n") ("^[.]DE[^\n]*\n" "@end example\n\n") ("^[.]DS[^\n]*\n" "\n@example\n") ("^[.]DE[^\n]*\n" "@end example\n\n") ("^[.]RS\n" "") ; relative indent increased.. ("^[.]rE\n" "") ("^[\\]&\\([^\n]*\\)\n" "@*@w{ \\1}\n") ; ("Command-Line Switch" "Keyword") ("pathName }@b{\\([a-z]\\)" "pathName }@b{:\\1") ("[\\]0" " ") ("%\\([a-z#]\\)\\([^a-zA-Z0-9%]\\)" "|%\\1|\\2") ("^[.]TP[^\n]*\n" "@item ") )) (add-keywords) ) (defun do-font (ign a b) (let ((ch (assoc (aref a 0) '((?R . "@r{") (?I . "@i{") (?B . "@b{"))))) (cond (ch (insert (cdr ch) b "}\\f") (forward-char -2) ) (t (error "unknown leter %s" a))))) (defun do-keyword (ign name class key) (insert "@table \n@item @code{"key "}" "\n@flushright\nName=@code{\""name"\"} Class=@code{\""class "\"}\n" "@end flushright\n@sp 1\n") (save-excursion (cond ((re-search-forward "[.]LP\\|[.]BE\\|[.]SH" nil t) (beginning-of-line) (insert "@end table\n"))))) (defun try () (interactive) (if (get-buffer "foo.texi") (kill-buffer (get-buffer "foo.texi"))) (if (get-buffer "foo.info") (kill-buffer (get-buffer "foo.info"))) (find-file "foo.n") (toggle-read-only 0) (doit) (write-file "foo.texi") (makeinfo-buffer )) (defun foo () (re-search-forward "\n\\|\\([\\]f[a-zA-Z]\\)" nil t) (list (match-beginning 0) (match-beginning 1) (match-beginning 2))) (defun list-current-line () (beginning-of-line) (let (ans at-end (beg (point))) (save-excursion (while (not at-end) (re-search-forward "\n\\|\\([\\]f[a-zA-Z]\\)" nil t) (if (match-beginning 1) (replace-match "") (setq at-end t)))) (setq at-end nil) (beginning-of-line) (while (not at-end) (re-search-forward "[\t\n]" nil t) (let ((x (buffer-substring beg (- (point) 1)))) (or (equal x "") (setq ans (cons x ans)))) (setq beg (point)) (setq at-end (equal (char-after (- (point) 1)) ?\n))) (nreverse ans) )) (defun do-ta (a0) (let ((beg (point)) items (vec (make-vector 10 0)) i (tot 0) surplus) (while (not (looking-at "[.][LDI]")) (cond ((looking-at "[.]")(forward-line 1)) (t (setq items (cons (list-current-line) items)) (let ((tem (car items)) (i 0)) (while tem (aset vec i (max (real-length (car tem)) (aref vec i))) (setq i (+ i 1)) (setq tem (cdr tem))) )))) ; (message "%s" (list beg (point))) ; (sit-for 1) (delete-region beg (point)) ; (forward-line -2) ; (message "%s" vec) ; (sit-for 2) (setq items (nreverse items)) (setq i 0) (while (< i (length vec)) (setq tot (+ (aref vec i) tot)) (setq i (+ i 1))) (setq surplus (/ (- 70 tot) (+ 1 (length (car items))))) (while items (setq tem (car items)) (setq i 0) (let (ans x) (insert "") (while tem (insert (tex-center (car tem) (+ (aref vec i) surplus) 'left (real-length (car tem)))) (setq tem (cdr tem)) (setq i (+ i 1))) (insert "\n")) (setq items (cdr items))) ) ) (defun real-length (item) (let* ((n (length item)) (m (- n 1)) (start 0)) (while (setq start (string-match "[\\]f" item start)) (setq n (- n 3)) (if (< start m) (setq start (+ start 1)))) n)) (defun do-tables () (goto-char (point-min)) (while (re-search-forward "^[.]TP" nil t) (beginning-of-line) (insert "\n@table @asis\n") (forward-line 2) (re-search-forward "^[.]\\(LP\\|BE\\|SH\\)" nil t) (beginning-of-line) (insert "@end table\n") )) (defun do-nf () (goto-char (point-min)) (while (re-search-forward "^[.]nf" nil t) (forward-line 1) (beginning-of-line) (while (not (looking-at "[.]fi")) (insert "@w{" ) (end-of-line) (insert "}") (forward-line 1) (beginning-of-line)))) (defun add-keywords () (let ((tem tk-control-options)x lis l y) (while tem (setq l (car tem)) (setq tem (cdr tem)) (setq x (symbol-name (car l ))) (setq lis (car (cdr l))) (while lis (cond ((atom lis) (setq lis nil)) (t (setq y (symbol-name (car lis))) (do-replace (list (list (concat x " "y "") (concat x " :"y "") ))))) (setq lis (cdr lis)))))) (setq tk-control-options '((after fixnum) (exit fixnum) (lower window) (place pathName (-anchor -bordermode -height -in -relheight -relwidth -relx -rely -width -x -y)) (send interpreter ) ;(TKVARS "invalid command name \"tkvars\"") (winfo (atom atomname cells children class containing depth exists fpixels geometry height id interps ismapped name parent pathname pixels reqheight reqwidth rgb rootx rooty screen screencells screendepth screenheight screenmmheight screenmmwidth screenvisual screenwidth toplevel visual vrootheight vrootwidth vrootx vrooty width x y) ) (focus (default none) ) (option (add clear get readfile)) (raise pathname) (tk colormodel) (tkwait ( variable visible window) ) (wm (aspect client command deiconify focusmodel frame geometry grid group iconbitmap iconify iconmask iconname iconposition iconwindow maxsize minsize overrideredirect positionfrom protocol sizefrom state title trace transient withdraw)) (destroy window) (grab (current release set status)) (pack window (-after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, -side) argggg) (selection (clear get handle own)) (tkerror "") (update (idletasks)) )) (setq tk-widget-options '( (button (activate configure deactivate flash invoke)) (listbox ( configure curselection delete get insert nearest scan select size xview yview)) (scale ( configure get set)) (canvas ( addtag bbox bind canvasx canvasy configure coords create dchars delete dtag find focus gettags icursor index insert itemconfigure lower move postscript raise scale scan select type xview yview)) (menu ( activate add configure delete disable enable entryconfigure index invoke post unpost yposition)) (scrollbar ( configure get set)) (checkbutton ( activate configure deactivate deselect flash invoke select toggle)) (menubutton ( activate configure deactivate)) (text ( compare configure debug delete get index insert mark scan tag yview)) (entry ( configure delete get icursor index insert scan select view)) (message ( configure)) (frame ( configure)) (label ( configure)) (radiobutton ( activate configure deactivate deselect flash invoke select)) (toplevel ( configure)) )) (setq manual-sections '(after bind button canvas checkbutton destroy entry exit focus foo frame grab label lbSingSel listbox lower menu menubar menubutton message option options pack-old pack place radiobutton raise scale scrollbar selection send text tk tkerror tkvars tkwait toplevel update winfo wm)) ;(setq widgets (sort (mapcar 'car tk-widget-options) 'string-lessp)) ;(let ((m manual-sections)(tem widgets)) (while tem (setq manual-sections (delete (car tem) manual-sections))(setq tem (cdr tem)))) gcl/elisp/readme000077500000000000000000000003541242227143400141250ustar00rootroot00000000000000 dbl.el: mode for source level debugging lisp much like the authors gdb.el gcl.el: mode for interacting with gcl sshell.el: old fashioned shell mode, used by dbl.el. lisp-complete.el: a history mechanism based on the prompt. gcl/elisp/smart-complete.el000066400000000000000000000117211242227143400162200ustar00rootroot00000000000000;; This file is part of GNU Emacs. ;; Copyright (C) 1998 William F. Schelter ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility ;; to anyone for the consequences of using it or for whether it serves ;; any particular purpose or works at all, unless he says so in writing. ;; Refer to the GNU Emacs General Public License for full details. ;; Everyone is granted permission to copy, modify and redistribute GNU ;; Emacs, but only under the conditions described in the GNU Emacs ;; General Public License. A copy of this license is supposed to have ;; been given to you along with GNU Emacs so you can know your rights and ;; responsibilities. It should be in a file named COPYING. Among other ;; things, the copyright notice and this notice must be preserved on all ;; copies. ;; By Bill Schelter wfs@math.utexas.edu ;; Completion on forms in the buffer. Does either a line or an sexp. ;; Uses the current prompt and the beginning of what you have typed. ;; Thus If the buffer contained ;; (dbm:3) load("jo" ;; (C11) lo("ji") ;; (gdb) last ;; maxima>>4 ;; /home/bil# ls ;; then if you are at a prompt ;; "(C15) l" would match lo("ji") only, not "last", not "ls" nor load(" ;; and the commands with the (gdb) prompt would only match ones ;; starting with (gdb) .. ;; also if the command is a lisp sexp and this would be longer than the ;; current line, it grabs the whole thing. sometimes we have different ;; prompts, for different programs and we dont want to confuse the input ;; from one with input for another. Generally the prompt matches a ;; previous prompt, with numbers matching any number, and if there are ;; '/' then match anything up to a shell prompt terminator. Note it does ;; this without additional consing or building up huge lists of inputs. (if (boundp 'comint-mode-map) (define-key comint-mode-map "\ep" 'smart-complete) ) (if (boundp 'sshell-mode-map) (define-key sshell-mode-map "\ep" 'smart-complete) (define-key sshell-mode-map "\M-p" 'smart-complete) ) (defun get-match-n (i ) (buffer-substring (match-beginning i) (match-end i))) (defun smart-complete () "Begin to type the command and then type M-p. You will be offered in the minibuffer a succession of choices, which you can say 'n' to to get the next one, or 'y' or 'space' to grab the current one. Thus to get the last command starting with 'li' you type liM-py " (interactive ) (let ((point (point)) new str tem prompt) (save-excursion (beginning-of-line) (cond ((looking-at sshell-prompt-pattern) (setq prompt (get-match-n 0)) (setq str (buffer-substring (match-end 0) point))) (t (error "Your prompt on this line does not match sshell-prompt-pattern"))) (setq new (smart-complete2 prompt str)) ) (cond (new (delete-region (setq tem (- point (length str))) point) (goto-char tem) (insert new))))) (defun smart-complete2 (prompt str) (let ((pt (point)) found (pat (concat (regexp-for-this-prompt prompt) "\\(" (regexp-quote str) "\\)" )) offered (not-yet t) ) (setq bill pat) (while (and not-yet (re-search-backward pat nil t)) (goto-char (match-beginning 1)) (setq at (match-beginning 1)) (goto-char at) (setq this (buffer-substring at (save-excursion (end-of-line) (point)))) (or (member this offered) (equal this str) (progn (setq offered (cons this offered)) ;; do this so the display does not shift... (goto-char pt) (setq not-yet (not (y-or-n-p (concat "Use: " this " ")))))) (cond (not-yet (goto-char at) (beginning-of-line) (forward-char -1)) (t (setq found (save-excursion (buffer-substring at (progn (goto-char at) (max (save-excursion (end-of-line) (point)) (save-excursion (forward-sexp 1)(point))) ))))))) (or found (message "No more matches")) found )) ;; return a regexp for this prompt but with numbers replaced. (defun split-string-gcl (s bag) (cond ((equal (length s) 0) '("")) ((string-match bag s) (if (= (match-beginning 0) 0) (cons "" (split-string-gcl (substring s (match-end 0)) bag)) (cons (substring s 0 (match-beginning 0)) (split-string-gcl (substring s (match-end 0)) bag)))) (t (cons s nil)))) ;; Return a regexp which matches the current prompt, and which ;; allows things like ;; "/foo/bar# " to match "any# " ;; "(C12) " to match "(C1002) " but not (gdb) nor "(D12) " ;; if the prompt appears to be a pathname (ie has /) then ;; allow any beginning, otherwise numbers match numbers... (defun regexp-for-this-prompt (prompt ) (let ((wild (cond ((string-match "/" prompt) "[^ >#%()]+") (t "[0-9]+")))) (let ((tem (split-string-gcl prompt wild)) (ans "")) (while tem (setq ans (concat ans (regexp-quote (car tem)))) (cond ((cdr tem) (setq ans (concat ans wild)))) (setq tem (cdr tem))) ans))) (provide 'smart-complete) gcl/elisp/sshell.el000077500000000000000000000320031242227143400145550ustar00rootroot00000000000000 ;; Run subshell under Emacs ;; Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc. ;; Modifications by William Schelter ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 1, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;; The following is a "simple shell" much like the one in version 18 ;; of emacs. Unfortunately cmint breaks most code which tries to use ;; the shell mode, and is rather complex. ;; This mode uses a better completion mechanism (smart-complete.el), ;; in that it should ;; find the input you really want with your typing less keystrokes, ;; and easier keystrokes to type (defvar last-input-start nil "In a sshell-mode buffer, marker for start of last unit of input.") (defvar last-input-end nil "In a sshell-mode buffer, marker for end of last unit of input.") (defvar sshell-mode-map nil) (defvar sshell-directory-stack nil "List of directories saved by pushd in this buffer's sshell.") (defvar sshell-popd-regexp "popd" "*Regexp to match subsshell commands equivalent to popd.") (defvar sshell-pushd-regexp "pushd" "*Regexp to match subsshell commands equivalent to pushd.") (defvar sshell-cd-regexp "cd" "*Regexp to match subsshell commands equivalent to cd.") (defvar explicit-sshell-file-name nil "*If non-nil, is file name to use for explicitly requested inferior sshell.") ;In loaddefs.el now. (defconst sshell-prompt-pattern "\\(^\\|\n\\)[^ >]*[>$)%#:][>]*[ ]*" "*Regexp used by Newline command to match subsshell prompts. Anything from beginning of line up to the end of what this pattern matches is deemed to be prompt, and is not reexecuted.") (defun sshell-mode () "Major mode for interacting with an inferior sshell. Sshell name is same as buffer name, sans the asterisks. Return at end of buffer sends line as input. Return not at end copies rest of line to end and sends it. The following commands imitate the usual Unix interrupt and editing control characters: \\{sshell-mode-map} Entry to this mode calls the value of sshell-mode-hook with no args, if that value is non-nil. cd, pushd and popd commands given to the sshell are watched by Emacs to keep this buffer's default directory the same as the sshell's working directory. Variables sshell-cd-regexp, sshell-pushd-regexp and sshell-popd-regexp are used to match these command names. You can send text to the sshell (or its subjobs) from other buffers using the commands process-send-region, process-send-string and lisp-send-defun." (interactive) (kill-all-local-variables) (setq major-mode 'sshell-mode) (setq mode-name "Sshell") (setq mode-line-process '(": %s")) (use-local-map sshell-mode-map) (make-local-variable 'sshell-directory-stack) (setq sshell-directory-stack nil) (make-local-variable 'last-input-start) (setq last-input-start (make-marker)) (make-local-variable 'last-input-end) (setq last-input-end (make-marker)) (run-hooks 'sshell-mode-hook)) (if sshell-mode-map nil (setq sshell-mode-map (make-sparse-keymap)) (define-key sshell-mode-map "\t" 'sshell-complete-filename) (define-key sshell-mode-map "\C-m" 'sshell-send-input) (define-key sshell-mode-map "\C-c\C-d" 'sshell-send-eof) (define-key sshell-mode-map "\C-c\C-u" 'kill-sshell-input) (define-key sshell-mode-map "\C-c\C-w" 'backward-kill-word) (define-key sshell-mode-map "\C-c\C-c" 'interrupt-sshell-subjob) (define-key sshell-mode-map "\C-c\C-z" 'stop-sshell-subjob) (define-key sshell-mode-map "\C-c\C-\\" 'quit-sshell-subjob) (define-key sshell-mode-map "\C-c\C-o" 'kill-output-from-sshell) (define-key sshell-mode-map "\C-c\C-r" 'show-output-from-sshell) (define-key sshell-mode-map "\C-c\C-y" 'copy-last-sshell-input)) (defun sshell-complete-filename () (interactive) (let* ((p (point)) tem beg (ff (save-excursion (skip-chars-backward "[a-z---_0-9$/A-Z~#.]") (buffer-substring (setq beg (point)) p)))) (setq dir (or (file-name-directory ff) default-directory)) (setq file (file-name-nondirectory ff)) (cond ((and (setq tem (file-name-completion (or file "") dir)) (not (equal tem file))) (cond ((eq tem t)) (t (delete-region beg p) (insert (concat dir tem))))) (t (let ((lis (file-name-all-completions file dir))) (with-output-to-temp-buffer "*completions*" (display-completion-list lis)) ))))) (defvar explicit-csh-args (if (eq system-type 'hpux) ;; -T persuades HP's csh not to think it is smarter ;; than us about what terminal modes to use. '("-i" "-T") '("-i")) "Args passed to inferior sshell by M-x sshell, if the sshell is csh. Value is a list of strings, which may be nil.") (defun sshell () "Run an inferior sshell, with I/O through buffer *sshell*. If buffer exists but sshell process is not running, make new sshell. Program used comes from variable explicit-sshell-file-name, or (if that is nil) from the ESHELL environment variable, or else from SHELL if there is no ESHELL. If a file ~/.emacs_SHELLNAME exists, it is given as initial input (Note that this may lose due to a timing error if the sshell discards input when it starts up.) The buffer is put in sshell-mode, giving commands for sending input and controlling the subjobs of the sshell. See sshell-mode. See also variable sshell-prompt-pattern. The sshell file name (sans directories) is used to make a symbol name such as `explicit-csh-arguments'. If that symbol is a variable, its value is used as a list of arguments when invoking the sshell. Otherwise, one argument `-i' is passed to the sshell. Note that many people's .cshrc files unconditionally clear the prompt. If yours does, you will probably want to change it." (interactive) (let* ((prog (or explicit-sshell-file-name (getenv "ESHELL") (getenv "SHELL") "/bin/sh")) (name (file-name-nondirectory prog))) (switch-to-buffer (apply 'make-sshell "shell" prog (if (file-exists-p (concat "~/.emacs_" name)) (concat "~/.emacs_" name)) (let ((symbol (intern-soft (concat "explicit-" name "-args")))) (if (and symbol (boundp symbol)) (symbol-value symbol) '("-i"))))))) (defun make-sshell (name program &optional startfile &rest switches) (let ((buffer (get-buffer-create (concat "*" name "*"))) proc status size) (setq proc (get-buffer-process buffer)) (if proc (setq status (process-status proc))) (save-excursion (set-buffer buffer) ;; (setq size (buffer-size)) (if (memq status '(run stop)) nil (if proc (delete-process proc)) (setq proc (apply 'start-process name buffer (or program explicit-sshell-file-name (getenv "ESHELL") (getenv "SHELL") "/bin/sh") switches)) (cond (startfile ;;This is guaranteed to wait long enough ;;but has bad results if the sshell does not prompt at all ;; (while (= size (buffer-size)) ;; (sleep-for 1)) ;;I hope 1 second is enough! (sleep-for 1) (goto-char (point-max)) (insert-file-contents startfile) (setq startfile (buffer-substring (point) (point-max))) (delete-region (point) (point-max)) (process-send-string proc startfile))) (setq name (process-name proc))) (goto-char (point-max)) (set-marker (process-mark proc) (point)) (sshell-mode)) buffer)) (defvar sshell-set-directory-error-hook 'ignore "Function called with no arguments when sshell-send-input recognizes a change-directory command but gets an error trying to change Emacs's default directory.") (defun sshell-send-input () "Send input to subsshell. At end of buffer, sends all text after last output as input to the subsshell, including a newline inserted at the end. When not at end, copies current line to the end of the buffer and sends it, after first attempting to discard any prompt at the beginning of the line by matching the regexp that is the value of sshell-prompt-pattern if possible. This regexp should start with \"^\"." (interactive) (or (get-buffer-process (current-buffer)) (error "Current buffer has no process")) (end-of-line) (if (eobp) (progn (move-marker last-input-start (process-mark (get-buffer-process (current-buffer)))) (insert ?\n) (move-marker last-input-end (point))) (beginning-of-line) ;; Exclude the sshell prompt, if any. (re-search-forward sshell-prompt-pattern (save-excursion (end-of-line) (point)) t) (let ((copy (buffer-substring (point) (progn (forward-line 1) (point))))) (goto-char (point-max)) (move-marker last-input-start (point)) (insert copy) (move-marker last-input-end (point)))) ;; Even if we get an error trying to hack the working directory, ;; still send the input to the subsshell. (condition-case () (save-excursion (goto-char last-input-start) (sshell-set-directory)) (error (funcall sshell-set-directory-error-hook))) (let ((process (get-buffer-process (current-buffer))) (s (buffer-substring last-input-start last-input-end)) ) ;; avoid sending emacs's idea of what an international character ;; set string is to a subprocess.. (if (fboundp 'string-make-unibyte) (setq s (string-make-unibyte s))) (process-send-string process s) (set-marker (process-mark process) (point)))) ;;; If this code changes (sshell-send-input and sshell-set-directory), ;;; the customization tutorial in ;;; info/customizing-tutorial must also change, since it explains this ;;; code. Please let marick@gswd-vms.arpa know of any changes you ;;; make. (defun sshell-set-directory () (cond ((and (looking-at sshell-popd-regexp) (memq (char-after (match-end 0)) '(?\; ?\n))) (if sshell-directory-stack (progn (cd (car sshell-directory-stack)) (setq sshell-directory-stack (cdr sshell-directory-stack))))) ((looking-at sshell-pushd-regexp) (cond ((memq (char-after (match-end 0)) '(?\; ?\n)) (if sshell-directory-stack (let ((old default-directory)) (cd (car sshell-directory-stack)) (setq sshell-directory-stack (cons old (cdr sshell-directory-stack)))))) ((memq (char-after (match-end 0)) '(?\ ?\t)) (let (dir) (skip-chars-forward "^ ") (skip-chars-forward " \t") (if (file-directory-p (setq dir (expand-file-name (substitute-in-file-name (buffer-substring (point) (progn (skip-chars-forward "^\n \t;") (point))))))) (progn (setq sshell-directory-stack (cons default-directory sshell-directory-stack)) (cd dir))))))) ((looking-at sshell-cd-regexp) (cond ((memq (char-after (match-end 0)) '(?\; ?\n)) (cd (getenv "HOME"))) ((memq (char-after (match-end 0)) '(?\ ?\t)) (let (dir) (forward-char 3) (skip-chars-forward " \t") (if (file-directory-p (setq dir (expand-file-name (substitute-in-file-name (buffer-substring (point) (progn (skip-chars-forward "^\n \t;") (point))))))) (cd dir)))))))) (defun sshell-send-eof () "Send eof to subsshell (or to the program running under it)." (interactive) (process-send-eof)) (defun kill-output-from-sshell () "Kill all output from sshell since last input." (interactive) (goto-char (point-max)) (beginning-of-line) (kill-region last-input-end (point)) (insert "*** output flushed ***\n") (goto-char (point-max))) (defun show-output-from-sshell () "Display start of this batch of sshell output at top of window. Also put cursor there." (interactive) (set-window-start (selected-window) last-input-end) (goto-char last-input-end)) (defun copy-last-sshell-input () "Copy previous sshell input, sans newline, and insert before point." (interactive) (insert (buffer-substring last-input-end last-input-start)) (delete-char -1)) (defun interrupt-sshell-subjob () "Interrupt this sshell's current subjob." (interactive) (interrupt-process nil t)) (defun kill-sshell-subjob () "Send kill signal to this sshell's current subjob." (interactive) (kill-process nil t)) (defun quit-sshell-subjob () "Send quit signal to this sshell's current subjob." (interactive) (quit-process nil t)) (defun stop-sshell-subjob () "Stop this sshell's current subjob." (interactive) (stop-process nil t)) (defun kill-sshell-input () "Kill all text since last stuff output by the sshell or its subjobs." (interactive) (kill-region (process-mark (get-buffer-process (current-buffer))) (point))) (require 'smart-complete) (provide 'sshell)gcl/eval.html000077500000000000000000000051521242227143400134470ustar00rootroot00000000000000 Tcl Evaluator-In-A-Page

Tcl Evaluator-in-a-Page

[Sun Home | Tcl Plugin | Demos]

Below is a little evaluator for Tcl commands. Type any valid Tcl command in and see the result immediately. Check out our quick tour of the Tcl syntax. For example, to create a new button, type the following: 

button .b -text hello -background red
pack .b
When you're done with the button, type: 
destroy .b
and it's gone. You may also want to use the puts command to output results from within loops. For example: 
foreach proc [info procs] {
    puts "$proc [info args $proc]"
}

To learn more about Tcl, read either Brent Welch'sor John Ousterhout's Tcl books. Many more Tcl and Tk resources are available here.

Source:

Here is the source for the evaluator application: 


# A frame, scrollbar, and text
frame .eval
set _t [text .eval.t -width 40 -height 15 -yscrollcommand {.eval.s set}]
scrollbar .eval.s -command {.eval.t yview}
pack .eval.s -side left -fill y
pack .eval.t -side right -fill both -expand true
pack .eval -fill both -expand true

# Insert the prompt and initialize the limit mark
.eval.t insert insert "Tcl eval log\n"
set prompt "tcl> "
.eval.t insert insert $prompt
.eval.t mark set limit insert
.eval.t mark gravity limit left
focus .eval.t

# Keybindings that limit input and eval things
bind .eval.t <Return> { _Eval .eval.t ; break }
bind .eval.t <Any-Key> {
	if [%W compare insert < limit] {
		%W mark set insert end
	}
}
bindtags .eval.t {.eval.t Text all}

proc _Eval { t } {
	global prompt
	set command [$t get limit end]
	if [info complete $command] {
		$t insert insert \n
		set err [catch {uplevel #0 $command} result]
		if {[string length $result] > 0} {
		    $t insert insert $result\n
		}
		$t insert insert $prompt
		$t see insert
		$t mark set limit insert
		return
	} else {
		$t insert insert \n
	}
}
proc puts {args} {
    if {[string match -nonewline* $args]} {
	set args [lrange $args 1 end]
	set nonewline 1
    }
    .eval.t insert end [lindex $args end]	;# Ignore file specifier
    if ![info exists nonewline] {
	.eval.t insert end \n
    }
}
gcl/eval.tcl000077500000000000000000000036311242227143400132650ustar00rootroot00000000000000# A frame, scrollbar, and text frame .eval set _t [text .eval.t -width 40 -height 15 -yscrollcommand {.eval.s set}] scrollbar .eval.s -command {.eval.t yview} pack .eval.s -side left -fill y pack .eval.t -side right -fill both -expand true pack .eval -fill both -expand true # Insert the prompt and initialize the limit mark .eval.t insert insert "Tcl eval log\n" set prompt "tcl> " .eval.t insert insert $prompt .eval.t mark set limit insert .eval.t mark gravity limit left focus .eval.t # Keybindings that limit input and eval things bind .eval.t { _Eval .eval.t ; break } bind .eval.t { if [%W compare insert < limit] { %W mark set insert end } } bind .eval.t { if {[%W tag nextrange sel 1.0 end] != ""} { %W delete sel.first sel.last } elseif [%W compare insert > limit] { %W delete insert-1c %W see insert } break } bindtags .eval.t {.eval.t Text all} proc _Eval { t } { global prompt set command [$t get limit end] if [info complete $command] { $t insert insert \n $t mark set limit insert set err [catch {uplevel #0 $command} result] if {[string length $result] > 0} { $t insert insert $result\n } $t insert insert $prompt $t see insert $t mark set limit insert return } else { $t insert insert \n } } rename puts putsSystem proc puts args { if {[llength $args] > 3} { error "invalid arguments" } set newline "\n" if {[string match "-nonewline" [lindex $args 0]]} { set newline "" set args [lreplace $args 0 0] } if {[llength $args] == 1} { set chan stdout set string [lindex $args 0]$newline } else { set chan [lindex $args 0] set string [lindex $args 1]$newline } if [regexp (stdout|stderr) $chan] { .eval.t mark gravity limit right .eval.t insert limit $string .eval.t see limit .eval.t mark gravity limit left } else { putsSystem -nonewline $chan $string } } gcl/faq000077500000000000000000000050521242227143400123230ustar00rootroot00000000000000 october 22, 1995 =============== Question: On my dec alpha-osf1 and irix 5 can i save an image with compiled functions? Answer: These two systems use the o/fasldlsym.c module, which uses the system call dl_open to do the loading of object files, from dynamic libraries. While this provides fast loading of .o files into a running image we do not know where those objects are located, or how to save an image once they are loaded. So in short the answer is NO, not at the moment.. These unixes no longer support the simple old 'ld -A' option which let one build a .o and read it into memory where one wanted. If you have a large system with a lot of preinitialization code, you COULD build an image in the same manner the actual lisp itself is built. Ie essentially add more files to the main link. si::save-system does work, it just wont work after you dynamically load in .o files. I do this for the build of maxima (in version >= maxima-5.1). Look at the files maxima-5.1/src/{makefile,sysinit.lsp}. Basically you need to compile your files with the :system-p t flag, so that an init function for each file based on the file name is produced. Then you have to arrange for those init functions to be called at startup, then you save as is done in building the lisp. ============= Question: Are tcl 7.4 and tk 4.0 compatible with gcl 2.2. Answer: Not really. Some things will work but others wont. The demos in the demos directory certainly wont all work, they are based on tk 3.6. They presumably could be rewritten based on their newer counterparts. I do not know of what other changes are necessary... In some sense the separation between gcl and tcl/tk is fairly complete so in PRINCIPLE the changes required should only be those to user code, caused by changes to the tk library. One would need to add perhaps some new calls to def-widget, eg in tkl.lisp adding (def-widget listbox) if 'listbox' were a new widget type. (def-control send) (def-control raise) if 'send' or 'control' were new functions.. Also one should update the gcl-tk info stuff from the using gcl-2.2/elisp/man1-to-texi.el you can also use You can use gcl-2.2/gcl-tk/convert.el as a start on using emacs to convert other (tcl/tk 4.0) code to lisp, to have their new demos in lisp for testing purposes. ============ Question: Is there a port to mach 10 on the mac. Answer: Not yet. This would be good.. Emacs is ported there. I dont know if it saves itself however...i had heard it does not. I believe they are using the macintosh native executable format.... =========== gcl/gcl-tk/000077500000000000000000000000001242227143400130055ustar00rootroot00000000000000gcl/gcl-tk/comm.c000077500000000000000000000160751242227143400141200ustar00rootroot00000000000000 #include #ifndef NO_DEFUN #ifndef DEFUN #define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,doc) ret fname #endif #endif #ifndef HZ #define HZ 60 #endif #ifndef SET_TIMEVAL #define SET_TIMEVAL(t,timeout) \ t.tv_sec = timeout/HZ; t.tv_usec = (int) ((timeout%HZ)*(1000000.0)/HZ) #endif DEFUN_NEW("CHECK-FD-FOR-INPUT",object,fScheck_fd_for_input, SI,2,2,NONE,OI,IO,OO,OO,(fixnum fd,fixnum timeout), "Check FD a file descriptor for data to read, waiting TIMEOUT clicks \ for data to become available. Here there are \ INTERNAL-TIME-UNITS-PER-SECOND in one second. Return is 1 if data \ available on FD, 0 if timeout reached and -1 if failed.") { fd_set inp; int n; struct timeval t; SET_TIMEVAL(t,timeout); FD_ZERO(&inp); FD_SET(fd, &inp); n = select(fd + 1, &inp, NULL, NULL, &t); if (n < 0) return make_fixnum1(-1); else if (FD_ISSET(fd, &inp)) return make_fixnum1(1); else return make_fixnum1(0); } #ifdef STATIC_FUNCTION_POINTERS object fScheck_fd_for_input(fixnum fd,fixnum timeout) { return FFN(fScheck_fd_for_input)(fd,timeout); } #endif #define MAX_PACKET 1000 #define MUST_CONFIRM 2000 #define OUR_SOCK_MAGIC 0206 /* Each write and read will be of a packet including information about how many we have read and written. Sometimes we must read more messages, in order to check whether the one being sent has info about bytes_received. */ struct connection_state * setup_connection_state(fd) { struct connection_state * res; res = (void *)malloc(sizeof(struct connection_state)); bzero(res,sizeof(struct connection_state)); res->fd = fd; res->read_buffer_size = READ_BUFF_SIZE; res->read_buffer = (void *)malloc(READ_BUFF_SIZE); res->valid_data = res->read_buffer; res->max_allowed_in_pipe = MAX_ALLOWED_IN_PIPE; res->write_timeout = 30* 100; return res; } /* P is supposed to start with a hdr and run N bytes. */ static void scan_headers(sfd) struct connection_state *sfd; { struct our_header *hdr; char *p = sfd->valid_data + sfd->next_packet_offset; int n = sfd->valid_data_size - sfd->next_packet_offset; int length,received; while (n >= HDR_SIZE) { hdr = (void *)p; if (hdr->magic != OUR_SOCK_MAGIC) abort(); GET_2BYTES(&hdr->received, received); STORE_2BYTES(&hdr->received, 0); sfd->bytes_sent_not_received -= received; GET_2BYTES(&hdr->length, length); p += length; n -= length; } } static int write1(struct connection_state *,const char *,int); static void send_confirmation(struct connection_state *sfd) { write1(sfd,0,0); } /* read from SFD to buffer P M bytes. Allow TIMEOUT delay while waiting for data to arrive. return number of bytes actually read. The data arrives on the pipe packetized, but is unpacketized by this function. It gets info about bytes that have been received by the other process, and updates info in the state. */ static int read1(sfd,p,m,timeout) struct connection_state* sfd; char *p; int timeout; int m; { int nread=0; int wanted = m; int length; struct our_header *hdr; if (wanted == 0) goto READ_SOME; TRY_PACKET: if (sfd->next_packet_offset > 0) { int mm = (sfd->next_packet_offset >= wanted ? wanted : sfd->next_packet_offset); { bcopy(sfd->valid_data,p,mm); p += mm; sfd->valid_data+= mm; sfd->valid_data_size -= mm; sfd->next_packet_offset -= mm; } wanted -= mm; if (0 == wanted) return m; } /* at beginning of a packet */ if (sfd->valid_data_size >= HDR_SIZE) { hdr = (void *) sfd->valid_data; GET_2BYTES(&hdr->length,length); } else goto READ_SOME; if (length > sfd->valid_data_size) goto READ_SOME; /* we have a full packet available */ {int mm = (wanted <= length - HDR_SIZE ? wanted : length - HDR_SIZE); /* mm = amount to copy */ { bcopy(sfd->valid_data+HDR_SIZE,p,mm); p += mm; sfd->valid_data+= (mm +HDR_SIZE); sfd->valid_data_size -= (mm +HDR_SIZE); sfd->next_packet_offset = length - (mm + HDR_SIZE); wanted -= mm; } if (0 == wanted) return m; goto TRY_PACKET; } READ_SOME: if (sfd->read_buffer_size - sfd->valid_data_size < MAX_PACKET) { char *tmp ; tmp = (void *) malloc(2* sfd->read_buffer_size); if (tmp == 0) error("out of free space"); bcopy(sfd->valid_data,tmp,sfd->valid_data_size); free(sfd->read_buffer); sfd->valid_data = sfd->read_buffer = tmp; sfd->read_buffer_size *= 2; } if(sfd->read_buffer_size - (sfd->valid_data - sfd->read_buffer) < MAX_PACKET) { bcopy(sfd->valid_data,sfd->read_buffer,sfd->valid_data_size); sfd->valid_data=sfd->read_buffer;} /* there is at least a packet size of space available */ if ((fix(FFN(fScheck_fd_for_input)(sfd->fd,sfd->write_timeout))>0)); again: {char *start = sfd->valid_data+sfd->valid_data_size; nread = SAFE_READ(sfd->fd,start, sfd->read_buffer_size - (start - sfd->read_buffer)); } if (nread<0) {if (errno == EAGAIN) goto again; return -1;} if (nread == 0) { return 0; } sfd->total_bytes_received += nread; sfd->bytes_received_not_confirmed += nread; sfd->valid_data_size += nread; if(sfd->bytes_received_not_confirmed > MUST_CONFIRM) send_confirmation(sfd); scan_headers(sfd); goto TRY_PACKET; } /* send BYTES chars from buffer P to CONNECTION. They are packaged up with a hdr */ static void write_timeout_error(char *); static void connection_failure(char *); int write1(sfd,p,bytes) struct connection_state *sfd; const char *p; int bytes; { int bs; int to_send = bytes; BEGIN: bs = sfd->bytes_sent_not_received; if (bs > sfd->max_allowed_in_pipe) {read1(sfd,0,0,sfd->write_timeout); if (bs > sfd->bytes_sent_not_received) goto BEGIN; write_timeout_error(""); } {struct our_header *hdr; char buf[MAX_PACKET]; int n_to_send = (bytes > MAX_PACKET -HDR_SIZE ? MAX_PACKET : bytes+HDR_SIZE); hdr = (void *) buf; STORE_2BYTES(&hdr->length, n_to_send); hdr->magic = OUR_SOCK_MAGIC; STORE_2BYTES(&hdr->received, sfd->bytes_received_not_confirmed); sfd->bytes_received_not_confirmed =0; sfd->bytes_sent_not_received += n_to_send; bcopy(p, buf+HDR_SIZE,n_to_send - HDR_SIZE); AGAIN: { int n = write(sfd->fd,buf,n_to_send); if (n == n_to_send); else if (n < 0) { if (errno == EAGAIN) { goto AGAIN; } else connection_failure(""); } else abort(); } p += (n_to_send -HDR_SIZE); bytes -= (n_to_send -HDR_SIZE); if (bytes==0) return to_send; goto BEGIN; } } DEFUN_NEW("CLEAR-CONNECTION",object,fSclear_connection,SI,1,1,NONE,OI,OO,OO,OO,(fixnum fd), "Read on FD until nothing left to read. Return number of bytes read") {char buffer[0x1000]; int n=0; while (fix(FFN(fScheck_fd_for_input)(fd,0))) { n+=read(fd,buffer,sizeof(buffer)); } return make_fixnum1(n); } #ifdef STATIC_FUNCTION_POINTERS object fSclear_connection(fixnum fd) { return FFN(fSclear_connection)(fd); } #endif gcl/gcl-tk/convert.el000077500000000000000000000146521242227143400150220ustar00rootroot00000000000000 (defun try () (interactive) (goto-char (point-min)) (if (looking-at "#") (insert ";;")) (grab-variables) (goto-char (point-min)) (do-replacements '(("\n\\([ \t]*\\)#" "\n\\1;;") ("catch {destroy $w}" "(if (winfo :exists w) (destroy w))") ("\\[tk colormodel [$]w\\] == \"color\"" "equal (tk :colormodel w) \"color\"") )) (goto-char (point-min)) (replace-proc) (goto-char (point-min)) (replace-if) (goto-char (point-min)) (separate-lines) (goto-char (point-min)) (replace-keywords) (do-replacements '(("@[$]tk_library\\([^ \t\n]+\\)" "\"@\" : *tk-library* : \"\\1\""))) (goto-char (point-min)) (replace-$-in-string) (goto-char (point-min)) (do-replacements *replacements*) (goto-char (point-min)) (do-replacements '(( "[$]\\([a-z0-9A-Z]+\\)\\([)} \n]\\)" "\\1\\2"))) (do-replacements '(( " \\([0-9][0-9.]*[cmpi]\\)" " \"\\1\"") ("\\(:create\\|:tag\\|:add\\|:scan\\:select\\:mark\\) \\([a-z]\\)" "\\1 :\\2") ; (":add \\([a-z]\\)" ":add '\\1") )) (do-replacements '(("\\([ \t]\\)[.]\\([a-z0-9A-Z.]*\\)" "\\1'.\\2") ("'[.] " "'|.| ") ("((conc " "(funcall (conc ")) t) ) (defun grab-variables () (let (tem) (setq the-variables nil) (while (re-search-forward "[$]\\([a-zA-Z0-9]+\\)" nil t) (setq tem (buffer-substring (match-beginning 1) (match-end 1))) (or (member tem the-variables) (setq the-variables (cons tem the-variables)))))) (defun separate-lines () (interactive) (while (re-search-forward "\n[ \t]*[^;#() \n]" nil t) (forward-char -1) (cond ((or (looking-at "}") (looking-at "for"))) (t ; (forward-sexp -1) (insert "(") (re-search-forward "[^\\]\n" nil t) (forward-char -1)(insert ")") )))) (defun replace-keywords () (interactive) (while (re-search-forward "\\([ \t]\\)-\\([a-zA-Z]\\)" nil t) (replace-match "\\1:\\2") (forward-sexp 1) (skip-chars-forward " ") (cond ((looking-at "[a-z]") (insert "\"")(forward-sexp 1) (insert "\"")))) (goto-char (point-min)) (while (re-search-forward "(\\([^ ]+\\)" nil t) (let ((tem (buffer-substring (match-beginning 1)(match-end 0)))) ; (message (princ tem)) (sit-for 1) (cond ((equal tem "defun")(forward-line 1)(beginning-of-line)) ((member tem '("defun" "set"))) (t (skip-chars-forward " ") (cond ((looking-at "[a-z]") (insert ":")))))))) (defvar the-variables nil) (defun replace-$-in-string () (interactive) (let (tem beg (end (make-marker ))) (while (re-search-forward "\\([^\\]\\)[$]\\([a-zA-Z0-9]+\\)" nil t) (forward-char -1) (cond ((in-a-string) (goto-char this-string-began ) (setq beg (point)) (insert "(tk-conc ") (setq beg (point)) (forward-sexp 1) (set-marker end (point)) (insert ")") (goto-char beg) (while (re-search-forward "\\([^\\]\\)[$]\\([a-zA-Z0-9]+\\)" end t) (replace-match "\\1\" \\2 \"")) (goto-char (- beg 2)) (while (re-search-forward " \"\"" end t) (replace-match "")) (set-marker end nil) )) ))) (defun change-{-to-paren () (interactive) (let (end) (cond ((search-forward "{" nil t) (forward-char -1) (let ((p (point))) (forward-sexp 1) (delete-region (- (point) 1)(point)) (insert ")") (setq end (point)) (goto-char p) (delete-region p (+ p 1)) (insert "(")) (goto-char end) t)))) (defun in-a-string () (interactive) (save-excursion (save-match-data (let ((p (point)) (c 0)) (beginning-of-line) (while (re-search-forward "[^\\]\"" p t) (setq this-string-began (+ 1 (match-beginning 0))) (setq c (+ c 1))) (eql 1 (mod c 2)))))) (defun replace-proc () (interactive) (while (re-search-forward "[ \t\n]\\(proc\\) " nil t) (goto-char (match-beginning 1)) (delete-region (match-beginning 1) (match-end 0)) (insert "(defun ") (forward-sexp 1) (skip-chars-forward " \n\t") (cond ((looking-at "{{") (change-{-to-paren) (forward-sexp -1) (forward-char 1) (insert "&optional ") (change-{-to-paren)) ((looking-at "{") (change-{-to-paren))) (change-{-to-paren) (forward-sexp -1) (delete-char 1))) (defun replace-if () (interactive) (while (re-search-forward "[ \t\n]\\(if\\) " nil t) (goto-char (match-beginning 1)) (delete-region (match-beginning 1) (match-end 0)) (insert "(if ") (skip-chars-forward " \n\t") (cond ((looking-at "{") (change-{-to-paren))) (skip-chars-forward " \n\t") (cond ((looking-at "{") (change-{-to-paren) (save-excursion (forward-sexp -1) (forward-char 1) (insert "progn ")))) (skip-chars-forward " \n\t") (cond ((looking-at "else") (replace-match ";;else \n") (skip-chars-forward " \n\t") (cond ((looking-at "{") (change-{-to-paren) (save-excursion (forward-sexp -1) (forward-char 1) (insert "progn ")))) (insert ")") )))) (setq *replacements* '( ("[$]\\([a-zA-Z0-9]+\\)[.][$]\\([a-zA-Z0-9]+\\)[.]\\([a-z0-9A-Z.]+\\)" "(conc \\1 '|.| \\2 '.\\3)") ("[$]\\([a-zA-Z0-9]+\\)[.][$]\\([a-zA-Z0-9)]+\\)" "(conc \\1 '|.| \\2)") ("[$]\\([a-zA-Z0-9]+\\)[.]\\([a-z0-9A-Z.)]+\\)" "(conc \\1 '.\\2\)") ("\\(<[a-z0-9A-Z---]+>\\)" "\"\\1\"") ("[[]expr \\([a-z$A-Z0-9]+\\)\\([ ]*[+---*][ ]*\\)\\([a-z$A-Z0-9]+\\)\\]" "(\\2 \\1 \\3)") ("[[]expr \\([a-z$A-Z0-9]+\\)\\]" "\\1") ("($\\([a-z0-9A-Z]+\\)[.]\\([a-z0-9A-Z.]+\\)" "(funcall (conc \\1 '.\\2)") ("($\\([a-z0-9A-Z]+\\)" "(funcall \\1") ("[[]$\\([a-z0-9A-Z]+\\)\\([^]]+\\)\\]" "(funcall \\1\\2)") ("[{]$\\([a-z0-9A-Z]+\\)\\([^}]+\\)\\}" "(funcall \\1\\2)") ("[\\]\n" "\n") ("\n\\([ \t]*\\)#" "\n\\1;") ("(set " "(setq ") ("tk_menuBar" "tk-menu-bar") ("@\\([$a-zA-Z0-9]+\\),\\([$a-zA-Z0-9]+\\)" "(aT \\1 \\2)") ("\\(:variable\\)[ ]+\"\\([a-zA-Z0-9]+\\)\"" "\\1 '\\2") ("\\(:textvariable\\)[ ]+\"\\([a-zA-Z0-9]+\\)\"" "\\1 '\\2") (":font -" ":font :") (":create \\([a-z]+\\)" ":create \"\\1\"") )) (defun do-replacements (lis &optional not-in-string) (let (x) (while lis (setq x (car lis)) (setq lis (cdr lis)) (goto-char (point-min)) (while (re-search-forward (nth 0 x) nil t) (and not-in-string (progn (forward-char -1) (not (in-a-string)))) (replace-match (nth 1 x) t))))) gcl/gcl-tk/decode.tcl000066400000000000000000000206421242227143400147400ustar00rootroot00000000000000# this file contains the protocol for receiving connections from GCL and # other lisps [or other languages] # The communication is via a socket, and the data is packaged up into # packets, which we track letting the other side know how much is actually # received. This protocol is to prevent problems with flooding a # communications channel. The sender knows how many bytes are in the pipe. # the outer wrapper is # { char magic; # unsigned short length; /* including the header */ # unsigned short received; /* incremental number of bytes received at the # other end of the channel */ # # (MAGIC1 MAGIC2 TYPE FLAG BODY-LENGTH NIL NIL MSG-INDEX NIL NIL) set GclMTypes { m_not_used m_create_command m_reply m_call m_tcl_command m_tcl_command_wait_response m_tcl_clear_connection m_tcl_link_text_variable m_set_lisp_loc m_tcl_set_text_variable m_tcl_unlink_text_variable} proc GclDecodeMsg { msg } { # char magic1; \06 # char magic2; 'A' # char type; m_* # unsigned char flag; # unsigned char size[3]; /* of body */ # unsigned char msg_id[3]; # char body[1]; global GclMTypes if { [string match "\06A*" $msg] } { binary scan [string range $msg 2 end] ccsc type flag bodyLo bodyHi set bodyLength [expr ($bodyLo & 0xffff)+ ($bodyHi >> 16)] set index [msgIndex $msg] set ans "xMsg-id=$index, type= [lindex $GclMTypes $type], length=$bodyLength, body=[string range $msg 10 [expr 10 + $bodyLength-1]]" } else {set ans "invalidmsg:<$msg>" } } #proc GclmsgIndex { msg } { # binary scan [string range $msg 7 9] sc indLo indHi # set index [expr ($indLo & 0xffff)+ ($indHi >> 16)] # return $index #} proc Gclget3Bytes { s } { binary scan $s "sc" lo hi return [expr { ($lo & 0xffff) + ($hi << 16) }] } proc GclMake3Bytes { n } { return [ string range [binary format i $n] 0 2] } proc debugSend { msg } { puts stderr $msg flush stderr } proc GclAnswerSocket { host port pid } { global GclSock GclPdata GclPacket set sock [socket $host $port] setupPacket $sock fconfigure $sock -blocking 0 -translation {binary binary} # debugSend fconfigure:$sock:[fconfigure $sock] set GclSock $sock catch { unset GclPdata(data,$sock) } fileevent $sock readable "GclReadAndAct1 $sock" set GclPdata(pid,$sock) $pid return $sock } proc setupPacket { sock } { global GclPacket # data including 5 byte headers set GclPacket(indata,$sock) "" set GclPacket(received,$sock) 0 set GclPacket(sent_not_received,$sock) 0 # the data after stripping headers set GclPacket(outdata,$sock) "" } proc GclRead1 { sock } { global GclPacket upvar #0 GclPacket(indata,$sock) indata set recd 0 append indata [read $sock] set ll 0 while { [set l [string length $indata]] >= 5 } { binary scan $indata "css" magic length received # debugSend "magic=$magic,length=$length,received:=$received,indata=$indata" # -122 = signedchar(0206) if { $magic != -122 } { error "bad magic" } # debugSend "test: $l >= $length + 5" if { $l >= $length } { append GclPacket(outdata,$sock) [string range $indata 5 [expr $length -1]] set indata [string range $indata $length end] incr recd $received incr ll $length } else { break } } incr GclPacket(received,$sock) $ll if { $recd } { incr GclPacket(sent_not_received,$sock) -$recd } if { $GclPacket(received,$sock) > 1500 } { sendReceiveConfirmation $sock } set res $GclPacket(outdata,$sock) set GclPacket(outdata,$sock) "" # debugSend "GclRead1--><$res>" return $res } proc sendReceiveConfirmation { sock } { GclWrite1 $sock "" } proc GclWrite1 { sock data } { global GclPacket # debugSend "entering GclWrite1" set length [expr 5 + [string length $data]] set hdr \206[binary format ss $length $GclPacket(received,$sock)] # debugSend "hdr=$hdr, [array get GclPacket *]" set GclPacket(received,$sock) 0 incr GclPacket(sent_not_received,$sock) $length #debugSend "GclWrite1:<$hdr$data>" puts -nonewline $sock $hdr$data flush $sock } proc GclReadAndAct1 { sock } { global GclPdata GclMTypes upvar #0 GclPdata(data,$sock) msg set read [GclRead1 $sock] if { [string length $read] == 0 } { if { [eof $sock] } { # debugSend "exitting since $sock is closed" exit 1 } return "" } append msg $read while { [set l [string length $msg]] >= 10 } { #debugSend "msg=<$msg>" #debugSend [GclDecodeMsg $msg] binary scan $msg sccsc magic type flag bodyLo bodyHi if { $magic != 16646 } { error "bad magic:[string range $msg 0 1]" } set bodyLength [expr ($bodyLo & 0xffff)+ ($bodyHi >> 16)] if { $l >= 10+$bodyLength } { set toeval [list [lindex $GclMTypes $type] $msg [string range $msg 10 [expr 10 + $bodyLength-1]]] set msg [string range $msg [expr 10 + $bodyLength] end] #debugSend toeval=$toeval if { [catch { eval $toeval } err] } { puts stderr "error in [lindex $toeval 0] [string range [lindex $toeval 1 ] 0 13]... [lindex $toeval 2]: $err" flush stderr } } } } proc GclGetCString {s } { return [string range $s 0 [expr [string first \0 $s] -1]] } set GclSockMsgId 0 proc sock_write_str {typeflag text } { global GclSock GclSockMsgId set msg "\06A$typeflag[GclMake3Bytes [string length $text]][GclMake3Bytes [incr GclSockMsgId]]$text" #debugSend sending:[GclDecodeMsg $msg] GclWrite1 $GclSock $msg } proc GclGenericCommand { n arg } { global GclSock # 2 == [lsearch $GclMTypes m_reply] sock_write_str "\3\0" "[GclMake3Bytes $n]$arg" signalParent $GclSock } proc GclGenericCommandStringify { n arglist lis } { global GclSock set i 0 set ans "[GclMake3Bytes $n](" foreach v $lis { if { "s" == "[string range $arglist $i $i]" } { append ans " \"" $v "\"" } else { append ans " " $v } } append ans ")" sock_write_str "\3\0" $ans signalParent $GclSock } proc m_create_command { msg body } { #debugSend "in m_create_command" set n [Gclget3Bytes $body] set arglist [GclGetCString [string range $body 3 end]] # "debugSend callback_$n:args=\$args ; GclGenericCommandStringify $n $arglist \$args" \ if { "$arglist" == "" } { proc callback_$n { { arg1 "" } } "GclGenericCommand $n \$arg1" } else { proc callback_$n { args } "GclGenericCommandStringify $n $arglist \$args" } } proc m_tcl_command { msg body } { set body [string trimright $body "\0"] # set body [GclGetCString $body] # set fail [catch { eval $body } res] # set fail [catch { eval $body } res] eval $body # set com "update idletasks" #after cancel $com #after 5 $com # update idletasks # puts stderr "doing $body" ; flush stderr # debugSend "in eval of <$body>: fail=$fail,res=<$res>" } proc m_tcl_command_wait_response { msg body } { global GclSock set body [string trimright $body "\0"] # set body [GclGetCString $body] set fail [catch { eval $body } res] # 2 == [lsearch $GclMTypes m_reply] sock_write_str "\2\0" "$fail[string range $msg 7 9]$res" # debugSend " signalParent $GclSock" # no need to signal other side is waiting. # signalParent $GclSock } proc m_tcl_clear_connection { msg body } { global GclSock flush $GclSock set GclPdata($GclSock,data) "" } proc m_tcl_set_text_variable { msg body } { set n [string first \0 $body] set [string range $body 0 [expr $n -1]] [string range $body [expr $n+1] end] } proc m_tcl_link_text_variable { msg body } { global GclPdata set i [Gclget3Bytes $body] set name [string range $body 3 end] uplevel #0 trace variable wu $name "GclTellLispVarChanged $i" } proc signalParent1 {sock } { global GclPdata GclPacket if { $GclPacket(sent_not_received,$sock) } { exec kill -s SIGUSR1 $GclPdata(pid,$sock) & } } proc signalParent {sock } { global delay set com "signalParent1 $sock" after cancel $com after 5 $com } proc GclTellLispVarChanged { i name1 name2 op } { global GclPdata upvar #0 $name1 val # 8 == [lsearch $GclMTypes m_set_lisp_loc] sock_write_str \8\0 "[GclMake3Bytes $i]$val" signalParent $GclSock } proc m_tcl_unlink_text_variable { msg body } { set i [Gclget3Bytes $body] set name [string range $body 3 end] trace vdelete $name wu "GclTellLispVarChanged $i" } gcl/gcl-tk/demos-4.1/000077500000000000000000000000001242227143400144145ustar00rootroot00000000000000gcl/gcl-tk/demos-4.1/items.lisp000077500000000000000000000316361242227143400164420ustar00rootroot00000000000000;;# items.lisp -- This demo has been converted for tk4.1 from the ;; corresponding tcl demo program. ;; ;; This demonstration script creates a canvas that displays the ;; canvas item types. ;; ;; @(#) :items.tcl 1.5 95/10/04 15:00:39 (defun positionwindow (w) (wm :geometry w "+60+25") ) (setq w '.items) (if (winfo :exists w) (destroy w)) (toplevel w) (wm :title w "Canvas Item Demonstration") (wm :iconname w "Items") (positionWindow w) (setq c (conc w '.frame.c)) (setq font :Adobe-times-medium-r-normal--*-180* ) (label (conc w '.msg) :font font :wraplength "5i" :justify "left" :text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area.") (pack (conc w '.msg) :side "top") (frame (conc w '.buttons)) (pack (conc w '.buttons) :side "bottom" :expand "y" :fill "x" :pady "2m") (button (conc w '.buttons.dismiss) :text "Dismiss" :command (tk-conc "destroy " w)) (button (conc w '.buttons.code) :text "See Code" :command (tk-conc "showCode " w)) (pack (conc w '.buttons.dismiss) (conc w '.buttons.code) :side "left" :expand 1) (frame (conc w '.frame)) (pack (conc w '.frame) :side "top" :fill "both" :expand "yes") (canvas c :scrollregion "0c 0c 30c 24c" :width "15c" :height "10c" :relief "sunken" :borderwidth 2 :xscrollcommand (tk-conc w ".frame.hscroll set") :yscrollcommand (tk-conc w ".frame.vscroll set")) (scrollbar (conc w '.frame.vscroll) :command (tk-conc c " yview")) (scrollbar (conc w '.frame.hscroll) :orient "horiz" :command (tk-conc c " xview")) (pack (conc w '.frame.hscroll) :side "bottom" :fill "x") (pack (conc w '.frame.vscroll) :side "right" :fill "y") (pack c :in (conc w '.frame) :expand "yes" :fill "both") ;; Display a 3x3 rectangular grid. (funcall c :create "rect" "0c" "0c" "30c" "24c" :width 2) (funcall c :create "line" "0c" "8c" "30c" "8c" :width 2) (funcall c :create "line" "0c" "16c" "30c" "16c" :width 2) (funcall c :create "line" "10c" "0c" "10c" "24c" :width 2) (funcall c :create "line" "20c" "0c" "20c" "24c" :width 2) (setq font1 :Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*) (setq font2 :Adobe-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*) (if (> (winfo :depth c :return 'number) 1) (progn (setq blue "DeepSkyBlue3") (setq red "red") (setq bisque "bisque3") (setq green "SeaGreen3") ) ;;else (progn (setq blue "black") (setq red "black") (setq bisque "black") (setq green "black") )) ;; Set up demos within each of the areas of the grid. (funcall c :create "text" "5c" '.2c :text "Lines" :anchor "n") (funcall c :create "line" "1c" "1c" "3c" "1c" "1c" "4c" "3c" "4c" :width "2m" :fill blue :cap "butt" :join "miter" :tags "item") (funcall c :create "line" "4.67c" "1c" "4.67c" "4c" :arrow "last" :tags "item") (funcall c :create "line" "6.33c" "1c" "6.33c" "4c" :arrow "both" :tags "item") (funcall c :create "line" "5c" "6c" "9c" "6c" "9c" "1c" "8c" "1c" "8c" "4.8c" "8.8c" "4.8c" "8.8c" "1.2c" "8.2c" "1.2c" "8.2c" "4.6c" "8.6c" "4.6c" "8.6c" "1.4c" "8.4c" "1.4c" "8.4c" "4.4c" :width 3 :fill red :tags "item") (funcall c :create "line" "1c" "5c" "7c" "5c" "7c" "7c" "9c" "7c" :width '.5c :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :arrow "both" :arrowshape "15 15 7" :tags "item") (funcall c :create "line" "1c" "7c" "1.75c" "5.8c" "2.5c" "7c" "3.25c" "5.8c" "4c" "7c" :width '.5c :cap "round" :join "round" :tags "item") (funcall c :create "text" "15c" '.2c :text "Curves (smoothed :lines)" :anchor "n") (funcall c :create "line" "11c" "4c" "11.5c" "1c" "13.5c" "1c" "14c" "4c" :smooth "on" :fill blue :tags "item") (funcall c :create "line" "15.5c" "1c" "19.5c" "1.5c" "15.5c" "4.5c" "19.5c" "4c" :smooth "on" :arrow "both" :width 3 :tags "item") (funcall c :create "line" "12c" "6c" "13.5c" "4.5c" "16.5c" "7.5c" "18c" "6c" "16.5c" "4.5c" "13.5c" "7.5c" "12c" "6c" :smooth "on" :width "3m" :cap "round" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill red :tags "item") (funcall c :create "text" "25c" '.2c :text "Polygons" :anchor "n") (funcall c :create "polygon" "21c" "1.0c" "22.5c" "1.75c" "24c" "1.0c" "23.25c" "2.5c" "24c" "4.0c" "22.5c" "3.25c" "21c" "4.0c" "21.75c" "2.5c" :fill green :outline "black" :width 4 :tags "item") (funcall c :create "polygon" "25c" "4c" "25c" "4c" "25c" "1c" "26c" "1c" "27c" "4c" "28c" "1c" "29c" "1c" "29c" "4c" "29c" "4c" :fill red :smooth "on" :tags "item") (funcall c :create "polygon" "22c" "4.5c" "25c" "4.5c" "25c" "6.75c" "28c" "6.75c" "28c" "5.25c" "24c" "5.25c" "24c" "6.0c" "26c" "6c" "26c" "7.5c" "22c" "7.5c" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :outline "black" :tags "item") (funcall c :create "text" "5c" "8.2c" :text "Rectangles" :anchor "n") (funcall c :create "rectangle" "1c" "9.5c" "4c" "12.5c" :outline red :width "3m" :tags "item") (funcall c :create "rectangle" "0.5c" "13.5c" "4.5c" "15.5c" :fill green :tags "item") (funcall c :create "rectangle" "6c" "10c" "9c" "15c" :outline "" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item") (funcall c :create "text" "15c" "8.2c" :text "Ovals" :anchor "n") (funcall c :create "oval" "11c" "9.5c" "14c" "12.5c" :outline red :width "3m" :tags "item") (funcall c :create "oval" "10.5c" "13.5c" "14.5c" "15.5c" :fill green :tags "item") (funcall c :create "oval" "16c" "10c" "19c" "15c" :outline "" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item") (funcall c :create "text" "25c" "8.2c" :text "Text" :anchor "n") (funcall c :create "rectangle" "22.4c" "8.9c" "22.6c" "9.1c") (funcall c :create "text" "22.5c" "9c" :anchor "n" :font font1 :width "4c" :text "A short string of text, word-wrapped, justified left, and anchored north (at :the top). The rectangles show the anchor points for each piece of text." :tags "item") (funcall c :create "rectangle" "25.4c" "10.9c" "25.6c" "11.1c") (funcall c :create "text" "25.5c" "11c" :anchor "w" :font font1 :fill blue :text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." :justify "center" :tags "item") (funcall c :create "rectangle" "24.9c" "13.9c" "25.1c" "14.1c") (funcall c :create "text" "25c" "14c" :font font2 :anchor "c" :fill red :stipple "gray50" :text "Stippled characters" :tags "item") (funcall c :create "text" "5c" "16.2c" :text "Arcs" :anchor "n") (funcall c :create "arc" "0.5c" "17c" "7c" "20c" :fill green :outline "black" :start 45 :extent 270 :style "pieslice" :tags "item") (funcall c :create "arc" "6.5c" "17c" "9.5c" "20c" :width "4m" :style "arc" :outline blue :start -135 :extent 270 :outlinestipple "@" : *tk-library* : "/demos/images/gray25.bmp" :tags "item") (funcall c :create "arc" "0.5c" "20c" "9.5c" "24c" :width "4m" :style "pieslice" :fill "" :outline red :start 225 :extent -90 :tags "item") (funcall c :create "arc" "5.5c" "20.5c" "9.5c" "23.5c" :width "4m" :style "chord" :fill blue :outline "" :start 45 :extent 270 :tags "item") (funcall c :create "text" "15c" "16.2c" :text "Bitmaps" :anchor "n") (funcall c :create "bitmap" "13c" "20c" :bitmap "@" : *tk-library* : "/demos/images/face.bmp" :tags "item") (funcall c :create "bitmap" "17c" "18.5c" :bitmap "@" : *tk-library* : "/demos/images/noletter.bmp" :tags "item") (funcall c :create "bitmap" "17c" "21.5c" :bitmap "@" : *tk-library* : "/demos/images/letters.bmp" :tags "item") (funcall c :create "text" "25c" "16.2c" :text "Windows" :anchor "n") (button (conc c '.button) :text "Press Me" :command `(butpress ',c "red")) (funcall c :create "window" "21c" "18c" :window (conc c '.button) :anchor "nw" :tags "item") (entry (conc c '.entry) :width 20 :relief "sunken") (funcall (conc c '.entry) :insert "end" "Edit this text") (funcall c :create "window" "21c" "21c" :window (conc c '.entry) :anchor "nw" :tags "item") (scale (conc c '.scale) :from 0 :to 100 :length "6c" :sliderlength '.4c :width '.5c :tickinterval 0) (funcall c :create "window" "28.5c" "17.5c" :window (conc c '.scale) :anchor "n" :tags "item") (funcall c :create "text" "21c" "17.9c" :text "Button": :anchor "sw") (funcall c :create "text" "21c" "20.9c" :text "Entry": :anchor "sw") (funcall c :create "text" "28.5c" "17.4c" :text "Scale": :anchor "s") ;; Set up event bindings for canvas: (funcall c :bind "item" "" `(itemEnter ',c)) (funcall c :bind "item" "" `(itemLeave ',c)) (bind c "<2>" (tk-conc c " scan mark %x %y")) (bind c "" (tk-conc c " scan dragto %x %y")) (bind c "<3>" `(itemMark ',c |%x| |%y|)) (bind c "" `(itemStroke ',c |%x| |%y|)) (bind c "" `(itemsUnderArea ',c)) (bind c "<1>" `(itemStartDrag ',c |%x| |%y|)) (bind c "" `(itemDrag ',c |%x| |%y|)) (focus c) ;; Utility procedures for highlighting the item under the pointer: (defvar *restorecmd* nil) (defun itemEnter (c &aux type bg) ; (global :*restorecmd*) (let ((current (funcall c :find "withtag" "current" :return 'string))) (if (equal current "") (return-from itementer nil)) (itemleave nil) (setq type (funcall c :type current :return 'string)) (if (equal type "window") (progn (itemLeave nil) (return-from itemEnter nil))) (if (equal type "bitmap") (progn (setq bg (nth 4 (funcall c :itemconf current :background :return 'list-strings))) (push `(,c :itemconfig ',current :background ',bg) *restorecmd*) (funcall c :itemconfig current :background "SteelBlue2") (return-from itemEnter nil))) (setq fill (nth 4 (funcall c :itemconfig current :fill :return 'list-strings))) (if (or (member type '("rectangle" "oval" "arg") :test 'equal) (equal fill "")) (progn (setq outline (nth 4 (funcall c :itemconfig current :outline :return 'list-strings))) (push `(,c :itemconfig ',current :outline ',outline) *restorecmd*) (funcall c :itemconfig current :outline "SteelBlue2")) (progn (push `(,c :itemconfig ',current :fill ,fill) *restorecmd*) (funcall c :itemconfig current :fill "SteelBlue2"))) ) ) (defun itemLeave (c) ; (global :*restorecmd*) (let ((tem *restorecmd*)) (setq *restorecmd* nil) (dolist (v tem) (eval v)))) ;; Utility procedures for stroking out a rectangle and printing what's ;; underneath the rectangle's area. (defun itemMark (c x y) ; (global :areaX1 areaY1) (setq areaX1 (funcall c :canvasx x :return 'string)) (setq areaY1 (funcall c :canvasy y :return 'string)) (funcall c :delete "area") ) (defun itemStroke (c x y ) (declare (special areaX1 areaY1 areaX2 areaY2)) (or *recursive* (let ((*recursive* t)) (setq x (funcall c :canvasx x :return 'string)) (setq y (funcall c :canvasy y :return 'string)) (progn (setq areaX2 x) (setq areaY2 y) ;; this next return 'stringis simply for TIMING!!! ;; to make it wait for the result before going into subsequent!! (funcall c :delete "area" :return 'string) (funcall c :addtag "area" "withtag" (funcall c :create "rect" areaX1 areaY1 x y :outline "black" :return 'string)) )))) (defun itemsUnderArea (c) ; (global :areaX1 areaY1 areaX2 areaY2) (setq area (funcall c :find "withtag" "area" :return 'string)) (setq me c) (setq items "") (dolist (i (funcall c :find "enclosed" areaX1 areaY1 areaX2 areaY2 :return 'list-strings)) (if (search "item" (funcall c :gettags i :return 'string)) (setq items (tk-conc items " " i)))) (print (tk-conc "Items enclosed by area: " items)) (setq items "") (dolist (i (funcall c :find "overlapping" areaX1 areaY1 areaX2 areaY2 :return 'list-strings)) (if (search "item" (funcall c :gettags i :return 'string)) (setq items (tk-conc items " " i)))) (print (tk-conc "Items overlapping area: " items)) (terpri) (force-output) ) (setq areaX1 0) (setq areaY1 0) (setq areaX2 0) (setq areaY2 0) ;; Utility procedures to support dragging of items. (defun itemStartDrag (c x y) ; (global :lastX lastY) (setq lastX (funcall c :canvasx x :return 'number)) (setq lastY (funcall c :canvasy y :return 'number)) ) (defun itemDrag (c x y) ; (global :lastX lastY) (setq x (funcall c :canvasx x :return 'number)) (setq y (funcall c :canvasy y :return 'number)) (funcall c :move "current" (- x lastX) (- y lastY)) (setq lastX x) (setq lastY y) ) (defvar *recursive* nil) (defun itemDrag (c x y) ; (global :lastX lastY) (cond (*recursive* ) (t (let ((*recursive* t)) (setq x (funcall c :canvasx x :return 'number)) (setq y (funcall c :canvasy y :return 'number)) (funcall c :move "current" (- x lastX) (- y lastY)) (setq lastX x) (setq lastY y))))) ;; Procedure that's invoked when the button embedded in the canvas ;; is invoked. (defun butPress (w color) (setq i (funcall w :create "text" "25c" "18.1c" :text "Ouch!!" :fill color :anchor "n" :return 'string)) (after 500 (tk-conc w " delete " i)) ) gcl/gcl-tk/demos-4.2/000077500000000000000000000000001242227143400144155ustar00rootroot00000000000000gcl/gcl-tk/demos-4.2/widget000077500000000000000000000321031242227143400156250ustar00rootroot00000000000000#!/bin/sh # the next line restarts using wish \ exec wish4.2 "$0" "$@" # widget -- # This script demonstrates the various widgets provided by Tk, # along with many of the features of the Tk toolkit. This file # only contains code to generate the main window for the # application, which invokes individual demonstrations. The # code for the actual demonstrations is contained in separate # ".tcl" files is this directory, which are sourced by this script # as needed. # # SCCS: @(#) widget 1.21 96/10/04 17:09:34 eval destroy [winfo child .] wm title . "Widget Demonstration" #---------------------------------------------------------------- # The code below create the main window, consisting of a menu bar # and a text widget that explains how to use the program, plus lists # all of the demos as hypertext items. #---------------------------------------------------------------- set font -*-Helvetica-Medium-R-Normal--*-140-*-*-*-*-*-* frame .menuBar pack .menuBar -side top -fill x menubutton .menuBar.file -text File -menu .menuBar.file.m -underline 0 menu .menuBar.file.m .menuBar.file.m add command -label "About ... " -command "aboutBox" \ -underline 0 -accelerator "" .menuBar.file.m add sep .menuBar.file.m add command -label "Quit" -command "exit" -underline 0 pack .menuBar.file -side left bind . aboutBox frame .textFrame scrollbar .s -orient vertical -command {.t yview} -highlightthickness 0 \ -takefocus 1 pack .s -in .textFrame -side right -fill y -padx 1 text .t -yscrollcommand {.s set} -wrap word -width 60 -height 30 -font $font \ -setgrid 1 -highlightthickness 0 -padx 4 -pady 2 -takefocus 0 pack .t -in .textFrame -expand y -fill both -padx 1 pack .textFrame -expand yes -fill both -padx 1 -pady 2 frame .statusBar label .statusBar.lab -text " " -relief sunken -bd 1 \ -font -*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -anchor w label .statusBar.foo -width 8 -relief sunken -bd 1 \ -font -*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -anchor w pack .statusBar.lab -side left -padx 2 -expand yes -fill both pack .statusBar.foo -side left -padx 2 pack .statusBar -side top -fill x -pady 2 # Create a bunch of tags to use in the text widget, such as those for # section titles and demo descriptions. Also define the bindings for # tags. .t tag configure title -font -*-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-* # We put some "space" characters to the left and right of each demo description # so that the descriptions are highlighted only when the mouse cursor # is right over them (but not when the cursor is to their left or right) # .t tag configure demospace -lmargin1 1c -lmargin2 1c if {[winfo depth .] == 1} { .t tag configure demo -lmargin1 1c -lmargin2 1c \ -underline 1 .t tag configure visited -lmargin1 1c -lmargin2 1c \ -underline 1 .t tag configure hot -background black -foreground white } else { .t tag configure demo -lmargin1 1c -lmargin2 1c \ -foreground blue -underline 1 .t tag configure visited -lmargin1 1c -lmargin2 1c \ -foreground #303080 -underline 1 .t tag configure hot -foreground red -underline 1 } .t tag bind demo { invoke [.t index {@%x,%y}] } set lastLine "" .t tag bind demo { set lastLine [.t index {@%x,%y linestart}] .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" .t config -cursor hand2 showStatus [.t index {@%x,%y}] } .t tag bind demo { .t tag remove hot 1.0 end .t config -cursor xterm .statusBar.lab config -text "" } .t tag bind demo { set newLine [.t index {@%x,%y linestart}] if {[string compare $newLine $lastLine] != 0} { .t tag remove hot 1.0 end set lastLine $newLine set tags [.t tag names {@%x,%y}] set i [lsearch -glob $tags demo-*] if {$i >= 0} { .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" } } showStatus [.t index {@%x,%y}] } # Create the text for the text widget. .t insert end "Tk Widget Demonstrations\n" title .t insert end { This application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the "See Code" button to see the Tcl/Tk code that created the demonstration. If you wish, you can edit the code and click the "Rerun Demo" button in the code window to reinvoke the demonstration with the modified code. } .t insert end "Labels, buttons, checkbuttons, and radiobuttons" title .t insert end " \n " {demospace} .t insert end "1. Labels (text and bitmaps)." {demo demo-label} .t insert end " \n " {demospace} .t insert end "2. Buttons." {demo demo-button} .t insert end " \n " {demospace} .t insert end "3. Checkbuttons (select any of a group)." {demo demo-check} .t insert end " \n " {demospace} .t insert end "4. Radiobuttons (select one of a group)." {demo demo-radio} .t insert end " \n " {demospace} .t insert end "5. A 15-puzzle game made out of buttons." {demo demo-puzzle} .t insert end " \n " {demospace} .t insert end "6. Iconic buttons that use bitmaps." {demo demo-icon} .t insert end " \n " {demospace} .t insert end "7. Two labels displaying images." {demo demo-image1} .t insert end " \n " {demospace} .t insert end "8. A simple user interface for viewing images." \ {demo demo-image2} .t insert end " \n " {demospace} .t insert end \n {} "Listboxes" title .t insert end " \n " {demospace} .t insert end "1. 50 states." {demo demo-states} .t insert end " \n " {demospace} .t insert end "2. Colors: change the color scheme for the application." \ {demo demo-colors} .t insert end " \n " {demospace} .t insert end "3. A collection of famous sayings." {demo demo-sayings} .t insert end " \n " {demospace} .t insert end \n {} "Entries" title .t insert end " \n " {demospace} .t insert end "1. Without scrollbars." {demo demo-entry1} .t insert end " \n " {demospace} .t insert end "2. With scrollbars." {demo demo-entry2} .t insert end " \n " {demospace} .t insert end "3. Simple Rolodex-like form." {demo demo-form} .t insert end " \n " {demospace} .t insert end \n {} "Text" title .t insert end " \n " {demospace} .t insert end "1. Basic editable text." {demo demo-text} .t insert end " \n " {demospace} .t insert end "2. Text display styles." {demo demo-style} .t insert end " \n " {demospace} .t insert end "3. Hypertext (tag bindings)." {demo demo-bind} .t insert end " \n " {demospace} .t insert end "4. A text widget with embedded windows." {demo demo-twind} .t insert end " \n " {demospace} .t insert end "5. A search tool built with a text widget." {demo demo-search} .t insert end " \n " {demospace} .t insert end \n {} "Canvases" title .t insert end " \n " {demospace} .t insert end "1. The canvas item types." {demo demo-items} .t insert end " \n " {demospace} .t insert end "2. A simple 2-D plot." {demo demo-plot} .t insert end " \n " {demospace} .t insert end "3. Text items in canvases." {demo demo-ctext} .t insert end " \n " {demospace} .t insert end "4. An editor for arrowheads on canvas lines." {demo demo-arrow} .t insert end " \n " {demospace} .t insert end "5. A ruler with adjustable tab stops." {demo demo-ruler} .t insert end " \n " {demospace} .t insert end "6. A building floor plan." {demo demo-floor} .t insert end " \n " {demospace} .t insert end "7. A simple scrollable canvas." {demo demo-cscroll} .t insert end " \n " {demospace} .t insert end \n {} "Scales" title .t insert end " \n " {demospace} .t insert end "1. Vertical scale." {demo demo-vscale} .t insert end " \n " {demospace} .t insert end "2. Horizontal scale." {demo demo-hscale} .t insert end " \n " {demospace} .t insert end \n {} "Menus" title .t insert end " \n " {demospace} .t insert end "1. A window containing several menus and cascades." \ {demo demo-menu} .t insert end " \n " {demospace} .t insert end \n {} "Common Dialogs" title .t insert end " \n " {demospace} .t insert end "1. Message boxes." {demo demo-msgbox} .t insert end " \n " {demospace} .t insert end "2. File selection dialog." {demo demo-filebox} .t insert end " \n " {demospace} .t insert end "3. Color picker." {demo demo-clrpick} .t insert end " \n " {demospace} .t insert end \n {} "Miscellaneous" title .t insert end " \n " {demospace} .t insert end "1. The built-in bitmaps." {demo demo-bitmap} .t insert end " \n " {demospace} .t insert end "2. A dialog box with a local grab." {demo demo-dialog1} .t insert end " \n " {demospace} .t insert end "3. A dialog box with a global grab." {demo demo-dialog2} .t insert end " \n " {demospace} .t configure -state disabled focus .s # positionWindow -- # This procedure is invoked by most of the demos to position a # new demo window. # # Arguments: # w - The name of the window to position. proc positionWindow w { wm geometry $w +300+300 } # showVars -- # Displays the values of one or more variables in a window, and # updates the display whenever any of the variables changes. # # Arguments: # w - Name of new window to create for display. # args - Any number of names of variables. proc showVars {w args} { catch {destroy $w} toplevel $w wm title $w "Variable values" label $w.title -text "Variable values:" -width 20 -anchor center \ -font -Adobe-helvetica-medium-r-normal--*-180-*-*-*-*-*-* pack $w.title -side top -fill x set len 1 foreach i $args { if {[string length $i] > $len} { set len [string length $i] } } foreach i $args { frame $w.$i label $w.$i.name -text "$i: " -width [expr $len + 2] -anchor w label $w.$i.value -textvar $i -anchor w pack $w.$i.name -side left pack $w.$i.value -side left -expand 1 -fill x pack $w.$i -side top -anchor w -fill x } button $w.ok -text OK -command "destroy $w" pack $w.ok -side bottom -pady 2 } # invoke -- # This procedure is called when the user clicks on a demo description. # It is responsible for invoking the demonstration. # # Arguments: # index - The index of the character that the user clicked on. proc invoke index { global tk_library set tags [.t tag names $index] set i [lsearch -glob $tags demo-*] if {$i < 0} { return } set cursor [.t cget -cursor] .t configure -cursor watch update set demo [string range [lindex $tags $i] 5 end] uplevel [list source [file join $tk_library demos $demo.tcl]] update .t configure -cursor $cursor .t tag add visited "$index linestart +1 chars" "$index lineend -1 chars" } # showStatus -- # # Show the name of the demo program in the status bar. This procedure # is called when the user moves the cursor over a demo description. # proc showStatus index { global tk_library set tags [.t tag names $index] set i [lsearch -glob $tags demo-*] set cursor [.t cget -cursor] if {$i < 0} { .statusBar.lab config -text " " set newcursor xterm } else { set demo [string range [lindex $tags $i] 5 end] .statusBar.lab config -text "Run the \"$demo\" sample program" set newcursor hand2 } if [string compare $cursor $newcursor] { .t config -cursor $newcursor } } # showCode -- # This procedure creates a toplevel window that displays the code for # a demonstration and allows it to be edited and reinvoked. # # Arguments: # w - The name of the demonstration's window, which can be # used to derive the name of the file containing its code. proc showCode w { global tk_library set file [string range $w 1 end].tcl if ![winfo exists .code] { toplevel .code frame .code.buttons pack .code.buttons -side bottom -fill x button .code.buttons.dismiss -text Dismiss -command "destroy .code" button .code.buttons.rerun -text "Rerun Demo" -command { eval [.code.text get 1.0 end] } pack .code.buttons.dismiss .code.buttons.rerun -side left \ -expand 1 -pady 2 frame .code.frame pack .code.frame -expand yes -fill both -padx 1 -pady 1 text .code.text -height 40 -wrap word\ -xscrollcommand ".code.xscroll set" \ -yscrollcommand ".code.yscroll set" \ -setgrid 1 -highlightthickness 0 -pady 2 -padx 3 scrollbar .code.xscroll -command ".code.text xview" \ -highlightthickness 0 -orient horizontal scrollbar .code.yscroll -command ".code.text yview" \ -highlightthickness 0 -orient vertical grid .code.text -in .code.frame -padx 1 -pady 1 \ -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news grid .code.yscroll -in .code.frame -padx 1 -pady 1 \ -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news # grid .code.xscroll -in .code.frame -padx 1 -pady 1 \ # -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news grid rowconfig .code.frame 0 -weight 1 -minsize 0 grid columnconfig .code.frame 0 -weight 1 -minsize 0 } else { wm deiconify .code raise .code } wm title .code "Demo code: [file join $tk_library demos $file]" wm iconname .code $file set id [open [file join $tk_library demos $file]] .code.text delete 1.0 end .code.text insert 1.0 [read $id] .code.text mark set insert 1.0 close $id } # aboutBox -- # # Pops up a message box with an "about" message # proc aboutBox {} { tk_messageBox -icon info -type ok -title "About Widget Demo" -message \ "Tk widget demonstration\n\n\ Copyright (c) 1996 Sun Microsystems, Inc." } gcl/gcl-tk/demos-4.2/widget.lisp000077500000000000000000000355761242227143400166140ustar00rootroot00000000000000;;#!/bin/sh ;; the next line restarts using wish ;(exec :wish4.2 (tk-conc 0) "$@") (in-package "TK") ;; widget -- ;; This script demonstrates the various widgets provided by Tk, ;; along with many of the features of the Tk toolkit. This file ;; only contains code to generate the main window for the ;; application, which invokes individual demonstrations. The ;; code for the actual demonstrations is contained in separate ;; ".tcl" files is this directory, which are sourced by this script ;; as needed. ;; ;; SCCS: @(#) :widget 1.21 96/10/04 17:09:34 (apply 'destroy (winfo :child '|.| :return 'list)) (wm :title '|.| "Widget Demonstration") ;;---------------------------------------------------------------- ;; The code below create the main window, consisting of a menu bar ;; and a text widget that explains how to use the program, plus lists ;; all of the demos as hypertext items. ;;---------------------------------------------------------------- (setq font '-*-Helvetica-Medium-R-Normal--*-140-*-*-*-*-*-*) (frame '.menuBar) (pack '.menuBar :side "top" :fill "x") (menubutton '.menuBar.file :text "File" :menu '.menuBar.file.m :underline 0) (menu '.menuBar.file.m) (.menuBar.file.m :add :command :label "About '... " :command "aboutBox" :underline 0 :accelerator "") (.menuBar.file.m :add :sep) (.menuBar.file.m :add :command :label "Quit" :command "exit" :underline 0) (pack '.menuBar.file :side "left") (bind '|.| "" 'aboutBox) (frame '.textFrame) (scrollbar '.s :orient "vertical" :command '(.t :yview) :highlightthickness 0 :takefocus 1) (pack '.s :in '.textFrame :side "right" :fill "y" :padx 1) (text '.t :yscrollcommand '(.s :set) :wrap "word" :width 60 :height 30 :font font :setgrid 1 :highlightthickness 0 :padx 4 :pady 2 :takefocus 0) (pack '.t :in '.textFrame :expand "y" :fill "both" :padx 1) (pack '.textFrame :expand "yes" :fill "both" :padx 1 :pady 2) (frame '.statusBar) (label '.statusBar.lab :text " " :relief "sunken" :bd 1 :font :*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* :anchor "w") (label '.statusBar.foo :width 8 :relief "sunken" :bd 1 :font :*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* :anchor "w") (pack '.statusBar.lab :side "left" :padx 2 :expand "yes" :fill "both") (pack '.statusBar.foo :side "left" :padx 2) (pack '.statusBar :side "top" :fill "x" :pady 2) ;; Create a bunch of tags to use in the text widget, such as those for ;; section titles and demo descriptions. Also define the bindings for ;; tags. (.t :tag :configure "title" :font :*-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*) ;; We put some "space" characters to the left and right of each demo description ;; so that the descriptions are highlighted only when the mouse cursor ;; is right over them (but :not when the cursor is to their left or right) ;; (.t :tag :configure "demospace" :lmargin1 "1c" :lmargin2 "1c") (if (equal (winfo :depth '|.| :return 'number) 1) (progn (.t :tag :configure "demo" :lmargin1 "1c" :lmargin2 "1c" :underline 1) (.t :tag :configure "visited" :lmargin1 "1c" :lmargin2 "1c" :underline 1) (.t :tag :configure "hot" :background "black" :foreground "white") ) ;;else (progn (.t :tag :configure "demo" :lmargin1 "1c" :lmargin2 "1c" :foreground "blue" :underline 1) (.t :tag :configure "visited" :lmargin1 "1c" :lmargin2 "1c" :foreground "#303080" :underline 1) (.t :tag :configure "hot" :foreground "red" :underline 1) )) (.t :tag :bind "demo" "" '(invoke (.t index "@%x,%y")) ) (setq lastLine "") (.t :tag :bind "demo" "" '(progn (setq lastLine (.t :index "@" : |%x| :"," : |%y| "linestart" :return 'number)) (.t :tag :add "hot" (tk-conc lastLine " +1 chars") (tk-conc lastLine " lineend -1 chars")) (.t :config :cursor "hand2") (showStatus (.t :index "@" : |%x| :"," : |%y| :return 'number)) )) (.t :tag :bind "demo" "" '(progn (.t :tag :remove "hot" 1.0 end) (.t :config :cursor "xterm") (.statusBar.lab :config :text "") ) (.t :tag :bind "demo" "" '(progn (setq newLine [.t index {@%x,%y linestart}]) (if ([string :compare newLine $lastLine] != 0) (progn (.t :tag :remove "hot" 1.0 end) (setq lastLine newLine) (setq tags [.t tag names {@%x,%y}]) (setq i [lsearch :glob tags "demo-*"]) (if (funcall i >= 0) {) (.t :tag :add "hot" (tk-conc lastLine " +1 chars") (tk-conc lastLine " lineend -1 chars")) ) ) (showStatus (.t :index "@%x,%y" :return 'number)) )) ;; Create the text for the text widget. (.t :insert end "Tk Widget Demonstrations\n" title) (.t :insert end {) (This :application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the "See Code" button to see the Tcl/Tk code that created the demonstration. (if :you wish, you can edit the code and click the "Rerun Demo" button in the code window to reinvoke the demonstration with the modified code.) } (setq *newline* " ") (.t :insert :end "Labels, buttons, checkbuttons, and radiobuttons" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. Labels (text :and bitmaps)." "demo demo-label") (.t :insert :end " \n " "demospace") (.t :insert :end "2. Buttons." "demo demo-label") (.t :insert :end *newline* "demospace") (.t :insert :end "3. Checkbuttons (select :any of a group)." "demo demo-check") (.t :insert :end *newline* "demospace") (.t :insert :end "4. Radiobuttons (select :one of a group).""demo demo-radio") (.t :insert :end *newline* "demospace") (.t :insert :end "5. A 15-puzzle game made out of buttons.""demo demo-puzzle") (.t :insert :end *newline* "demospace") (.t :insert :end "6. Iconic buttons that use bitmaps." "demo demo-icon") (.t :insert :end *newline* "demospace") (.t :insert :end "7. Two labels displaying images." "demo demo-image1") (.t :insert :end *newline* "demospace") (.t :insert :end "8. A simple user interface for viewing images." "demo demo-image2") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Listboxes" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. 50 states." "demo demo-states") (.t :insert :end *newline* "demospace") (.t :insert :end "2. Colors: change the color scheme for the application." "demo demo-colors") (.t :insert :end *newline* "demospace") (.t :insert :end "3. A collection of famous sayings." "demo demo-sayings") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Entries" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. Without scrollbars." "demo demo-entry1") (.t :insert :end *newline* "demospace") (.t :insert :end "2. With scrollbars." "demo demo-entry2") (.t :insert :end *newline* "demospace") (.t :insert :end "3. Simple Rolodex-like form." "demo demo-form") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Text" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. Basic editable text." "demo demo-text") (.t :insert :end *newline* "demospace") (.t :insert :end "2. Text display styles." "demo demo-style") (.t :insert :end *newline* "demospace") (.t :insert :end "3. Hypertext (tag :bindings)." "demo demo-bind") (.t :insert :end *newline* "demospace") (.t :insert :end "4. A text widget with embedded windows." "demo demo-twind") (.t :insert :end *newline* "demospace") (.t :insert :end "5. A search tool built with a text widget." "demo demo-search") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Canvases" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. The canvas item types." "demo demo-items") (.t :insert :end *newline* "demospace") (.t :insert :end "2. A simple 2-D plot." "demo demo-plot") (.t :insert :end *newline* "demospace") (.t :insert :end "3. Text items in canvases." "demo demo-ctext") (.t :insert :end *newline* "demospace") (.t :insert :end "4. An editor for arrowheads on canvas lines." "demo demo-arrow") (.t :insert :end *newline* "demospace") (.t :insert :end "5. A ruler with adjustable tab stops." "demo demo-ruler") (.t :insert :end *newline* "demospace") (.t :insert :end "6. A building floor plan." "demo demo-floor") (.t :insert :end *newline* "demospace") (.t :insert :end "7. A simple scrollable canvas." "demo demo-cscroll") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Scales" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. Vertical scale." "demo demo-vscale") (.t :insert :end *newline* "demospace") (.t :insert :end "2. Horizontal scale." "demo demo-hscale") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Menus" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. A window containing several menus and cascades." (demo demo-menu)) (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Common Dialogs" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. Message boxes." "demo demo-msgbox") (.t :insert :end *newline* "demospace") (.t :insert :end "2. File selection dialog." "demo demo-filebox") (.t :insert :end *newline* "demospace") (.t :insert :end "3. Color picker." "demo demo-clrpick") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Miscellaneous" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. The built-in bitmaps." "demo demo-bitmap") (.t :insert :end *newline* "demospace") (.t :insert :end "2. A dialog box with a local grab." "demo demo-dialog1") (.t :insert :end *newline* "demospace") (.t :insert :end "3. A dialog box with a global grab." "demo demo-dialog2") (.t :insert :end *newline* "demospace") (.t :configure :state "disabled") (focus '.s) ;; positionWindow -- ;; This procedure is invoked by most of the demos to position a ;; new demo window. ;; ;; Arguments: ;; w - The name of the window to position. (defun positionWindow w (wm :geometry w +300+300) ) ;; showVars -- ;; Displays the values of one or more variables in a window, and ;; updates the display whenever any of the variables changes. ;; ;; Arguments: ;; w - Name of new window to create for display. ;; args - Any number of names of variables. (defun showVars (w args) (if (winfo :exists w) (destroy :w)) (toplevel w) (wm :title w "Variable values") (label (conc w '."title") :text "Variable values:" :width 20 :anchor "center" :font :Adobe-helvetica-medium-r-normal--*-180-*-*-*-*-*-*) (pack (conc w '."title") :side "top" :fill "x") (setq len 1) foreach i args { ( (if ([string :length $i] > len) (progn ) (setq len [string length $i]) ( )) } foreach i args { (frame (conc w '|.| i)) (label (conc w '|.| i '.name) :text (tk-conc i ": ") :width ( + len 2) :anchor "w") (label (conc w '|.| i '.value) :textvar i :anchor "w") (pack (conc w '|.| i '.name) :side "left") (pack (conc w '|.| i '.value) :side "left" :expand 1 :fill "x") (pack (conc w '|.| i) :side "top" :anchor "w" :fill "x") } (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.ok) :side "bottom" :pady 2) ) ;; invoke -- ;; This procedure is called when the user clicks on a demo description. ;; It is responsible for invoking the demonstration. ;; ;; Arguments: ;; index - The index of the character that the user clicked on. (defun invoke index (global :tk_library) (setq tags [.t tag names $index]) (setq i [lsearch :glob tags demo-*]) (if (funcall i < 0) (progn (return) ) (setq cursor [.t cget :cursor]) (.t :configure :cursor "watch") (update) (setq demo [string range [lindex tags $i] 5 end]) (uplevel [list source [file join $tk_library demos (conc demo '.tcl)]]) (update) (.t :configure :cursor cursor) (.t :tag :add visited (tk-conc index " linestart +1 chars") (tk-conc index " lineend -1 chars")) ) ;; showStatus -- ;; ;; Show the name of the demo program in the status bar. This procedure ;; is called when the user moves the cursor over a demo description. ;; (defun showStatus (index ) ;(global :tk_library) ; (setq index (round index)) (setq tags (.t :tag "names" index :return 'string)) (setq i (lsearch "-glob" tags "demo-*" :return 'number)) (setq cursor (.t :cget :cursor :return 'string)) (if (< i 0) (progn (.statusBar.lab :config :text " ") (setq newcursor "xterm") ) ;;else (progn (setq demo (string :range (lindex tags i :return 'string) 5 "end" :return 'string)) (.statusBar.lab :config :text (tk-conc "Run the \"" demo "\" sample program")) (setq newcursor "hand2") )) (if (string :compare cursor newcursor :return 'boolean) (.t :config :cursor newcursor) ) ) ;; showCode -- ;; This procedure creates a toplevel window that displays the code for ;; a demonstration and allows it to be edited and reinvoked. ;; ;; Arguments: ;; w - The name of the demonstration's window, which can be ;; used to derive the name of the file containing its code. (defun showCode w (global :tk_library) (setq file [string range w 1 end].tcl) (if ![winfo exists '.code] { (toplevel '.code) (frame '.code.buttons) (pack '.code.buttons :side "bottom" :fill "x") (button '.code.buttons.dismiss :text "Dismiss" :command "destroy '.code") (button '.code.buttons.rerun :text "Rerun Demo" :command {) (eval [.code.text get 1.0 end]) } (pack '.code.buttons.dismiss '.code.buttons.rerun :side "left" :expand 1 :pady 2) (frame '.code.frame) (pack '.code.frame :expand "yes" :fill "both" :padx 1 :pady 1) (text '.code.text :height 40 :wrap "word " :xscrollcommand ".code.xscroll set" :yscrollcommand ".code.yscroll set" :setgrid 1 :highlightthickness 0 :pady 2 :padx 3) (scrollbar '.code.xscroll :command ".code.text xview" :highlightthickness 0 :orient "horizontal") (scrollbar '.code.yscroll :command ".code.text yview" :highlightthickness 0 :orient "vertical") (grid '.code.text :in '.code.frame :padx 1 :pady 1 :row 0 :column 0 :rowspan 1 :columnspan 1 :sticky "news") (grid '.code.yscroll :in '.code.frame :padx 1 :pady 1 :row 0 :column 1 :rowspan 1 :columnspan 1 :sticky "news") ;; grid '.code.xscroll :in '.code.frame :padx 1 :pady 1 ;; :row 1 :column 0 :rowspan 1 :columnspan 1 :sticky "news" (grid :rowconfig '.code.frame 0 :weight 1 :minsize 0) (grid :columnconfig '.code.frame 0 :weight 1 :minsize 0) } else { (wm :deiconify '.code) (raise '.code) } (wm :title '.code (tk-conc "Demo code: [file join " tk "_library demos " file "]")) (wm :iconname '.code file) (setq id [open [file join $tk_library demos $file]]) (.code.text :delete 1.0 end) (.code.text :insert 1.0 [read $id]) (.code.text :mark set insert 1.0) (close id) ) ;; aboutBox -- ;; ;; Pops up a message box with an "about" message ;; (defun aboutBox () (tk_messageBox :icon "info" :type "ok" :title "About Widget Demo" :message "Tk widget demonstration\\n\\n Copyright (c) 1996 Sun Microsystems, Inc.") ) gcl/gcl-tk/demos/000077500000000000000000000000001242227143400141145ustar00rootroot00000000000000gcl/gcl-tk/demos/gc-monitor.lisp000077500000000000000000000120411242227143400170640ustar00rootroot00000000000000 ;; bug in aix c compiler on optimize?? #+aix3 (eval-when (compile) (proclaim '(optimize (speed 0)))) (in-package "TK") (defvar *gc-monitor-types* '(cons fixnum string si::relocatable-blocks stream)) (defvar *special-type-background* "red") (defun make-one-graph (top type) (let* ((f (conc top '.type type))) (setf (get type 'frame) f) (setf (get type 'canvas) (conc top '.canvas type)) (frame f ) (canvas (get type 'canvas) :relief "sunken" :width "8c" :height ".4c") (label (conc f '.data)) (button (conc f '.label) :text (string-capitalize (symbol-name type)) :background "gray90" :command `(draw-status ',type t)) (pack (conc f '.label) (conc f '.data) :side "left" :anchor "w" :padx "4m") (pack f :side "top" :anchor "w" :padx "1c") (pack (get type 'canvas) :side "top" :expand 1 :pady "2m") )) (defvar *prev-special-type* nil) (defvar *time-to-stay-on-type* 0) (defvar *values-array* (make-array 20 :fill-pointer 0)) (defun push-multiple-values (&rest l) (declare (:dynamic-extent l)) (dolist (v l) (vector-push-extend v *values-array*))) (defun draw-status (special-type &optional clicked) (setf (fill-pointer *values-array*) 0) (let ((max-size 0) (ar *values-array*) (i 0) (width 7.0s0) (ht ".15c")) (declare (fixnum max-size) (short-float width)(type (array (t)) ar)) (dolist (v *gc-monitor-types*) (let ((fp (fill-pointer *values-array*)) ) (multiple-value-call 'push-multiple-values (si::allocated v)) (setq max-size (max max-size (aref ar (the fixnum (+ fp 1))))))) ; (nfree npages maxpage nppage gccount nused) (dolist (v *gc-monitor-types*) (let* ((nfree (aref ar i)) (npages (aref ar (setq i(+ i 1)))) (nppage (aref ar (setq i(+ i 2)))) (gccount (aref ar (setq i (+ i 1)))) (nused (aref ar (setq i (+ i 1)))) (wid (/ (the short-float(* npages width)) max-size)) (f (get v 'frame)) (tot (* npages nppage)) (width-used (the short-float (/ (the short-float (* wid (the fixnum (- tot (the fixnum nfree))))) tot)))) (declare (fixnum nppage npages tot) (short-float wid)) (setq i (+ i 1)) (funcall (get v 'canvas) :delete "graph") (funcall (get v 'canvas) :create "line" 0 ht width-used : "c" ht :width "3m" :tag "graph" :fill "red") (funcall (get v 'canvas) :create "line" width-used : "c" ht wid : "c" ht :width "3m" :tag "graph" :fill "aquamarine4" ) (funcall (conc f '.data) :configure :text gccount : " gc's for ": npages : " pages (used=" : nused : ")") (cond ((eql special-type v) (cond (clicked (let ((n (* max-size 2))) (.gc.amount :configure :length "8c" :label "Allocate: " : (or special-type "") :tickinterval (truncate n 4) :to n) (.gc.amount :set npages) ))))))) (set-label-background *prev-special-type* "pink") (setq *prev-special-type* special-type) (set-label-background special-type *special-type-background*) ) ) (defun do-allocation () (when *prev-special-type* (allocate *prev-special-type* (.gc.amount :get :return 'number) t) (draw-status *prev-special-type*))) (defun set-label-background (type colour) (and (get type 'frame) (let ((label (conc (get type 'frame) '.label))) (funcall label :configure :background colour)))) (defun mkgcmonitor() (let (si::*after-gbc-hook*) (toplevel '.gc) (wm :title '.gc "GC Monitor") (wm :title '.gc "GC") (or (> (read-from-string (winfo :depth '.gc)) 1) (setq *special-type-background* "white")) (message '.gc.msg :font :Adobe-times-medium-r-normal--*-180* :aspect 400 :text "GC monitor displays after each garbage collection the amount of space used (red) and free (green) of the types in the list *gc-monitor-types*. Clicking on a type makes its size appear on the scale at the bottom, and double clicking on the scale causes actual allocation!") (pack '.gc.msg :side "top") (dolist (v *gc-monitor-types*) (make-one-graph '.gc v) ) (.gc :configure :borderwidth 4 :relief "ridge") ;; it is important to create the frame first, so that ;; it is earlier... and the others will show. (frame '.gc.ff) (button '.gc.ok :text "QUIT" :command `(progn (setq si::*after-gbc-hook* nil) (destroy '.gc))) (scale '.gc.amount :label "Amount :" :width ".3c" :orient "horizontal" :to 100) (pack '.gc.amount) (button '.gc.reset :text "RESET Number Used" :command '(progn (dolist (v *gc-monitor-types*) (set-label-background v "gray90")) (si::reset-number-used) (draw-status *prev-special-type*))) (button '.gc.update :text "Update" :command '(draw-status *prev-special-type*)) (pack '.gc.ok '.gc.reset '.gc.update :expand 1 :fill "x" :in '.gc.ff :padx 3 :pady 2 :side 'left) (pack '.gc.ff :expand 1 :fill "x") (bind '.gc.amount "" 'do-allocation) (draw-status nil)) (setq si::*after-gbc-hook* 'draw-status) ) gcl/gcl-tk/demos/mkArrow.tcl000077500000000000000000000162061242227143400162520ustar00rootroot00000000000000# mkArrow w # # Create a top-level window containing a canvas demonstration that # allows the user to experiment with arrow shapes. # # Arguments: # w - Name to use for new top-level window. # This file implements a canvas widget that displays a large line with # an arrowhead and allows the shape of the arrowhead to be edited # interactively. The only procedure that should be invoked from outside # the file is the first one, which creates the canvas. proc mkArrow {{w .arrow}} { global tk_library upvar #0 demo_arrowInfo v catch {destroy $w} toplevel $w dpos $w wm title $w "Arrowhead Editor Demonstration" wm iconname $w "Arrow" set c $w.c frame $w.frame1 -relief raised -bd 2 canvas $c -width 500 -height 350 -relief raised button $w.ok -text "OK" -command "destroy $w" pack $w.frame1 -side top -fill both pack $w.ok -side bottom -pady 5 pack $c -expand yes -fill both message $w.frame1.m -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \ -text "This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases. To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on the right give examples at normal scale. The text at the bottom shows the configuration options as you'd enter them for a line." pack $w.frame1.m set v(a) 8 set v(b) 10 set v(c) 3 set v(width) 2 set v(motionProc) arrowMoveNull set v(x1) 40 set v(x2) 350 set v(y) 150 set v(smallTips) {5 5 2} set v(count) 0 if {[winfo depth $c] > 1} { set v(bigLineStyle) "-fill SkyBlue1" set v(boxStyle) "-fill {} -outline black -width 1" set v(activeStyle) "-fill red -outline black -width 1" } else { set v(bigLineStyle) "-fill black -stipple @$tk_library/demos/bitmaps/grey.25" set v(boxStyle) "-fill {} -outline black -width 1" set v(activeStyle) "-fill black -outline black -width 1" } arrowSetup $c $c bind box "$c itemconfigure current $v(activeStyle)" $c bind box "$c itemconfigure current $v(boxStyle)" $c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1} $c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2} $c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3} $c bind box "\$demo_arrowInfo(motionProc) $c %x %y" bind $c "arrowSetup $c" } # The procedure below completely regenerates all the text and graphics # in the canvas window. It's called when the canvas is initially created, # and also whenever any of the parameters of the arrow head are changed # interactively. The argument is the name of the canvas widget to be # regenerated, and also the name of a global variable containing the # parameters for the display. proc arrowSetup c { upvar #0 demo_arrowInfo v $c delete all # Create the arrow and outline. eval "$c create line $v(x1) $v(y) $v(x2) $v(y) -width [expr 10*$v(width)] \ -arrowshape {[expr 10*$v(a)] [expr 10*$v(b)] [expr 10*$v(c)]} \ -arrow last $v(bigLineStyle)" set xtip [expr $v(x2)-10*$v(b)] set deltaY [expr 10*$v(c)+5*$v(width)] $c create line $v(x2) $v(y) $xtip [expr $v(y)+$deltaY] \ [expr $v(x2)-10*$v(a)] $v(y) $xtip [expr $v(y)-$deltaY] \ $v(x2) $v(y) -width 2 -capstyle round -joinstyle round # Create the boxes for reshaping the line and arrowhead. eval "$c create rect [expr $v(x2)-10*$v(a)-5] [expr $v(y)-5] \ [expr $v(x2)-10*$v(a)+5] [expr $v(y)+5] $v(boxStyle) \ -tags {box1 box}" eval "$c create rect [expr $xtip-5] [expr $v(y)-$deltaY-5] \ [expr $xtip+5] [expr $v(y)-$deltaY+5] $v(boxStyle) \ -tags {box2 box}" eval "$c create rect [expr $v(x1)-5] [expr $v(y)-5*$v(width)-5] \ [expr $v(x1)+5] [expr $v(y)-5*$v(width)+5] $v(boxStyle) \ -tags {box3 box}" # Create three arrows in actual size with the same parameters $c create line [expr $v(x2)+50] 0 [expr $v(x2)+50] 1000 \ -width 2 set tmp [expr $v(x2)+100] $c create line $tmp [expr $v(y)-125] $tmp [expr $v(y)-75] \ -width $v(width) \ -arrow both -arrowshape "$v(a) $v(b) $v(c)" $c create line [expr $tmp-25] $v(y) [expr $tmp+25] $v(y) \ -width $v(width) \ -arrow both -arrowshape "$v(a) $v(b) $v(c)" $c create line [expr $tmp-25] [expr $v(y)+75] [expr $tmp+25] \ [expr $v(y)+125] -width $v(width) \ -arrow both -arrowshape "$v(a) $v(b) $v(c)" # Create a bunch of other arrows and text items showing the # current dimensions. set tmp [expr $v(x2)+10] $c create line $tmp [expr $v(y)-5*$v(width)] \ $tmp [expr $v(y)-$deltaY] \ -arrow both -arrowshape $v(smallTips) $c create text [expr $v(x2)+15] [expr $v(y)-$deltaY+5*$v(c)] \ -text $v(c) -anchor w set tmp [expr $v(x1)-10] $c create line $tmp [expr $v(y)-5*$v(width)] \ $tmp [expr $v(y)+5*$v(width)] \ -arrow both -arrowshape $v(smallTips) $c create text [expr $v(x1)-15] $v(y) -text $v(width) -anchor e set tmp [expr $v(y)+5*$v(width)+10*$v(c)+10] $c create line [expr $v(x2)-10*$v(a)] $tmp $v(x2) $tmp \ -arrow both -arrowshape $v(smallTips) $c create text [expr $v(x2)-5*$v(a)] [expr $tmp+5] \ -text $v(a) -anchor n set tmp [expr $tmp+25] $c create line [expr $v(x2)-10*$v(b)] $tmp $v(x2) $tmp \ -arrow both -arrowshape $v(smallTips) $c create text [expr $v(x2)-5*$v(b)] [expr $tmp+5] \ -text $v(b) -anchor n $c create text $v(x1) 310 -text "-width $v(width)" \ -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-180-* $c create text $v(x1) 330 -text "-arrowshape {$v(a) $v(b) $v(c)}" \ -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-180-* incr v(count) } # The procedures below are called in response to mouse motion for one # of the three items used to change the line width and arrowhead shape. # Each procedure updates one or more of the controlling parameters # for the line and arrowhead, and recreates the display if that is # needed. The arguments are the name of the canvas widget, and the # x and y positions of the mouse within the widget. proc arrowMove1 {c x y} { upvar #0 demo_arrowInfo v set newA [expr ($v(x2)+5-[$c canvasx $x])/10] if {$newA < 1} { set newA 1 } if {$newA > 25} { set newA 25 } if {$newA != $v(a)} { $c move box1 [expr 10*($v(a)-$newA)] 0 set v(a) $newA } } proc arrowMove2 {c x y} { upvar #0 demo_arrowInfo v set newB [expr ($v(x2)+5-[$c canvasx $x])/10] if {$newB < 1} { set newB 1 } if {$newB > 25} { set newB 25 } set newC [expr ($v(y)+5-[$c canvasy $y]-5*$v(width))/10] if {$newC < 1} { set newC 1 } if {$newC > 20} { set newC 20 } if {($newB != $v(b)) || ($newC != $v(c))} { $c move box2 [expr 10*($v(b)-$newB)] [expr 10*($v(c)-$newC)] set v(b) $newB set v(c) $newC } } proc arrowMove3 {c x y} { upvar #0 demo_arrowInfo v set newWidth [expr ($v(y)+5-[$c canvasy $y])/5] if {$newWidth < 1} { set newWidth 1 } if {$newWidth > 20} { set newWidth 20 } if {$newWidth != $v(width)} { $c move box3 0 [expr 5*($v(width)-$newWidth)] set v(width) $newWidth } } gcl/gcl-tk/demos/mkBasic.lisp000077500000000000000000000053531242227143400163670ustar00rootroot00000000000000;;# mkBasic w ;; ;; Create a top-level window that displays a basic text widget. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defvar *basic-message* " This window is a text widget. It displays one or more lines of text and allows you to edit the text. Here is a summary of the things you can do to a text widget: 1. Scrolling. Use the scrollbar to adjust the view in the text window. 2. Scanning. Press mouse button 2 in the text window and drag up or down. This will drag the text at high speed to allow you to scan its contents. 3. Insert text. Press mouse button 1 to set the insertion cursor, then type text. What you type will be added to the widget. You can backspace over what you've typed using either the backspace key, the delete key, or Control+h. 4. Select. Press mouse button 1 and drag to select a range of characters. Once you've released the button, you can adjust the selection by pressing button 1 with the shift key down. This will reset the end of the selection nearest the mouse cursor and you can drag that end of the selection by dragging the mouse before releasing the mouse button. You can double-click to select whole words, or triple-click to select whole lines. 5. Delete. To delete text, select the characters you'd like to delete and type Control+d. 6. Copy the selection. To copy the selection either from this window or from any other window or application, select what you want, click button 1 to set the insertion cursor, then type Control+v to copy the selection to the point of the insertion cursor. 7. Resize the window. This widget has been configured with the \"setGrid\" option on, so that if you resize the window it will always resize to an even number of characters high and wide. Also, if you make the window narrow you can see that long lines automatically wrap around onto additional lines so that all the information is always visible. When you're finished with this demonstration, press the \"OK\" button below.") (defun mkBasic (&optional (w '.basic)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Text Demonstration - Basic Facilities") (wm :iconname w "Text Basics") (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) (text (conc w '.t) :relief "raised" :bd 2 :yscrollcommand (tk-conc w ".s set") :setgrid "true") (pack (conc w '.ok) :side 'bottom :fill "x") (pack (conc w '.s) :side 'right :fill "y") (pack (conc w '.t) :expand 'yes :fill 'both) (funcall (conc w '.t) :insert 0.0 *basic-message*) (funcall (conc w '.t) :mark 'set 'insert 0.0) (bind w "" (tk-conc "focus " w ".t")) ) gcl/gcl-tk/demos/mkBasic.tcl000077500000000000000000000047111242227143400161770ustar00rootroot00000000000000# mkBasic w # # Create a top-level window that displays a basic text widget. # # Arguments: # w - Name to use for new top-level window. proc mkBasic {{w .basic}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Text Demonstration - Basic Facilities" wm iconname $w "Text Basics" button $w.ok -text OK -command "destroy $w" text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true scrollbar $w.s -relief flat -command "$w.t yview" pack $w.ok -side bottom -fill x pack $w.s -side right -fill y pack $w.t -expand yes -fill both $w.t insert 0.0 {\ This window is a text widget. It displays one or more lines of text and allows you to edit the text. Here is a summary of the things you can do to a text widget: 1. Scrolling. Use the scrollbar to adjust the view in the text window. 2. Scanning. Press mouse button 2 in the text window and drag up or down. This will drag the text at high speed to allow you to scan its contents. 3. Insert text. Press mouse button 1 to set the insertion cursor, then type text. What you type will be added to the widget. You can backspace over what you've typed using either the backspace key, the delete key, or Control+h. 4. Select. Press mouse button 1 and drag to select a range of characters. Once you've released the button, you can adjust the selection by pressing button 1 with the shift key down. This will reset the end of the selection nearest the mouse cursor and you can drag that end of the selection by dragging the mouse before releasing the mouse button. You can double-click to select whole words, or triple-click to select whole lines. 5. Delete. To delete text, select the characters you'd like to delete and type Control+d. 6. Copy the selection. To copy the selection either from this window or from any other window or application, select what you want, click button 1 to set the insertion cursor, then type Control+v to copy the selection to the point of the insertion cursor. 7. Resize the window. This widget has been configured with the "setGrid" option on, so that if you resize the window it will always resize to an even number of characters high and wide. Also, if you make the window narrow you can see that long lines automatically wrap around onto additional lines so that all the information is always visible. When you're finished with this demonstration, press the "OK" button below.} $w.t mark set insert 0.0 bind $w "focus $w.t" } gcl/gcl-tk/demos/mkBitmaps.tcl000077500000000000000000000026751242227143400165640ustar00rootroot00000000000000# mkBitmaps w # # Create a top-level window that displays all of Tk's built-in bitmaps. # # Arguments: # w - Name to use for new top-level window. proc mkBitmaps {{w .bitmaps}} { global tk_library catch {destroy $w} toplevel $w dpos $w wm title $w "Bitmap Demonstration" wm iconname $w "Bitmaps" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -width 4i \ -text "This window displays all of Tk's built-in bitmaps, along with the names you can use for them in Tcl scripts. Click the \"OK\" button when you've seen enough." frame $w.frame bitmapRow $w.frame.0 error gray25 gray50 hourglass bitmapRow $w.frame.1 info question questhead warning button $w.ok -text OK -command "destroy $w" pack $w.msg -side top -anchor center pack $w.frame -side top -expand yes -fill both pack $w.ok -side bottom -fill both } # The procedure below creates a new row of bitmaps in a window. Its # arguments are: # # w - The window that is to contain the row. # args - The names of one or more bitmaps, which will be displayed # in a new row across the bottom of w along with their # names. proc bitmapRow {w args} { frame $w pack $w -side top -fill both set i 0 foreach bitmap $args { frame $w.$i pack $w.$i -side left -fill both -pady .25c -padx .25c label $w.$i.bitmap -bitmap $bitmap label $w.$i.label -text $bitmap -width 9 pack $w.$i.label $w.$i.bitmap -side bottom incr i } } gcl/gcl-tk/demos/mkButton.tcl000077500000000000000000000023231242227143400164260ustar00rootroot00000000000000# mkButton w # # Create a top-level window that displays a bunch of buttons. # # Arguments: # w - Name to use for new top-level window. proc mkButton {{w .b1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Button Demonstration" wm iconname $w "Buttons" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "Four buttons are displayed below. If you click on a button, it will change the background of the button area to the color indicated in the button. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg -side top -fill both pack $w.frame -side top -expand yes -fill both pack $w.ok -side bottom -fill both button $w.frame.b1 -text "Peach Puff" \ -command "$w.frame config -bg PeachPuff1" button $w.frame.b2 -text "Light Blue" \ -command "$w.frame config -bg LightBlue1" button $w.frame.b3 -text "Sea Green" \ -command "$w.frame config -bg SeaGreen2" button $w.frame.b4 -text "Yellow" \ -command "$w.frame config -bg Yellow1" pack $w.frame.b1 $w.frame.b2 $w.frame.b3 $w.frame.b4 -side top \ -expand yes -pady 2 } gcl/gcl-tk/demos/mkCanvText.lisp000077500000000000000000000116251242227143400171010ustar00rootroot00000000000000;;# mkCanvText w ;; ;; Create a top-level window containing a canvas displaying a text ;; string and allowing the string to be edited and re-anchored. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defun mkCanvText ({w .ctext}) (catch {destroy w}) (toplevel w) (dpos w) (wm :title w "Canvas Text Demonstration") (wm :iconname w "Text") (setq c (conc w '.c)) (message (conc w '.msg) :font -Adobe-Times-Medium-R-Normal-*-180-* :width 420 :relief "raised" :bd 2 :text "This window displays a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d. You can copy the selection with Control-v. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification.") (canvas c :relief "raised" :width 500 :height 400) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) :side "top" :fill "both") (pack (conc w '.c) :side "top" :expand "yes" :fill "both") (pack (conc w '.ok) :side "bottom" :pady 5 :anchor "center") (setq font :Adobe-helvetica-medium-r-*-240-*) (funcall c :create rectangle 245 195 255 205 :outline "black" :fill "red") ;; First, create the text item and give it bindings so it can be edited. (funcall c :addtag text withtag (funcall c create text 250 200 :text "This is just a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d." :width 440 :anchor "n" :font font :justify "left")) (funcall c :bind text "<1>" (textB1Press c |%x| |%y|)) (funcall c :bind text "" (textB1Move c %x %y)) (funcall c :bind text "" (tk-conc c " select adjust current @%x,%y")) (funcall c :bind text "" (funcall 'textB1Move c |%x| |%y|)) (funcall c :bind text "" (tk-conc c " insert text insert %A")) (funcall c :bind text "" (tk-conc c " insert text insert %A")) (funcall c :bind text "" (tk-conc c " insert text insert \\n")) (funcall c :bind text "" (funcall 'textBs c)) (funcall c :bind text "" (funcall 'textBs c)) (funcall c :bind text "" (tk-conc c " dchars text sel.first sel.last")) (funcall c :bind text "" (tk-conc c " insert text insert \[selection get\]")) ;; Next, create some items that allow the text's anchor position ;; to be edited. (setq x 50) (setq y 50) (setq color LightSkyBlue1) (mkTextConfig c x y :anchor "se" color) (mkTextConfig c (+ x 30) y :anchor "s" color) (mkTextConfig c (+ x 60) y :anchor "sw" color) (mkTextConfig c x (+ y 30) :anchor "e" color) (mkTextConfig c (+ x 30) (+ y 30) :anchor "center" color) (mkTextConfig c (+ x 60) (+ y 30) :anchor "w" color) (mkTextConfig c x (+ y 60) :anchor "ne" color) (mkTextConfig c (+ x 30) (+ y 60) :anchor "n" color) (mkTextConfig c (+ x 60) (+ y 60) :anchor "nw" color) (setq item (funcall c create rect (+ x 40) (+ y 40) (+ x 50) (+ y 50) :outline "black" :fill "red")) (funcall c :bind item "<1>" (tk-conc c " itemconf text :anchor ")center"") (funcall c :create text (+ x 45) (- y 5) :text "{Text Position}" :anchor "s" :font -Adobe-times-medium-r-normal--*-240-* :fill "brown") ;; Lastly, create some items that allow the text's justification to be ;; changed. (setq x 350) (setq y 50) (setq color SeaGreen2) (mkTextConfig c x y :justify "left" color) (mkTextConfig c (+ x 30) y :justify "center" color) (mkTextConfig c (+ x 60) y :justify "right" color) (funcall c :create text (+ x 45) (- y 5) :text "Justification" :anchor "s" :font -Adobe-times-medium-r-normal--*-240-* :fill "brown") (funcall c :bind config "" (tk-conc "textEnter " c)) (funcall c :bind config "" (tk-conc c " itemconf current :fill \$textConfigFill")) ) (defun mkTextConfig (w x y option value color) (setq item (funcall w create rect x y (+ x 30) (+ y 30) :outline "black" :fill color :width 1)) (funcall w :bind item "<1>" (tk-conc w " itemconf text " option " " value)) (funcall w :addtag "config" "withtag" item) ) (setq textConfigFill "") (defun textEnter (w) (global :textConfigFill) (setq textConfigFill [lindex (funcall w :itemconfig "current" :fill) 4]) (funcall w :itemconfig "current" :fill "black") ) (defun textB1Press (w x y) (funcall w :icursor "current" (aT x y)) (funcall w :focus "current") (focus w) (funcall w :select "from" "current" (aT x y)) ) (defun textB1Move (w x y) (funcall w :select "to current" (aT x y)) ) (defun textBs (w &aux char) (setq char (atoi (funcall w :index "text" "insert")) - 1) (if (>= char 0) (funcall w :dchar "text" char)) ) gcl/gcl-tk/demos/mkCanvText.tcl000077500000000000000000000105471242227143400167160ustar00rootroot00000000000000# mkCanvText w # # Create a top-level window containing a canvas displaying a text # string and allowing the string to be edited and re-anchored. # # Arguments: # w - Name to use for new top-level window. proc mkCanvText {{w .ctext}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Canvas Text Demonstration" wm iconname $w "Text" set c $w.c message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 420 \ -relief raised -bd 2 -text "This window displays a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d. You can copy the selection with Control-v. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification." canvas $c -relief raised -width 500 -height 400 button $w.ok -text "OK" -command "destroy $w" pack $w.msg -side top -fill both pack $w.c -side top -expand yes -fill both pack $w.ok -side bottom -pady 5 -anchor center set font -Adobe-helvetica-medium-r-*-240-* $c create rectangle 245 195 255 205 -outline black -fill red # First, create the text item and give it bindings so it can be edited. $c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d." -width 440 -anchor n -font $font -justify left] $c bind text <1> "textB1Press $c %x %y" $c bind text "textB1Move $c %x %y" $c bind text "$c select adjust current @%x,%y" $c bind text "textB1Move $c %x %y" $c bind text "$c insert text insert %A" $c bind text "$c insert text insert %A" $c bind text "$c insert text insert \\n" $c bind text "textBs $c" $c bind text "textBs $c" $c bind text "$c dchars text sel.first sel.last" $c bind text "$c insert text insert \[selection get\]" # Next, create some items that allow the text's anchor position # to be edited. set x 50 set y 50 set color LightSkyBlue1 mkTextConfig $c $x $y -anchor se $color mkTextConfig $c [expr $x+30] [expr $y] -anchor s $color mkTextConfig $c [expr $x+60] [expr $y] -anchor sw $color mkTextConfig $c [expr $x] [expr $y+30] -anchor e $color mkTextConfig $c [expr $x+30] [expr $y+30] -anchor center $color mkTextConfig $c [expr $x+60] [expr $y+30] -anchor w $color mkTextConfig $c [expr $x] [expr $y+60] -anchor ne $color mkTextConfig $c [expr $x+30] [expr $y+60] -anchor n $color mkTextConfig $c [expr $x+60] [expr $y+60] -anchor nw $color set item [$c create rect [expr $x+40] [expr $y+40] [expr $x+50] [expr $y+50] \ -outline black -fill red] $c bind $item <1> "$c itemconf text -anchor center" $c create text [expr $x+45] [expr $y-5] -text {Text Position} -anchor s \ -font -Adobe-times-medium-r-normal--*-240-* -fill brown # Lastly, create some items that allow the text's justification to be # changed. set x 350 set y 50 set color SeaGreen2 mkTextConfig $c $x $y -justify left $color mkTextConfig $c [expr $x+30] [expr $y] -justify center $color mkTextConfig $c [expr $x+60] [expr $y] -justify right $color $c create text [expr $x+45] [expr $y-5] -text {Justification} -anchor s \ -font -Adobe-times-medium-r-normal--*-240-* -fill brown $c bind config "textEnter $c" $c bind config "$c itemconf current -fill \$textConfigFill" } proc mkTextConfig {w x y option value color} { set item [$w create rect [expr $x] [expr $y] [expr $x+30] [expr $y+30] \ -outline black -fill $color -width 1] $w bind $item <1> "$w itemconf text $option $value" $w addtag config withtag $item } set textConfigFill {} proc textEnter {w} { global textConfigFill set textConfigFill [lindex [$w itemconfig current -fill] 4] $w itemconfig current -fill black } proc textB1Press {w x y} { $w icursor current @$x,$y $w focus current focus $w $w select from current @$x,$y } proc textB1Move {w x y} { $w select to current @$x,$y } proc textBs {w} { set char [expr {[$w index text insert] - 1}] if {$char >= 0} {$w dchar text $char} } gcl/gcl-tk/demos/mkCheck.tcl000077500000000000000000000026501242227143400161730ustar00rootroot00000000000000# mkCheck w # # Create a top-level window that displays a bunch of check buttons. # # Arguments: # w - Name to use for new top-level window. proc mkCheck {{w .c1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Checkbutton demonstration" wm iconname $w "Checkbuttons" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "Three checkbuttons are displayed below. If you click on a button, it will toggle the button's selection state and set a Tcl variable to a value indicating the state of the checkbutton. Click the \"See Variables\" button to see the current values of the variables. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 frame $w.frame2 pack $w.msg -side top -fill both pack $w.frame -side top -expand yes -fill both pack $w.frame2 -side bottom -fill both checkbutton $w.frame.b1 -text "Wipers OK" -variable wipers -relief flat checkbutton $w.frame.b2 -text "Brakes OK" -variable brakes -relief flat checkbutton $w.frame.b3 -text "Driver Sober" -variable sober -relief flat pack $w.frame.b1 $w.frame.b2 $w.frame.b3 -side top -pady 2 -expand yes \ -anchor w button $w.frame2.ok -text OK -command "destroy $w" button $w.frame2.vars -text "See Variables" \ -command "showVars $w.dialog wipers brakes sober" pack $w.frame2.ok $w.frame2.vars -side left -expand yes -fill both } gcl/gcl-tk/demos/mkDialog.tcl000077500000000000000000000043401242227143400163530ustar00rootroot00000000000000# mkDialog w msgArgs list list ... # # Create a dialog box with a message and any number of buttons at # the bottom. # # Arguments: # w - Name to use for new top-level window. # msgArgs - List of arguments to use when creating the message of the # dialog box (e.g. text, justifcation, etc.) # list - A two-element list that describes one of the buttons that # will appear at the bottom of the dialog. The first element # gives the text to be displayed in the button and the second # gives the command to be invoked when the button is invoked. proc mkDialog {w msgArgs args} { catch {destroy $w} toplevel $w -class Dialog wm title $w "Dialog box" wm iconname $w "Dialog" # Create two frames in the main window. The top frame will hold the # message and the bottom one will hold the buttons. Arrange them # one above the other, with any extra vertical space split between # them. frame $w.top -relief raised -border 1 frame $w.bot -relief raised -border 1 pack $w.top $w.bot -side top -fill both -expand yes # Create the message widget and arrange for it to be centered in the # top frame. eval message $w.top.msg -justify center \ -font -Adobe-times-medium-r-normal--*-180* $msgArgs pack $w.top.msg -side top -expand yes -padx 3 -pady 3 # Create as many buttons as needed and arrange them from left to right # in the bottom frame. Embed the left button in an additional sunken # frame to indicate that it is the default button, and arrange for that # button to be invoked as the default action for clicks and returns in # the dialog. if {[llength $args] > 0} { set arg [lindex $args 0] frame $w.bot.0 -relief sunken -border 1 pack $w.bot.0 -side left -expand yes -padx 10 -pady 10 button $w.bot.0.button -text [lindex $arg 0] \ -command "[lindex $arg 1]; destroy $w" pack $w.bot.0.button -expand yes -padx 6 -pady 6 bind $w "[lindex $arg 1]; destroy $w" focus $w set i 1 foreach arg [lrange $args 1 end] { button $w.bot.$i -text [lindex $arg 0] \ -command "[lindex $arg 1]; destroy $w" pack $w.bot.$i -side left -expand yes -padx 10 set i [expr $i+1] } } bind $w [list focus $w] focus $w } gcl/gcl-tk/demos/mkEntry.lisp000077500000000000000000000033101242227143400164360ustar00rootroot00000000000000;;# mkEntry w ;; ;; Create a top-level window that displays a bunch of entries. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defun mkEntry (&optional (w '.e1)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Entry Demonstration") (wm :iconname w "Entries") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 200 :text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. The usual emacs control characters control editing. Thus control-b back a char, control-f forward a char, control-a begin line, control-k kill rest of line, control-y yank. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough.") (frame (conc w '.frame) :borderwidth 10) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.frame) (conc w '.ok) :side "top" :fill "both") (entry (conc w '.frame.e1) :relief "sunken") (entry (conc w '.frame.e2) :relief "sunken") (entry (conc w '.frame.e3) :relief "sunken") (pack (conc w '.frame.e1) (conc w '.frame.e2) (conc w '.frame.e3) :side "top" :pady 5 :fill "x") (funcall (conc w '.frame.e1) :insert 0 "Initial value") (funcall (conc w '.frame.e2) :insert "end" "This entry contains a long value, much too long ") (funcall (conc w '.frame.e2) :insert "end" "to fit in the window at one time, so long in fact ") (funcall (conc w '.frame.e2) :insert "end" "that you'll have to scan or scroll to see the end.") ) gcl/gcl-tk/demos/mkEntry.tcl000077500000000000000000000027451242227143400162640ustar00rootroot00000000000000# mkEntry w # # Create a top-level window that displays a bunch of entries. # # Arguments: # w - Name to use for new top-level window. proc mkEntry {{w .e1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Entry Demonstration" wm iconname $w "Entries" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 200 \ -text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. You can delete by selecting and typing Control-d. Backspace, Control-h, and Delete may be typed to erase the character just before the insertion point, Control-W erases the word just before the insertion point, and Control-u clears the entry. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg $w.frame $w.ok -side top -fill both entry $w.frame.e1 -relief sunken entry $w.frame.e2 -relief sunken entry $w.frame.e3 -relief sunken pack $w.frame.e1 $w.frame.e2 $w.frame.e3 -side top -pady 5 -fill x $w.frame.e1 insert 0 "Initial value" $w.frame.e2 insert end "This entry contains a long value, much too long " $w.frame.e2 insert end "to fit in the window at one time, so long in fact " $w.frame.e2 insert end "that you'll have to scan or scroll to see the end." } gcl/gcl-tk/demos/mkEntry2.lisp000077500000000000000000000047751242227143400165400ustar00rootroot00000000000000;;# mkEntry2 - ;; ;; Create a top-level window that displays a bunch of entries with ;; scrollbars. ;; ;; Arguments: ;; w - Name to use for new top-level window. (IN-package "TK") (defun mkEntry2 (&optional (w '.e2)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Entry Demonstration") (wm :iconname w "Entries") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 200 :text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. You can delete by selecting and typing Control-d. Backspace, Control-h, and Delete may be typed to erase the character just before the insertion point, Control-W erases the word just before the insertion point, and Control-u clears the entry. For entries that are too large to fit in the window all at once, you can scan through the entries using the scrollbars, or by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough.") (frame (conc w '.frame) :borderwidth 10) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.frame) (conc w '.ok) :side "top" :fill "both") (entry (conc w '.frame.e1) :relief "sunken" :xscrollcommand (tk-conc w ".frame.s1 set")) (scrollbar (conc w '.frame.s1) :relief "sunken" :orient "horiz" :command (tk-conc w ".frame.e1 xview")) (frame (conc w '.frame.f1) :width 20 :height 10) (entry (conc w '.frame.e2) :relief "sunken" :xscrollcommand (tk-conc w ".frame.s2 set")) (scrollbar (conc w '.frame.s2) :relief "sunken" :orient "horiz" :command (tk-conc w ".frame.e2 xview")) (frame (conc w '.frame.f2) :width 20 :height 10) (entry (conc w '.frame.e3) :relief "sunken" :xscrollcommand (tk-conc w ".frame.s3 set")) (scrollbar (conc w '.frame.s3) :relief "sunken" :orient "horiz" :command (tk-conc w ".frame.e3 xview")) (pack (conc w '.frame.e1) (conc w '.frame.s1) (conc w '.frame.f1) (conc w '.frame.e2) (conc w '.frame.s2) (conc w '.frame.f2) (conc w '.frame.e3) (conc w '.frame.s3) :side "top" :fill "x") (funcall (conc w '.frame.e1) :insert 0 "Initial value") (funcall (conc w '.frame.e2) :insert 'end "This entry contains a long value, much too long ") (funcall (conc w '.frame.e2) :insert 'end "to fit in the window at one time, so long in fact ") (funcall (conc w '.frame.e2) :insert 'end "that you'll have to scan or scroll to see the end.") ) gcl/gcl-tk/demos/mkEntry2.tcl000077500000000000000000000040231242227143400163350ustar00rootroot00000000000000# mkEntry2 - # # Create a top-level window that displays a bunch of entries with # scrollbars. # # Arguments: # w - Name to use for new top-level window. proc mkEntry2 {{w .e2}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Entry Demonstration" wm iconname $w "Entries" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 200 \ -text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. You can delete by selecting and typing Control-d. Backspace, Control-h, and Delete may be typed to erase the character just before the insertion point, Control-W erases the word just before the insertion point, and Control-u clears the entry. For entries that are too large to fit in the window all at once, you can scan through the entries using the scrollbars, or by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg $w.frame $w.ok -side top -fill both entry $w.frame.e1 -relief sunken -xscrollcommand "$w.frame.s1 set" scrollbar $w.frame.s1 -relief sunken -orient horiz -command \ "$w.frame.e1 xview" frame $w.frame.f1 entry $w.frame.e2 -relief sunken -xscrollcommand "$w.frame.s2 set" scrollbar $w.frame.s2 -relief sunken -orient horiz -command \ "$w.frame.e2 xview" frame $w.frame.f2 entry $w.frame.e3 -relief sunken -xscrollcommand "$w.frame.s3 set" scrollbar $w.frame.s3 -relief sunken -orient horiz -command \ "$w.frame.e3 xview" pack $w.frame.e1 $w.frame.s1 $w.frame.f1 $w.frame.e2 $w.frame.s2 \ $w.frame.f2 $w.frame.e3 $w.frame.s3 -side top -fill x $w.frame.e1 insert 0 "Initial value" $w.frame.e2 insert end "This entry contains a long value, much too long " $w.frame.e2 insert end "to fit in the window at one time, so long in fact " $w.frame.e2 insert end "that you'll have to scan or scroll to see the end." } gcl/gcl-tk/demos/mkFloor.tcl000077500000000000000000002260401242227143400162400ustar00rootroot00000000000000# mkFloor w # # Create a top-level window containing a canvas that displays the # floorplan for DEC's Western Research Laboratory. # # Arguments: # w - Name to use for new top-level window. proc mkFloor {{w .cfloor}} { global c tk_library currentRoom colors catch {destroy $w} toplevel $w # dpos $w wm title $w "Floorplan Canvas Demonstration" wm iconname $w "Floorplan" wm minsize $w 100 100 set c $w.frame2.c message $w.msg -font *-Times-Medium-R-Normal-*-180-* -width 800 \ -relief raised -bd 2 -text "This window contains a canvas widget showing the floorplan of Digital Equipment Corporation's Western Research Laboratory. It has three levels. At any given time one of the levels is active, meaning that you can see its room structure. To activate a level, click the left mouse button anywhere on it. As the mouse moves over the active level, the room under the mouse lights up and its room number appears in the \"Room:\" entry. You can also type a room number in the entry and the room will light up." frame $w.frame2 -relief raised -bd 2 button $w.ok -text "OK" -command "destroy $w" pack $w.msg -side top -fill both pack $w.frame2 -side top -fill both -expand yes pack $w.ok -side bottom -pady 5 scrollbar $w.frame2.vscroll -relief sunken -command "$c yview" scrollbar $w.frame2.hscroll -orient horiz -relief sunken -command "$c xview" canvas $c -width 900 -height 500 -xscrollcommand "$w.frame2.hscroll set" \ -yscrollcommand "$w.frame2.vscroll set" pack $w.frame2.hscroll -side bottom -fill x pack $w.frame2.vscroll -side right -fill y pack $c -in $w.frame2 -expand yes -fill both # Create an entry for displaying and typing in current room. entry $c.entry -width 10 -relief sunken -bd 2 -textvariable currentRoom # Choose colors, then fill in the floorplan. if {[winfo depth $c] > 1} { set colors(bg1) #c0a3db55dc28 set colors(outline1) #70207f868000 set colors(bg2) #aeb8c6eec7ad set colors(outline2) #59b466056666 set colors(bg3) #9cfab288b333 set colors(outline3) #43474c834ccd set colors(offices) Black set colors(active) #dae0f278f332 } else { set colors(bg1) white set colors(outline1) black set colors(bg2) white set colors(outline2) black set colors(bg3) white set colors(outline3) black set colors(offices) Black set colors(active) black } floorDisplay $c 3 # Set up event bindings for canvas: $c bind floor1 <1> "floorDisplay $c 1" $c bind floor2 <1> "floorDisplay $c 2" $c bind floor3 <1> "floorDisplay $c 3" $c bind room \ "set currentRoom \$floorLabels(\[$c find withtag current\]) update idletasks" $c bind room {set currentRoom ""} bind $c <2> "$c scan mark %x %y" bind $c "$c scan dragto %x %y" bind $c "unset currentRoom" bind $c "focus $c.entry" set currentRoom "" trace variable currentRoom w "roomChanged $c" } set activeFloor "" # The following procedure recreates the floorplan display in the canvas # given by "w". The floor given by "active" (1, 2, or 3) is displayed # on top, with office structure visible. proc floorDisplay {w active} { global floorLabels floorItems colors activeFloor if {$activeFloor == $active} { return } $w delete all set activeFloor $active # First go through the three floors, displaying the backgrounds for # each floor. bg1 $w $colors(bg1) $colors(outline1) bg2 $w $colors(bg2) $colors(outline2) bg3 $w $colors(bg3) $colors(outline3) # Raise the background for the active floor so that it's on top. $w raise floor$active # Create a dummy item just to mark this point in the display list, # so we can insert highlights here. $w create rect 0 100 1 101 -fill {} -outline {} -tags marker # Add the walls and labels for the active floor, along with # transparent polygons that define the rooms on the floor. # Make sure that the room polygons are on top. catch {unset floorLabels} catch {unset floorItems} fg$active $w $colors(offices) $w raise room # Offset the floors diagonally from each other. $w move floor1 2c 2c $w move floor2 1c 1c # Create items for the room entry and its label. $w create window 600 100 -anchor w -window $w.entry $w create text 600 100 -anchor e -text "Room: " $w config -scrollregion [$w bbox all] } # This procedure is invoked whenever the currentRoom variable changes. # It highlights the current room and unhighlights any previous room. proc roomChanged {w args} { global currentRoom floorItems colors $w delete highlight if [catch {set item $floorItems($currentRoom)}] { return } set new [eval \ "$w create polygon [$w coords $item] -fill $colors(active) \ -tags highlight"] $w raise $new marker } # The following procedures are invoked to instantiate various portions # of the building floorplan. The bodies of these procedures were # generated automatically from database files describing the building. proc bg1 {w fill outline} { $w create poly 347 80 349 82 351 84 353 85 363 92 375 99 386 104 \ 386 129 398 129 398 162 484 162 484 129 559 129 559 133 725 \ 133 725 129 802 129 802 389 644 389 644 391 559 391 559 327 \ 508 327 508 311 484 311 484 278 395 278 395 288 400 288 404 \ 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 \ 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 \ 342 331 347 332 351 334 354 336 357 341 359 340 360 335 363 \ 331 365 326 366 304 366 304 355 258 355 258 387 60 387 60 391 \ 0 391 0 337 3 337 3 114 8 114 8 25 30 25 30 5 93 5 98 5 104 7 \ 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 34 221 \ 22 223 17 227 13 231 8 236 4 242 2 246 0 260 0 283 1 300 5 \ 321 14 335 22 348 25 365 29 363 39 358 48 352 56 337 70 \ 344 76 347 80 \ -tags {floor1 bg} -fill $fill $w create line 386 129 398 129 -fill $outline -tags {floor1 bg} $w create line 258 355 258 387 -fill $outline -tags {floor1 bg} $w create line 60 387 60 391 -fill $outline -tags {floor1 bg} $w create line 0 337 0 391 -fill $outline -tags {floor1 bg} $w create line 60 391 0 391 -fill $outline -tags {floor1 bg} $w create line 3 114 3 337 -fill $outline -tags {floor1 bg} $w create line 258 387 60 387 -fill $outline -tags {floor1 bg} $w create line 484 162 398 162 -fill $outline -tags {floor1 bg} $w create line 398 162 398 129 -fill $outline -tags {floor1 bg} $w create line 484 278 484 311 -fill $outline -tags {floor1 bg} $w create line 484 311 508 311 -fill $outline -tags {floor1 bg} $w create line 508 327 508 311 -fill $outline -tags {floor1 bg} $w create line 559 327 508 327 -fill $outline -tags {floor1 bg} $w create line 644 391 559 391 -fill $outline -tags {floor1 bg} $w create line 644 389 644 391 -fill $outline -tags {floor1 bg} $w create line 559 129 484 129 -fill $outline -tags {floor1 bg} $w create line 484 162 484 129 -fill $outline -tags {floor1 bg} $w create line 725 133 559 133 -fill $outline -tags {floor1 bg} $w create line 559 129 559 133 -fill $outline -tags {floor1 bg} $w create line 725 129 802 129 -fill $outline -tags {floor1 bg} $w create line 802 389 802 129 -fill $outline -tags {floor1 bg} $w create line 3 337 0 337 -fill $outline -tags {floor1 bg} $w create line 559 391 559 327 -fill $outline -tags {floor1 bg} $w create line 802 389 644 389 -fill $outline -tags {floor1 bg} $w create line 725 133 725 129 -fill $outline -tags {floor1 bg} $w create line 8 25 8 114 -fill $outline -tags {floor1 bg} $w create line 8 114 3 114 -fill $outline -tags {floor1 bg} $w create line 30 25 8 25 -fill $outline -tags {floor1 bg} $w create line 484 278 395 278 -fill $outline -tags {floor1 bg} $w create line 30 25 30 5 -fill $outline -tags {floor1 bg} $w create line 93 5 30 5 -fill $outline -tags {floor1 bg} $w create line 98 5 93 5 -fill $outline -tags {floor1 bg} $w create line 104 7 98 5 -fill $outline -tags {floor1 bg} $w create line 110 10 104 7 -fill $outline -tags {floor1 bg} $w create line 116 16 110 10 -fill $outline -tags {floor1 bg} $w create line 119 20 116 16 -fill $outline -tags {floor1 bg} $w create line 122 28 119 20 -fill $outline -tags {floor1 bg} $w create line 123 32 122 28 -fill $outline -tags {floor1 bg} $w create line 123 68 123 32 -fill $outline -tags {floor1 bg} $w create line 220 68 123 68 -fill $outline -tags {floor1 bg} $w create line 386 129 386 104 -fill $outline -tags {floor1 bg} $w create line 386 104 375 99 -fill $outline -tags {floor1 bg} $w create line 375 99 363 92 -fill $outline -tags {floor1 bg} $w create line 353 85 363 92 -fill $outline -tags {floor1 bg} $w create line 220 68 220 34 -fill $outline -tags {floor1 bg} $w create line 337 70 352 56 -fill $outline -tags {floor1 bg} $w create line 352 56 358 48 -fill $outline -tags {floor1 bg} $w create line 358 48 363 39 -fill $outline -tags {floor1 bg} $w create line 363 39 365 29 -fill $outline -tags {floor1 bg} $w create line 365 29 348 25 -fill $outline -tags {floor1 bg} $w create line 348 25 335 22 -fill $outline -tags {floor1 bg} $w create line 335 22 321 14 -fill $outline -tags {floor1 bg} $w create line 321 14 300 5 -fill $outline -tags {floor1 bg} $w create line 300 5 283 1 -fill $outline -tags {floor1 bg} $w create line 283 1 260 0 -fill $outline -tags {floor1 bg} $w create line 260 0 246 0 -fill $outline -tags {floor1 bg} $w create line 246 0 242 2 -fill $outline -tags {floor1 bg} $w create line 242 2 236 4 -fill $outline -tags {floor1 bg} $w create line 236 4 231 8 -fill $outline -tags {floor1 bg} $w create line 231 8 227 13 -fill $outline -tags {floor1 bg} $w create line 223 17 227 13 -fill $outline -tags {floor1 bg} $w create line 221 22 223 17 -fill $outline -tags {floor1 bg} $w create line 220 34 221 22 -fill $outline -tags {floor1 bg} $w create line 340 360 335 363 -fill $outline -tags {floor1 bg} $w create line 335 363 331 365 -fill $outline -tags {floor1 bg} $w create line 331 365 326 366 -fill $outline -tags {floor1 bg} $w create line 326 366 304 366 -fill $outline -tags {floor1 bg} $w create line 304 355 304 366 -fill $outline -tags {floor1 bg} $w create line 395 288 400 288 -fill $outline -tags {floor1 bg} $w create line 404 288 400 288 -fill $outline -tags {floor1 bg} $w create line 409 290 404 288 -fill $outline -tags {floor1 bg} $w create line 413 292 409 290 -fill $outline -tags {floor1 bg} $w create line 418 297 413 292 -fill $outline -tags {floor1 bg} $w create line 421 302 418 297 -fill $outline -tags {floor1 bg} $w create line 422 309 421 302 -fill $outline -tags {floor1 bg} $w create line 421 318 422 309 -fill $outline -tags {floor1 bg} $w create line 421 318 417 325 -fill $outline -tags {floor1 bg} $w create line 417 325 411 330 -fill $outline -tags {floor1 bg} $w create line 411 330 405 332 -fill $outline -tags {floor1 bg} $w create line 405 332 397 333 -fill $outline -tags {floor1 bg} $w create line 397 333 344 333 -fill $outline -tags {floor1 bg} $w create line 344 333 340 334 -fill $outline -tags {floor1 bg} $w create line 340 334 336 336 -fill $outline -tags {floor1 bg} $w create line 336 336 335 338 -fill $outline -tags {floor1 bg} $w create line 335 338 332 342 -fill $outline -tags {floor1 bg} $w create line 331 347 332 342 -fill $outline -tags {floor1 bg} $w create line 332 351 331 347 -fill $outline -tags {floor1 bg} $w create line 334 354 332 351 -fill $outline -tags {floor1 bg} $w create line 336 357 334 354 -fill $outline -tags {floor1 bg} $w create line 341 359 336 357 -fill $outline -tags {floor1 bg} $w create line 341 359 340 360 -fill $outline -tags {floor1 bg} $w create line 395 288 395 278 -fill $outline -tags {floor1 bg} $w create line 304 355 258 355 -fill $outline -tags {floor1 bg} $w create line 347 80 344 76 -fill $outline -tags {floor1 bg} $w create line 344 76 337 70 -fill $outline -tags {floor1 bg} $w create line 349 82 347 80 -fill $outline -tags {floor1 bg} $w create line 351 84 349 82 -fill $outline -tags {floor1 bg} $w create line 353 85 351 84 -fill $outline -tags {floor1 bg} } proc bg2 {w fill outline} { $w create poly 559 129 484 129 484 162 398 162 398 129 315 129 \ 315 133 176 133 176 129 96 129 96 133 3 133 3 339 0 339 0 391 \ 60 391 60 387 258 387 258 329 350 329 350 311 395 311 395 280 \ 484 280 484 311 508 311 508 327 558 327 558 391 644 391 644 \ 367 802 367 802 129 725 129 725 133 559 133 559 129 \ -tags {floor2 bg} -fill $fill $w create line 350 311 350 329 -fill $outline -tags {floor2 bg} $w create line 398 129 398 162 -fill $outline -tags {floor2 bg} $w create line 802 367 802 129 -fill $outline -tags {floor2 bg} $w create line 802 129 725 129 -fill $outline -tags {floor2 bg} $w create line 725 133 725 129 -fill $outline -tags {floor2 bg} $w create line 559 129 559 133 -fill $outline -tags {floor2 bg} $w create line 559 133 725 133 -fill $outline -tags {floor2 bg} $w create line 484 162 484 129 -fill $outline -tags {floor2 bg} $w create line 559 129 484 129 -fill $outline -tags {floor2 bg} $w create line 802 367 644 367 -fill $outline -tags {floor2 bg} $w create line 644 367 644 391 -fill $outline -tags {floor2 bg} $w create line 644 391 558 391 -fill $outline -tags {floor2 bg} $w create line 558 327 558 391 -fill $outline -tags {floor2 bg} $w create line 558 327 508 327 -fill $outline -tags {floor2 bg} $w create line 508 327 508 311 -fill $outline -tags {floor2 bg} $w create line 484 311 508 311 -fill $outline -tags {floor2 bg} $w create line 484 280 484 311 -fill $outline -tags {floor2 bg} $w create line 398 162 484 162 -fill $outline -tags {floor2 bg} $w create line 484 280 395 280 -fill $outline -tags {floor2 bg} $w create line 395 280 395 311 -fill $outline -tags {floor2 bg} $w create line 258 387 60 387 -fill $outline -tags {floor2 bg} $w create line 3 133 3 339 -fill $outline -tags {floor2 bg} $w create line 3 339 0 339 -fill $outline -tags {floor2 bg} $w create line 60 391 0 391 -fill $outline -tags {floor2 bg} $w create line 0 339 0 391 -fill $outline -tags {floor2 bg} $w create line 60 387 60 391 -fill $outline -tags {floor2 bg} $w create line 258 329 258 387 -fill $outline -tags {floor2 bg} $w create line 350 329 258 329 -fill $outline -tags {floor2 bg} $w create line 395 311 350 311 -fill $outline -tags {floor2 bg} $w create line 398 129 315 129 -fill $outline -tags {floor2 bg} $w create line 176 133 315 133 -fill $outline -tags {floor2 bg} $w create line 176 129 96 129 -fill $outline -tags {floor2 bg} $w create line 3 133 96 133 -fill $outline -tags {floor2 bg} $w create line 315 133 315 129 -fill $outline -tags {floor2 bg} $w create line 176 133 176 129 -fill $outline -tags {floor2 bg} $w create line 96 133 96 129 -fill $outline -tags {floor2 bg} } proc bg3 {w fill outline} { $w create poly 159 300 107 300 107 248 159 248 159 129 96 129 96 \ 133 21 133 21 331 0 331 0 391 60 391 60 370 159 370 159 300 \ -tags {floor3 bg} -fill $fill $w create poly 258 370 258 329 350 329 350 311 399 311 399 129 \ 315 129 315 133 176 133 176 129 159 129 159 370 258 370 \ -tags {floor3 bg} -fill $fill $w create line 96 133 96 129 -fill $outline -tags {floor3 bg} $w create line 176 129 96 129 -fill $outline -tags {floor3 bg} $w create line 176 129 176 133 -fill $outline -tags {floor3 bg} $w create line 315 133 176 133 -fill $outline -tags {floor3 bg} $w create line 315 133 315 129 -fill $outline -tags {floor3 bg} $w create line 399 129 315 129 -fill $outline -tags {floor3 bg} $w create line 399 311 399 129 -fill $outline -tags {floor3 bg} $w create line 399 311 350 311 -fill $outline -tags {floor3 bg} $w create line 350 329 350 311 -fill $outline -tags {floor3 bg} $w create line 350 329 258 329 -fill $outline -tags {floor3 bg} $w create line 258 370 258 329 -fill $outline -tags {floor3 bg} $w create line 60 370 258 370 -fill $outline -tags {floor3 bg} $w create line 60 370 60 391 -fill $outline -tags {floor3 bg} $w create line 60 391 0 391 -fill $outline -tags {floor3 bg} $w create line 0 391 0 331 -fill $outline -tags {floor3 bg} $w create line 21 331 0 331 -fill $outline -tags {floor3 bg} $w create line 21 331 21 133 -fill $outline -tags {floor3 bg} $w create line 96 133 21 133 -fill $outline -tags {floor3 bg} $w create line 107 300 159 300 159 248 107 248 107 300 \ -fill $outline -tags {floor3 bg} } proc fg1 {w color} { global floorLabels floorItems set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor1 room}] set floorLabels($i) 101 set {floorItems(101)} $i $w create text 358 209 -text 101 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor1 room}] set floorLabels($i) {Pub Lift1} set {floorItems(Pub Lift1)} $i $w create text 323 223 -text {Pub Lift1} -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor1 room}] set floorLabels($i) {Priv Lift1} set {floorItems(Priv Lift1)} $i $w create text 323 188 -text {Priv Lift1} -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 42 389 42 337 1 337 1 389 -fill {} -tags {floor1 room}] set floorLabels($i) 110 set {floorItems(110)} $i $w create text 21.5 363 -text 110 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 59 389 59 385 90 385 90 337 44 337 44 389 -fill {} -tags {floor1 room}] set floorLabels($i) 109 set {floorItems(109)} $i $w create text 67 363 -text 109 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 51 300 51 253 6 253 6 300 -fill {} -tags {floor1 room}] set floorLabels($i) 111 set {floorItems(111)} $i $w create text 28.5 276.5 -text 111 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 98 248 98 309 79 309 79 248 -fill {} -tags {floor1 room}] set floorLabels($i) 117B set {floorItems(117B)} $i $w create text 88.5 278.5 -text 117B -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 51 251 51 204 6 204 6 251 -fill {} -tags {floor1 room}] set floorLabels($i) 112 set {floorItems(112)} $i $w create text 28.5 227.5 -text 112 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 6 156 51 156 51 203 6 203 -fill {} -tags {floor1 room}] set floorLabels($i) 113 set {floorItems(113)} $i $w create text 28.5 179.5 -text 113 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 85 169 79 169 79 192 85 192 -fill {} -tags {floor1 room}] set floorLabels($i) 117A set {floorItems(117A)} $i $w create text 82 180.5 -text 117A -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 77 302 77 168 53 168 53 302 -fill {} -tags {floor1 room}] set floorLabels($i) 117 set {floorItems(117)} $i $w create text 65 235 -text 117 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 51 155 51 115 6 115 6 155 -fill {} -tags {floor1 room}] set floorLabels($i) 114 set {floorItems(114)} $i $w create text 28.5 135 -text 114 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 95 115 53 115 53 168 95 168 -fill {} -tags {floor1 room}] set floorLabels($i) 115 set {floorItems(115)} $i $w create text 74 141.5 -text 115 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 87 113 87 27 10 27 10 113 -fill {} -tags {floor1 room}] set floorLabels($i) 116 set {floorItems(116)} $i $w create text 48.5 70 -text 116 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 89 91 128 91 128 113 89 113 -fill {} -tags {floor1 room}] set floorLabels($i) 118 set {floorItems(118)} $i $w create text 108.5 102 -text 118 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 178 128 178 132 216 132 216 91 163 91 163 112 149 112 149 128 -fill {} -tags {floor1 room}] set floorLabels($i) 120 set {floorItems(120)} $i $w create text 189.5 111.5 -text 120 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 79 193 87 193 87 169 136 169 136 192 156 192 156 169 175 169 175 246 79 246 -fill {} -tags {floor1 room}] set floorLabels($i) 122 set {floorItems(122)} $i $w create text 131 207.5 -text 122 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 138 169 154 169 154 191 138 191 -fill {} -tags {floor1 room}] set floorLabels($i) 121 set {floorItems(121)} $i $w create text 146 180 -text 121 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 99 300 126 300 126 309 99 309 -fill {} -tags {floor1 room}] set floorLabels($i) 106A set {floorItems(106A)} $i $w create text 112.5 304.5 -text 106A -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 128 299 128 309 150 309 150 248 99 248 99 299 -fill {} -tags {floor1 room}] set floorLabels($i) 105 set {floorItems(105)} $i $w create text 124.5 278.5 -text 105 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 174 309 174 300 152 300 152 309 -fill {} -tags {floor1 room}] set floorLabels($i) 106B set {floorItems(106B)} $i $w create text 163 304.5 -text 106B -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 176 299 176 309 216 309 216 248 152 248 152 299 -fill {} -tags {floor1 room}] set floorLabels($i) 104 set {floorItems(104)} $i $w create text 184 278.5 -text 104 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 138 385 138 337 91 337 91 385 -fill {} -tags {floor1 room}] set floorLabels($i) 108 set {floorItems(108)} $i $w create text 114.5 361 -text 108 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 256 337 140 337 140 385 256 385 -fill {} -tags {floor1 room}] set floorLabels($i) 107 set {floorItems(107)} $i $w create text 198 361 -text 107 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 300 353 300 329 260 329 260 353 -fill {} -tags {floor1 room}] set floorLabels($i) Smoking set {floorItems(Smoking)} $i $w create text 280 341 -text Smoking -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 314 135 314 170 306 170 306 246 177 246 177 135 -fill {} -tags {floor1 room}] set floorLabels($i) 123 set {floorItems(123)} $i $w create text 245.5 190.5 -text 123 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 217 248 301 248 301 326 257 326 257 310 217 310 -fill {} -tags {floor1 room}] set floorLabels($i) 103 set {floorItems(103)} $i $w create text 259 287 -text 103 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 396 188 377 188 377 169 316 169 316 131 396 131 -fill {} -tags {floor1 room}] set floorLabels($i) 124 set {floorItems(124)} $i $w create text 356 150 -text 124 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 397 226 407 226 407 189 377 189 377 246 397 246 -fill {} -tags {floor1 room}] set floorLabels($i) 125 set {floorItems(125)} $i $w create text 392 217.5 -text 125 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 399 187 409 187 409 207 474 207 474 164 399 164 -fill {} -tags {floor1 room}] set floorLabels($i) 126 set {floorItems(126)} $i $w create text 436.5 185.5 -text 126 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 409 209 409 229 399 229 399 253 486 253 486 239 474 239 474 209 -fill {} -tags {floor1 room}] set floorLabels($i) 127 set {floorItems(127)} $i $w create text 436.5 231 -text 127 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 501 164 501 174 495 174 495 188 490 188 490 204 476 204 476 164 -fill {} -tags {floor1 room}] set floorLabels($i) MShower set {floorItems(MShower)} $i $w create text 488.5 184 -text MShower -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 497 176 513 176 513 204 492 204 492 190 497 190 -fill {} -tags {floor1 room}] set floorLabels($i) Closet set {floorItems(Closet)} $i $w create text 502.5 190 -text Closet -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 476 237 476 206 513 206 513 254 488 254 488 237 -fill {} -tags {floor1 room}] set floorLabels($i) WShower set {floorItems(WShower)} $i $w create text 494.5 230 -text WShower -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 486 131 558 131 558 135 724 135 724 166 697 166 697 275 553 275 531 254 515 254 515 174 503 174 503 161 486 161 -fill {} -tags {floor1 room}] set floorLabels($i) 130 set {floorItems(130)} $i $w create text 638.5 205 -text 130 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 308 242 339 242 339 248 342 248 342 246 397 246 397 276 393 276 393 309 300 309 300 248 308 248 -fill {} -tags {floor1 room}] set floorLabels($i) 102 set {floorItems(102)} $i $w create text 367.5 278.5 -text 102 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 397 255 486 255 486 276 397 276 -fill {} -tags {floor1 room}] set floorLabels($i) 128 set {floorItems(128)} $i $w create text 441.5 265.5 -text 128 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 510 309 486 309 486 255 530 255 552 277 561 277 561 325 510 325 -fill {} -tags {floor1 room}] set floorLabels($i) 129 set {floorItems(129)} $i $w create text 535.5 293 -text 129 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 696 281 740 281 740 387 642 387 642 389 561 389 561 277 696 277 -fill {} -tags {floor1 room}] set floorLabels($i) 133 set {floorItems(133)} $i $w create text 628.5 335 -text 133 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 742 387 742 281 800 281 800 387 -fill {} -tags {floor1 room}] set floorLabels($i) 132 set {floorItems(132)} $i $w create text 771 334 -text 132 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 800 168 800 280 699 280 699 168 -fill {} -tags {floor1 room}] set floorLabels($i) 134 set {floorItems(134)} $i $w create text 749.5 224 -text 134 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 726 131 726 166 800 166 800 131 -fill {} -tags {floor1 room}] set floorLabels($i) 135 set {floorItems(135)} $i $w create text 763 148.5 -text 135 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 340 360 335 363 331 365 326 366 304 366 304 312 396 312 396 288 400 288 404 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 342 331 347 332 351 334 354 336 357 341 359 -fill {} -tags {floor1 room}] set floorLabels($i) {Ramona Stair} set {floorItems(Ramona Stair)} $i $w create text 368 323 -text {Ramona Stair} -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 30 23 30 5 93 5 98 5 104 7 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 87 90 87 90 23 -fill {} -tags {floor1 room}] set floorLabels($i) {University Stair} set {floorItems(University Stair)} $i $w create text 155 77.5 -text {University Stair} -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 282 37 295 40 312 49 323 56 337 70 352 56 358 48 363 39 365 29 348 25 335 22 321 14 300 5 283 1 260 0 246 0 242 2 236 4 231 8 227 13 223 17 221 22 220 34 260 34 -fill {} -tags {floor1 room}] set floorLabels($i) {Plaza Stair} set {floorItems(Plaza Stair)} $i $w create text 317.5 28.5 -text {Plaza Stair} -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 220 34 260 34 282 37 295 40 312 49 323 56 337 70 350 83 365 94 377 100 386 104 386 128 220 128 -fill {} -tags {floor1 room}] set floorLabels($i) {Plaza Deck} set {floorItems(Plaza Deck)} $i $w create text 303 81 -text {Plaza Deck} -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 257 336 77 336 6 336 6 301 77 301 77 310 257 310 -fill {} -tags {floor1 room}] set floorLabels($i) 106 set {floorItems(106)} $i $w create text 131.5 318.5 -text 106 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 146 110 162 110 162 91 130 91 130 115 95 115 95 128 114 128 114 151 157 151 157 153 112 153 112 130 97 130 97 168 175 168 175 131 146 131 -fill {} -tags {floor1 room}] set floorLabels($i) 119 set {floorItems(119)} $i $w create text 143.5 133 -text 119 -fill $color -anchor c -tags {floor1 label} $w create line 155 191 155 189 -fill $color -tags {floor1 wall} $w create line 155 177 155 169 -fill $color -tags {floor1 wall} $w create line 96 129 96 169 -fill $color -tags {floor1 wall} $w create line 78 169 176 169 -fill $color -tags {floor1 wall} $w create line 176 247 176 129 -fill $color -tags {floor1 wall} $w create line 340 206 307 206 -fill $color -tags {floor1 wall} $w create line 340 187 340 170 -fill $color -tags {floor1 wall} $w create line 340 210 340 201 -fill $color -tags {floor1 wall} $w create line 340 247 340 224 -fill $color -tags {floor1 wall} $w create line 340 241 307 241 -fill $color -tags {floor1 wall} $w create line 376 246 376 170 -fill $color -tags {floor1 wall} $w create line 307 247 307 170 -fill $color -tags {floor1 wall} $w create line 376 170 307 170 -fill $color -tags {floor1 wall} $w create line 315 129 315 170 -fill $color -tags {floor1 wall} $w create line 147 129 176 129 -fill $color -tags {floor1 wall} $w create line 202 133 176 133 -fill $color -tags {floor1 wall} $w create line 398 129 315 129 -fill $color -tags {floor1 wall} $w create line 258 352 258 387 -fill $color -tags {floor1 wall} $w create line 60 387 60 391 -fill $color -tags {floor1 wall} $w create line 0 337 0 391 -fill $color -tags {floor1 wall} $w create line 60 391 0 391 -fill $color -tags {floor1 wall} $w create line 3 114 3 337 -fill $color -tags {floor1 wall} $w create line 258 387 60 387 -fill $color -tags {floor1 wall} $w create line 52 237 52 273 -fill $color -tags {floor1 wall} $w create line 52 189 52 225 -fill $color -tags {floor1 wall} $w create line 52 140 52 177 -fill $color -tags {floor1 wall} $w create line 395 306 395 311 -fill $color -tags {floor1 wall} $w create line 531 254 398 254 -fill $color -tags {floor1 wall} $w create line 475 178 475 238 -fill $color -tags {floor1 wall} $w create line 502 162 398 162 -fill $color -tags {floor1 wall} $w create line 398 129 398 188 -fill $color -tags {floor1 wall} $w create line 383 188 376 188 -fill $color -tags {floor1 wall} $w create line 408 188 408 194 -fill $color -tags {floor1 wall} $w create line 398 227 398 254 -fill $color -tags {floor1 wall} $w create line 408 227 398 227 -fill $color -tags {floor1 wall} $w create line 408 222 408 227 -fill $color -tags {floor1 wall} $w create line 408 206 408 210 -fill $color -tags {floor1 wall} $w create line 408 208 475 208 -fill $color -tags {floor1 wall} $w create line 484 278 484 311 -fill $color -tags {floor1 wall} $w create line 484 311 508 311 -fill $color -tags {floor1 wall} $w create line 508 327 508 311 -fill $color -tags {floor1 wall} $w create line 559 327 508 327 -fill $color -tags {floor1 wall} $w create line 644 391 559 391 -fill $color -tags {floor1 wall} $w create line 644 389 644 391 -fill $color -tags {floor1 wall} $w create line 514 205 475 205 -fill $color -tags {floor1 wall} $w create line 496 189 496 187 -fill $color -tags {floor1 wall} $w create line 559 129 484 129 -fill $color -tags {floor1 wall} $w create line 484 162 484 129 -fill $color -tags {floor1 wall} $w create line 725 133 559 133 -fill $color -tags {floor1 wall} $w create line 559 129 559 133 -fill $color -tags {floor1 wall} $w create line 725 149 725 167 -fill $color -tags {floor1 wall} $w create line 725 129 802 129 -fill $color -tags {floor1 wall} $w create line 802 389 802 129 -fill $color -tags {floor1 wall} $w create line 739 167 802 167 -fill $color -tags {floor1 wall} $w create line 396 188 408 188 -fill $color -tags {floor1 wall} $w create line 0 337 9 337 -fill $color -tags {floor1 wall} $w create line 58 337 21 337 -fill $color -tags {floor1 wall} $w create line 43 391 43 337 -fill $color -tags {floor1 wall} $w create line 105 337 75 337 -fill $color -tags {floor1 wall} $w create line 91 387 91 337 -fill $color -tags {floor1 wall} $w create line 154 337 117 337 -fill $color -tags {floor1 wall} $w create line 139 387 139 337 -fill $color -tags {floor1 wall} $w create line 227 337 166 337 -fill $color -tags {floor1 wall} $w create line 258 337 251 337 -fill $color -tags {floor1 wall} $w create line 258 328 302 328 -fill $color -tags {floor1 wall} $w create line 302 355 302 311 -fill $color -tags {floor1 wall} $w create line 395 311 302 311 -fill $color -tags {floor1 wall} $w create line 484 278 395 278 -fill $color -tags {floor1 wall} $w create line 395 294 395 278 -fill $color -tags {floor1 wall} $w create line 473 278 473 275 -fill $color -tags {floor1 wall} $w create line 473 256 473 254 -fill $color -tags {floor1 wall} $w create line 533 257 531 254 -fill $color -tags {floor1 wall} $w create line 553 276 551 274 -fill $color -tags {floor1 wall} $w create line 698 276 553 276 -fill $color -tags {floor1 wall} $w create line 559 391 559 327 -fill $color -tags {floor1 wall} $w create line 802 389 644 389 -fill $color -tags {floor1 wall} $w create line 741 314 741 389 -fill $color -tags {floor1 wall} $w create line 698 280 698 167 -fill $color -tags {floor1 wall} $w create line 707 280 698 280 -fill $color -tags {floor1 wall} $w create line 802 280 731 280 -fill $color -tags {floor1 wall} $w create line 741 280 741 302 -fill $color -tags {floor1 wall} $w create line 698 167 727 167 -fill $color -tags {floor1 wall} $w create line 725 137 725 129 -fill $color -tags {floor1 wall} $w create line 514 254 514 175 -fill $color -tags {floor1 wall} $w create line 496 175 514 175 -fill $color -tags {floor1 wall} $w create line 502 175 502 162 -fill $color -tags {floor1 wall} $w create line 475 166 475 162 -fill $color -tags {floor1 wall} $w create line 496 176 496 175 -fill $color -tags {floor1 wall} $w create line 491 189 496 189 -fill $color -tags {floor1 wall} $w create line 491 205 491 189 -fill $color -tags {floor1 wall} $w create line 487 238 475 238 -fill $color -tags {floor1 wall} $w create line 487 240 487 238 -fill $color -tags {floor1 wall} $w create line 487 252 487 254 -fill $color -tags {floor1 wall} $w create line 315 133 304 133 -fill $color -tags {floor1 wall} $w create line 256 133 280 133 -fill $color -tags {floor1 wall} $w create line 78 247 270 247 -fill $color -tags {floor1 wall} $w create line 307 247 294 247 -fill $color -tags {floor1 wall} $w create line 214 133 232 133 -fill $color -tags {floor1 wall} $w create line 217 247 217 266 -fill $color -tags {floor1 wall} $w create line 217 309 217 291 -fill $color -tags {floor1 wall} $w create line 217 309 172 309 -fill $color -tags {floor1 wall} $w create line 154 309 148 309 -fill $color -tags {floor1 wall} $w create line 175 300 175 309 -fill $color -tags {floor1 wall} $w create line 151 300 175 300 -fill $color -tags {floor1 wall} $w create line 151 247 151 309 -fill $color -tags {floor1 wall} $w create line 78 237 78 265 -fill $color -tags {floor1 wall} $w create line 78 286 78 309 -fill $color -tags {floor1 wall} $w create line 106 309 78 309 -fill $color -tags {floor1 wall} $w create line 130 309 125 309 -fill $color -tags {floor1 wall} $w create line 99 309 99 247 -fill $color -tags {floor1 wall} $w create line 127 299 99 299 -fill $color -tags {floor1 wall} $w create line 127 309 127 299 -fill $color -tags {floor1 wall} $w create line 155 191 137 191 -fill $color -tags {floor1 wall} $w create line 137 169 137 191 -fill $color -tags {floor1 wall} $w create line 78 171 78 169 -fill $color -tags {floor1 wall} $w create line 78 190 78 218 -fill $color -tags {floor1 wall} $w create line 86 192 86 169 -fill $color -tags {floor1 wall} $w create line 86 192 78 192 -fill $color -tags {floor1 wall} $w create line 52 301 3 301 -fill $color -tags {floor1 wall} $w create line 52 286 52 301 -fill $color -tags {floor1 wall} $w create line 52 252 3 252 -fill $color -tags {floor1 wall} $w create line 52 203 3 203 -fill $color -tags {floor1 wall} $w create line 3 156 52 156 -fill $color -tags {floor1 wall} $w create line 8 25 8 114 -fill $color -tags {floor1 wall} $w create line 63 114 3 114 -fill $color -tags {floor1 wall} $w create line 75 114 97 114 -fill $color -tags {floor1 wall} $w create line 108 114 129 114 -fill $color -tags {floor1 wall} $w create line 129 114 129 89 -fill $color -tags {floor1 wall} $w create line 52 114 52 128 -fill $color -tags {floor1 wall} $w create line 132 89 88 89 -fill $color -tags {floor1 wall} $w create line 88 25 88 89 -fill $color -tags {floor1 wall} $w create line 88 114 88 89 -fill $color -tags {floor1 wall} $w create line 218 89 144 89 -fill $color -tags {floor1 wall} $w create line 147 111 147 129 -fill $color -tags {floor1 wall} $w create line 162 111 147 111 -fill $color -tags {floor1 wall} $w create line 162 109 162 111 -fill $color -tags {floor1 wall} $w create line 162 96 162 89 -fill $color -tags {floor1 wall} $w create line 218 89 218 94 -fill $color -tags {floor1 wall} $w create line 218 89 218 119 -fill $color -tags {floor1 wall} $w create line 8 25 88 25 -fill $color -tags {floor1 wall} $w create line 258 337 258 328 -fill $color -tags {floor1 wall} $w create line 113 129 96 129 -fill $color -tags {floor1 wall} $w create line 302 355 258 355 -fill $color -tags {floor1 wall} $w create line 386 104 386 129 -fill $color -tags {floor1 wall} $w create line 377 100 386 104 -fill $color -tags {floor1 wall} $w create line 365 94 377 100 -fill $color -tags {floor1 wall} $w create line 350 83 365 94 -fill $color -tags {floor1 wall} $w create line 337 70 350 83 -fill $color -tags {floor1 wall} $w create line 337 70 323 56 -fill $color -tags {floor1 wall} $w create line 312 49 323 56 -fill $color -tags {floor1 wall} $w create line 295 40 312 49 -fill $color -tags {floor1 wall} $w create line 282 37 295 40 -fill $color -tags {floor1 wall} $w create line 260 34 282 37 -fill $color -tags {floor1 wall} $w create line 253 34 260 34 -fill $color -tags {floor1 wall} $w create line 386 128 386 104 -fill $color -tags {floor1 wall} $w create line 113 152 156 152 -fill $color -tags {floor1 wall} $w create line 113 152 156 152 -fill $color -tags {floor1 wall} $w create line 113 152 113 129 -fill $color -tags {floor1 wall} } proc fg2 {w color} { global floorLabels floorItems set i [$w create polygon 748 188 755 188 755 205 758 205 758 222 800 222 800 168 748 168 -fill {} -tags {floor2 room}] set floorLabels($i) 238 set {floorItems(238)} $i $w create text 774 195 -text 238 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 726 188 746 188 746 166 800 166 800 131 726 131 -fill {} -tags {floor2 room}] set floorLabels($i) 237 set {floorItems(237)} $i $w create text 763 148.5 -text 237 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 497 187 497 204 559 204 559 324 641 324 643 324 643 291 641 291 641 205 696 205 696 291 694 291 694 314 715 314 715 291 715 205 755 205 755 190 724 190 724 187 -fill {} -tags {floor2 room}] set floorLabels($i) 246 set {floorItems(246)} $i $w create text 600 264 -text 246 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 694 279 643 279 643 314 694 314 -fill {} -tags {floor2 room}] set floorLabels($i) 247 set {floorItems(247)} $i $w create text 668.5 296.5 -text 247 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 232 250 308 250 308 242 339 242 339 246 397 246 397 255 476 255 476 250 482 250 559 250 559 274 482 274 482 278 396 278 396 274 232 274 -fill {} -tags {floor2 room}] set floorLabels($i) 202 set {floorItems(202)} $i $w create text 285.5 260 -text 202 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 53 228 53 338 176 338 233 338 233 196 306 196 306 180 175 180 175 169 156 169 156 196 176 196 176 228 -fill {} -tags {floor2 room}] set floorLabels($i) 206 set {floorItems(206)} $i $w create text 143 267 -text 206 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 51 277 6 277 6 338 51 338 -fill {} -tags {floor2 room}] set floorLabels($i) 212 set {floorItems(212)} $i $w create text 28.5 307.5 -text 212 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 557 276 486 276 486 309 510 309 510 325 557 325 -fill {} -tags {floor2 room}] set floorLabels($i) 245 set {floorItems(245)} $i $w create text 521.5 300.5 -text 245 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 560 389 599 389 599 326 560 326 -fill {} -tags {floor2 room}] set floorLabels($i) 244 set {floorItems(244)} $i $w create text 579.5 357.5 -text 244 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 601 389 601 326 643 326 643 389 -fill {} -tags {floor2 room}] set floorLabels($i) 243 set {floorItems(243)} $i $w create text 622 357.5 -text 243 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 688 316 645 316 645 365 688 365 -fill {} -tags {floor2 room}] set floorLabels($i) 242 set {floorItems(242)} $i $w create text 666.5 340.5 -text 242 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 802 367 759 367 759 226 802 226 -fill {} -tags {floor2 room}] set floorLabels($i) {Barbecue Deck} set {floorItems(Barbecue Deck)} $i $w create text 780.5 296.5 -text {Barbecue Deck} -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 755 262 755 314 717 314 717 262 -fill {} -tags {floor2 room}] set floorLabels($i) 240 set {floorItems(240)} $i $w create text 736 288 -text 240 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 755 316 689 316 689 365 755 365 -fill {} -tags {floor2 room}] set floorLabels($i) 241 set {floorItems(241)} $i $w create text 722 340.5 -text 241 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 755 206 717 206 717 261 755 261 -fill {} -tags {floor2 room}] set floorLabels($i) 239 set {floorItems(239)} $i $w create text 736 233.5 -text 239 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 695 277 643 277 643 206 695 206 -fill {} -tags {floor2 room}] set floorLabels($i) 248 set {floorItems(248)} $i $w create text 669 241.5 -text 248 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 676 135 676 185 724 185 724 135 -fill {} -tags {floor2 room}] set floorLabels($i) 236 set {floorItems(236)} $i $w create text 700 160 -text 236 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 675 135 635 135 635 145 628 145 628 185 675 185 -fill {} -tags {floor2 room}] set floorLabels($i) 235 set {floorItems(235)} $i $w create text 651.5 160 -text 235 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 626 143 633 143 633 135 572 135 572 143 579 143 579 185 626 185 -fill {} -tags {floor2 room}] set floorLabels($i) 234 set {floorItems(234)} $i $w create text 606 160 -text 234 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 557 135 571 135 571 145 578 145 578 185 527 185 527 131 557 131 -fill {} -tags {floor2 room}] set floorLabels($i) 233 set {floorItems(233)} $i $w create text 552.5 158 -text 233 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 476 249 557 249 557 205 476 205 -fill {} -tags {floor2 room}] set floorLabels($i) 230 set {floorItems(230)} $i $w create text 516.5 227 -text 230 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 476 164 486 164 486 131 525 131 525 185 476 185 -fill {} -tags {floor2 room}] set floorLabels($i) 232 set {floorItems(232)} $i $w create text 500.5 158 -text 232 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 476 186 495 186 495 204 476 204 -fill {} -tags {floor2 room}] set floorLabels($i) 229 set {floorItems(229)} $i $w create text 485.5 195 -text 229 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 474 207 409 207 409 187 399 187 399 164 474 164 -fill {} -tags {floor2 room}] set floorLabels($i) 227 set {floorItems(227)} $i $w create text 436.5 185.5 -text 227 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 399 228 399 253 474 253 474 209 409 209 409 228 -fill {} -tags {floor2 room}] set floorLabels($i) 228 set {floorItems(228)} $i $w create text 436.5 231 -text 228 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 397 246 397 226 407 226 407 189 377 189 377 246 -fill {} -tags {floor2 room}] set floorLabels($i) 226 set {floorItems(226)} $i $w create text 392 217.5 -text 226 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 377 169 316 169 316 131 397 131 397 188 377 188 -fill {} -tags {floor2 room}] set floorLabels($i) 225 set {floorItems(225)} $i $w create text 356.5 150 -text 225 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 234 198 306 198 306 249 234 249 -fill {} -tags {floor2 room}] set floorLabels($i) 224 set {floorItems(224)} $i $w create text 270 223.5 -text 224 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 270 179 306 179 306 170 314 170 314 135 270 135 -fill {} -tags {floor2 room}] set floorLabels($i) 223 set {floorItems(223)} $i $w create text 292 157 -text 223 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 268 179 221 179 221 135 268 135 -fill {} -tags {floor2 room}] set floorLabels($i) 222 set {floorItems(222)} $i $w create text 244.5 157 -text 222 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 177 179 219 179 219 135 177 135 -fill {} -tags {floor2 room}] set floorLabels($i) 221 set {floorItems(221)} $i $w create text 198 157 -text 221 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 299 327 349 327 349 284 341 284 341 276 299 276 -fill {} -tags {floor2 room}] set floorLabels($i) 204 set {floorItems(204)} $i $w create text 324 301.5 -text 204 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 234 276 297 276 297 327 257 327 257 338 234 338 -fill {} -tags {floor2 room}] set floorLabels($i) 205 set {floorItems(205)} $i $w create text 265.5 307 -text 205 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 256 385 256 340 212 340 212 385 -fill {} -tags {floor2 room}] set floorLabels($i) 207 set {floorItems(207)} $i $w create text 234 362.5 -text 207 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 210 340 164 340 164 385 210 385 -fill {} -tags {floor2 room}] set floorLabels($i) 208 set {floorItems(208)} $i $w create text 187 362.5 -text 208 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 115 340 162 340 162 385 115 385 -fill {} -tags {floor2 room}] set floorLabels($i) 209 set {floorItems(209)} $i $w create text 138.5 362.5 -text 209 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 89 228 89 156 53 156 53 228 -fill {} -tags {floor2 room}] set floorLabels($i) 217 set {floorItems(217)} $i $w create text 71 192 -text 217 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 89 169 97 169 97 190 89 190 -fill {} -tags {floor2 room}] set floorLabels($i) 217A set {floorItems(217A)} $i $w create text 93 179.5 -text 217A -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 89 156 89 168 95 168 95 135 53 135 53 156 -fill {} -tags {floor2 room}] set floorLabels($i) 216 set {floorItems(216)} $i $w create text 71 145.5 -text 216 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 51 179 51 135 6 135 6 179 -fill {} -tags {floor2 room}] set floorLabels($i) 215 set {floorItems(215)} $i $w create text 28.5 157 -text 215 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 51 227 6 227 6 180 51 180 -fill {} -tags {floor2 room}] set floorLabels($i) 214 set {floorItems(214)} $i $w create text 28.5 203.5 -text 214 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 51 275 6 275 6 229 51 229 -fill {} -tags {floor2 room}] set floorLabels($i) 213 set {floorItems(213)} $i $w create text 28.5 252 -text 213 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 114 340 67 340 67 385 114 385 -fill {} -tags {floor2 room}] set floorLabels($i) 210 set {floorItems(210)} $i $w create text 90.5 362.5 -text 210 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 59 389 59 385 65 385 65 340 1 340 1 389 -fill {} -tags {floor2 room}] set floorLabels($i) 211 set {floorItems(211)} $i $w create text 33 364.5 -text 211 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 393 309 350 309 350 282 342 282 342 276 393 276 -fill {} -tags {floor2 room}] set floorLabels($i) 203 set {floorItems(203)} $i $w create text 367.5 292.5 -text 203 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 99 191 91 191 91 226 174 226 174 198 154 198 154 192 109 192 109 169 99 169 -fill {} -tags {floor2 room}] set floorLabels($i) 220 set {floorItems(220)} $i $w create text 132.5 208.5 -text 220 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor2 room}] set floorLabels($i) {Priv Lift2} set {floorItems(Priv Lift2)} $i $w create text 323 188 -text {Priv Lift2} -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor2 room}] set floorLabels($i) {Pub Lift 2} set {floorItems(Pub Lift 2)} $i $w create text 323 223 -text {Pub Lift 2} -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -tags {floor2 room}] set floorLabels($i) 218 set {floorItems(218)} $i $w create text 136 149.5 -text 218 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -tags {floor2 room}] set floorLabels($i) 219 set {floorItems(219)} $i $w create text 132.5 180 -text 219 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor2 room}] set floorLabels($i) 201 set {floorItems(201)} $i $w create text 358 209 -text 201 -fill $color -anchor c -tags {floor2 label} $w create line 641 186 678 186 -fill $color -tags {floor2 wall} $w create line 757 350 757 367 -fill $color -tags {floor2 wall} $w create line 634 133 634 144 -fill $color -tags {floor2 wall} $w create line 634 144 627 144 -fill $color -tags {floor2 wall} $w create line 572 133 572 144 -fill $color -tags {floor2 wall} $w create line 572 144 579 144 -fill $color -tags {floor2 wall} $w create line 398 129 398 162 -fill $color -tags {floor2 wall} $w create line 174 197 175 197 -fill $color -tags {floor2 wall} $w create line 175 197 175 227 -fill $color -tags {floor2 wall} $w create line 757 206 757 221 -fill $color -tags {floor2 wall} $w create line 396 188 408 188 -fill $color -tags {floor2 wall} $w create line 727 189 725 189 -fill $color -tags {floor2 wall} $w create line 747 167 802 167 -fill $color -tags {floor2 wall} $w create line 747 167 747 189 -fill $color -tags {floor2 wall} $w create line 755 189 739 189 -fill $color -tags {floor2 wall} $w create line 769 224 757 224 -fill $color -tags {floor2 wall} $w create line 802 224 802 129 -fill $color -tags {floor2 wall} $w create line 802 129 725 129 -fill $color -tags {floor2 wall} $w create line 725 189 725 129 -fill $color -tags {floor2 wall} $w create line 725 186 690 186 -fill $color -tags {floor2 wall} $w create line 676 133 676 186 -fill $color -tags {floor2 wall} $w create line 627 144 627 186 -fill $color -tags {floor2 wall} $w create line 629 186 593 186 -fill $color -tags {floor2 wall} $w create line 579 144 579 186 -fill $color -tags {floor2 wall} $w create line 559 129 559 133 -fill $color -tags {floor2 wall} $w create line 725 133 559 133 -fill $color -tags {floor2 wall} $w create line 484 162 484 129 -fill $color -tags {floor2 wall} $w create line 559 129 484 129 -fill $color -tags {floor2 wall} $w create line 526 129 526 186 -fill $color -tags {floor2 wall} $w create line 540 186 581 186 -fill $color -tags {floor2 wall} $w create line 528 186 523 186 -fill $color -tags {floor2 wall} $w create line 511 186 475 186 -fill $color -tags {floor2 wall} $w create line 496 190 496 186 -fill $color -tags {floor2 wall} $w create line 496 205 496 202 -fill $color -tags {floor2 wall} $w create line 475 205 527 205 -fill $color -tags {floor2 wall} $w create line 558 205 539 205 -fill $color -tags {floor2 wall} $w create line 558 205 558 249 -fill $color -tags {floor2 wall} $w create line 558 249 475 249 -fill $color -tags {floor2 wall} $w create line 662 206 642 206 -fill $color -tags {floor2 wall} $w create line 695 206 675 206 -fill $color -tags {floor2 wall} $w create line 695 278 642 278 -fill $color -tags {floor2 wall} $w create line 642 291 642 206 -fill $color -tags {floor2 wall} $w create line 695 291 695 206 -fill $color -tags {floor2 wall} $w create line 716 208 716 206 -fill $color -tags {floor2 wall} $w create line 757 206 716 206 -fill $color -tags {floor2 wall} $w create line 757 221 757 224 -fill $color -tags {floor2 wall} $w create line 793 224 802 224 -fill $color -tags {floor2 wall} $w create line 757 262 716 262 -fill $color -tags {floor2 wall} $w create line 716 220 716 264 -fill $color -tags {floor2 wall} $w create line 716 315 716 276 -fill $color -tags {floor2 wall} $w create line 757 315 703 315 -fill $color -tags {floor2 wall} $w create line 757 325 757 224 -fill $color -tags {floor2 wall} $w create line 757 367 644 367 -fill $color -tags {floor2 wall} $w create line 689 367 689 315 -fill $color -tags {floor2 wall} $w create line 647 315 644 315 -fill $color -tags {floor2 wall} $w create line 659 315 691 315 -fill $color -tags {floor2 wall} $w create line 600 325 600 391 -fill $color -tags {floor2 wall} $w create line 627 325 644 325 -fill $color -tags {floor2 wall} $w create line 644 391 644 315 -fill $color -tags {floor2 wall} $w create line 615 325 575 325 -fill $color -tags {floor2 wall} $w create line 644 391 558 391 -fill $color -tags {floor2 wall} $w create line 563 325 558 325 -fill $color -tags {floor2 wall} $w create line 558 391 558 314 -fill $color -tags {floor2 wall} $w create line 558 327 508 327 -fill $color -tags {floor2 wall} $w create line 558 275 484 275 -fill $color -tags {floor2 wall} $w create line 558 302 558 275 -fill $color -tags {floor2 wall} $w create line 508 327 508 311 -fill $color -tags {floor2 wall} $w create line 484 311 508 311 -fill $color -tags {floor2 wall} $w create line 484 275 484 311 -fill $color -tags {floor2 wall} $w create line 475 208 408 208 -fill $color -tags {floor2 wall} $w create line 408 206 408 210 -fill $color -tags {floor2 wall} $w create line 408 222 408 227 -fill $color -tags {floor2 wall} $w create line 408 227 398 227 -fill $color -tags {floor2 wall} $w create line 398 227 398 254 -fill $color -tags {floor2 wall} $w create line 408 188 408 194 -fill $color -tags {floor2 wall} $w create line 383 188 376 188 -fill $color -tags {floor2 wall} $w create line 398 188 398 162 -fill $color -tags {floor2 wall} $w create line 398 162 484 162 -fill $color -tags {floor2 wall} $w create line 475 162 475 254 -fill $color -tags {floor2 wall} $w create line 398 254 475 254 -fill $color -tags {floor2 wall} $w create line 484 280 395 280 -fill $color -tags {floor2 wall} $w create line 395 311 395 275 -fill $color -tags {floor2 wall} $w create line 307 197 293 197 -fill $color -tags {floor2 wall} $w create line 278 197 233 197 -fill $color -tags {floor2 wall} $w create line 233 197 233 249 -fill $color -tags {floor2 wall} $w create line 307 179 284 179 -fill $color -tags {floor2 wall} $w create line 233 249 278 249 -fill $color -tags {floor2 wall} $w create line 269 179 269 133 -fill $color -tags {floor2 wall} $w create line 220 179 220 133 -fill $color -tags {floor2 wall} $w create line 155 191 110 191 -fill $color -tags {floor2 wall} $w create line 90 190 98 190 -fill $color -tags {floor2 wall} $w create line 98 169 98 190 -fill $color -tags {floor2 wall} $w create line 52 133 52 165 -fill $color -tags {floor2 wall} $w create line 52 214 52 177 -fill $color -tags {floor2 wall} $w create line 52 226 52 262 -fill $color -tags {floor2 wall} $w create line 52 274 52 276 -fill $color -tags {floor2 wall} $w create line 234 275 234 339 -fill $color -tags {floor2 wall} $w create line 226 339 258 339 -fill $color -tags {floor2 wall} $w create line 211 387 211 339 -fill $color -tags {floor2 wall} $w create line 214 339 177 339 -fill $color -tags {floor2 wall} $w create line 258 387 60 387 -fill $color -tags {floor2 wall} $w create line 3 133 3 339 -fill $color -tags {floor2 wall} $w create line 165 339 129 339 -fill $color -tags {floor2 wall} $w create line 117 339 80 339 -fill $color -tags {floor2 wall} $w create line 68 339 59 339 -fill $color -tags {floor2 wall} $w create line 0 339 46 339 -fill $color -tags {floor2 wall} $w create line 60 391 0 391 -fill $color -tags {floor2 wall} $w create line 0 339 0 391 -fill $color -tags {floor2 wall} $w create line 60 387 60 391 -fill $color -tags {floor2 wall} $w create line 258 329 258 387 -fill $color -tags {floor2 wall} $w create line 350 329 258 329 -fill $color -tags {floor2 wall} $w create line 395 311 350 311 -fill $color -tags {floor2 wall} $w create line 398 129 315 129 -fill $color -tags {floor2 wall} $w create line 176 133 315 133 -fill $color -tags {floor2 wall} $w create line 176 129 96 129 -fill $color -tags {floor2 wall} $w create line 3 133 96 133 -fill $color -tags {floor2 wall} $w create line 66 387 66 339 -fill $color -tags {floor2 wall} $w create line 115 387 115 339 -fill $color -tags {floor2 wall} $w create line 163 387 163 339 -fill $color -tags {floor2 wall} $w create line 234 275 276 275 -fill $color -tags {floor2 wall} $w create line 288 275 309 275 -fill $color -tags {floor2 wall} $w create line 298 275 298 329 -fill $color -tags {floor2 wall} $w create line 341 283 350 283 -fill $color -tags {floor2 wall} $w create line 321 275 341 275 -fill $color -tags {floor2 wall} $w create line 375 275 395 275 -fill $color -tags {floor2 wall} $w create line 315 129 315 170 -fill $color -tags {floor2 wall} $w create line 376 170 307 170 -fill $color -tags {floor2 wall} $w create line 307 250 307 170 -fill $color -tags {floor2 wall} $w create line 376 245 376 170 -fill $color -tags {floor2 wall} $w create line 340 241 307 241 -fill $color -tags {floor2 wall} $w create line 340 245 340 224 -fill $color -tags {floor2 wall} $w create line 340 210 340 201 -fill $color -tags {floor2 wall} $w create line 340 187 340 170 -fill $color -tags {floor2 wall} $w create line 340 206 307 206 -fill $color -tags {floor2 wall} $w create line 293 250 307 250 -fill $color -tags {floor2 wall} $w create line 271 179 238 179 -fill $color -tags {floor2 wall} $w create line 226 179 195 179 -fill $color -tags {floor2 wall} $w create line 176 129 176 179 -fill $color -tags {floor2 wall} $w create line 182 179 176 179 -fill $color -tags {floor2 wall} $w create line 174 169 176 169 -fill $color -tags {floor2 wall} $w create line 162 169 90 169 -fill $color -tags {floor2 wall} $w create line 96 169 96 129 -fill $color -tags {floor2 wall} $w create line 175 227 90 227 -fill $color -tags {floor2 wall} $w create line 90 190 90 227 -fill $color -tags {floor2 wall} $w create line 52 179 3 179 -fill $color -tags {floor2 wall} $w create line 52 228 3 228 -fill $color -tags {floor2 wall} $w create line 52 276 3 276 -fill $color -tags {floor2 wall} $w create line 155 177 155 169 -fill $color -tags {floor2 wall} $w create line 110 191 110 169 -fill $color -tags {floor2 wall} $w create line 155 189 155 197 -fill $color -tags {floor2 wall} $w create line 350 283 350 329 -fill $color -tags {floor2 wall} $w create line 162 197 155 197 -fill $color -tags {floor2 wall} $w create line 341 275 341 283 -fill $color -tags {floor2 wall} } proc fg3 {w color} { global floorLabels floorItems set i [$w create polygon 89 228 89 180 70 180 70 228 -fill {} -tags {floor3 room}] set floorLabels($i) 316 set {floorItems(316)} $i $w create text 79.5 204 -text 316 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 115 368 162 368 162 323 115 323 -fill {} -tags {floor3 room}] set floorLabels($i) 309 set {floorItems(309)} $i $w create text 138.5 345.5 -text 309 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 164 323 164 368 211 368 211 323 -fill {} -tags {floor3 room}] set floorLabels($i) 308 set {floorItems(308)} $i $w create text 187.5 345.5 -text 308 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 256 368 212 368 212 323 256 323 -fill {} -tags {floor3 room}] set floorLabels($i) 307 set {floorItems(307)} $i $w create text 234 345.5 -text 307 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 244 276 297 276 297 327 260 327 260 321 244 321 -fill {} -tags {floor3 room}] set floorLabels($i) 305 set {floorItems(305)} $i $w create text 270.5 301.5 -text 305 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 251 219 251 203 244 203 244 219 -fill {} -tags {floor3 room}] set floorLabels($i) 324B set {floorItems(324B)} $i $w create text 247.5 211 -text 324B -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 251 249 244 249 244 232 251 232 -fill {} -tags {floor3 room}] set floorLabels($i) 324A set {floorItems(324A)} $i $w create text 247.5 240.5 -text 324A -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 223 135 223 179 177 179 177 135 -fill {} -tags {floor3 room}] set floorLabels($i) 320 set {floorItems(320)} $i $w create text 200 157 -text 320 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 114 368 114 323 67 323 67 368 -fill {} -tags {floor3 room}] set floorLabels($i) 310 set {floorItems(310)} $i $w create text 90.5 345.5 -text 310 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 23 277 23 321 68 321 68 277 -fill {} -tags {floor3 room}] set floorLabels($i) 312 set {floorItems(312)} $i $w create text 45.5 299 -text 312 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 23 229 68 229 68 275 23 275 -fill {} -tags {floor3 room}] set floorLabels($i) 313 set {floorItems(313)} $i $w create text 45.5 252 -text 313 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 68 227 23 227 23 180 68 180 -fill {} -tags {floor3 room}] set floorLabels($i) 314 set {floorItems(314)} $i $w create text 45.5 203.5 -text 314 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 95 179 95 135 23 135 23 179 -fill {} -tags {floor3 room}] set floorLabels($i) 315 set {floorItems(315)} $i $w create text 59 157 -text 315 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 99 226 99 204 91 204 91 226 -fill {} -tags {floor3 room}] set floorLabels($i) 316B set {floorItems(316B)} $i $w create text 95 215 -text 316B -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 91 202 99 202 99 180 91 180 -fill {} -tags {floor3 room}] set floorLabels($i) 316A set {floorItems(316A)} $i $w create text 95 191 -text 316A -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 97 169 109 169 109 192 154 192 154 198 174 198 174 226 101 226 101 179 97 179 -fill {} -tags {floor3 room}] set floorLabels($i) 319 set {floorItems(319)} $i $w create text 141.5 209 -text 319 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 65 368 58 368 58 389 1 389 1 333 23 333 23 323 65 323 -fill {} -tags {floor3 room}] set floorLabels($i) 311 set {floorItems(311)} $i $w create text 29.5 361 -text 311 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -tags {floor3 room}] set floorLabels($i) 318 set {floorItems(318)} $i $w create text 132.5 180 -text 318 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -tags {floor3 room}] set floorLabels($i) 317 set {floorItems(317)} $i $w create text 136 149.5 -text 317 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 274 194 274 221 306 221 306 194 -fill {} -tags {floor3 room}] set floorLabels($i) 323 set {floorItems(323)} $i $w create text 290 207.5 -text 323 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 306 222 274 222 274 249 306 249 -fill {} -tags {floor3 room}] set floorLabels($i) 325 set {floorItems(325)} $i $w create text 290 235.5 -text 325 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 263 179 224 179 224 135 263 135 -fill {} -tags {floor3 room}] set floorLabels($i) 321 set {floorItems(321)} $i $w create text 243.5 157 -text 321 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 314 169 306 169 306 192 273 192 264 181 264 135 314 135 -fill {} -tags {floor3 room}] set floorLabels($i) 322 set {floorItems(322)} $i $w create text 293.5 163.5 -text 322 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor3 room}] set floorLabels($i) {Pub Lift3} set {floorItems(Pub Lift3)} $i $w create text 323 223 -text {Pub Lift3} -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor3 room}] set floorLabels($i) {Priv Lift3} set {floorItems(Priv Lift3)} $i $w create text 323 188 -text {Priv Lift3} -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 350 284 376 284 376 276 397 276 397 309 350 309 -fill {} -tags {floor3 room}] set floorLabels($i) 303 set {floorItems(303)} $i $w create text 373.5 292.5 -text 303 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 272 203 272 249 252 249 252 230 244 230 244 221 252 221 252 203 -fill {} -tags {floor3 room}] set floorLabels($i) 324 set {floorItems(324)} $i $w create text 262 226 -text 324 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 299 276 299 327 349 327 349 284 341 284 341 276 -fill {} -tags {floor3 room}] set floorLabels($i) 304 set {floorItems(304)} $i $w create text 324 301.5 -text 304 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor3 room}] set floorLabels($i) 301 set {floorItems(301)} $i $w create text 358 209 -text 301 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 397 246 377 246 377 185 397 185 -fill {} -tags {floor3 room}] set floorLabels($i) 327 set {floorItems(327)} $i $w create text 387 215.5 -text 327 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 316 131 316 169 377 169 377 185 397 185 397 131 -fill {} -tags {floor3 room}] set floorLabels($i) 326 set {floorItems(326)} $i $w create text 356.5 150 -text 326 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 308 251 242 251 242 274 342 274 342 282 375 282 375 274 397 274 397 248 339 248 339 242 308 242 -fill {} -tags {floor3 room}] set floorLabels($i) 302 set {floorItems(302)} $i $w create text 319.5 261 -text 302 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 70 321 242 321 242 200 259 200 259 203 272 203 272 193 263 180 242 180 175 180 175 169 156 169 156 196 177 196 177 228 107 228 70 228 70 275 107 275 107 248 160 248 160 301 107 301 107 275 70 275 -fill {} -tags {floor3 room}] set floorLabels($i) 306 set {floorItems(306)} $i $w create text 200.5 284.5 -text 306 -fill $color -anchor c -tags {floor3 label} $w create line 341 275 341 283 -fill $color -tags {floor3 wall} $w create line 162 197 155 197 -fill $color -tags {floor3 wall} $w create line 396 247 399 247 -fill $color -tags {floor3 wall} $w create line 399 129 399 311 -fill $color -tags {floor3 wall} $w create line 258 202 243 202 -fill $color -tags {floor3 wall} $w create line 350 283 350 329 -fill $color -tags {floor3 wall} $w create line 251 231 243 231 -fill $color -tags {floor3 wall} $w create line 243 220 251 220 -fill $color -tags {floor3 wall} $w create line 243 250 243 202 -fill $color -tags {floor3 wall} $w create line 155 197 155 190 -fill $color -tags {floor3 wall} $w create line 110 192 110 169 -fill $color -tags {floor3 wall} $w create line 155 192 110 192 -fill $color -tags {floor3 wall} $w create line 155 177 155 169 -fill $color -tags {floor3 wall} $w create line 176 197 176 227 -fill $color -tags {floor3 wall} $w create line 69 280 69 274 -fill $color -tags {floor3 wall} $w create line 21 276 69 276 -fill $color -tags {floor3 wall} $w create line 69 262 69 226 -fill $color -tags {floor3 wall} $w create line 21 228 69 228 -fill $color -tags {floor3 wall} $w create line 21 179 75 179 -fill $color -tags {floor3 wall} $w create line 69 179 69 214 -fill $color -tags {floor3 wall} $w create line 90 220 90 227 -fill $color -tags {floor3 wall} $w create line 90 204 90 202 -fill $color -tags {floor3 wall} $w create line 90 203 100 203 -fill $color -tags {floor3 wall} $w create line 90 187 90 179 -fill $color -tags {floor3 wall} $w create line 90 227 176 227 -fill $color -tags {floor3 wall} $w create line 100 179 100 227 -fill $color -tags {floor3 wall} $w create line 100 179 87 179 -fill $color -tags {floor3 wall} $w create line 96 179 96 129 -fill $color -tags {floor3 wall} $w create line 162 169 96 169 -fill $color -tags {floor3 wall} $w create line 173 169 176 169 -fill $color -tags {floor3 wall} $w create line 182 179 176 179 -fill $color -tags {floor3 wall} $w create line 176 129 176 179 -fill $color -tags {floor3 wall} $w create line 195 179 226 179 -fill $color -tags {floor3 wall} $w create line 224 133 224 179 -fill $color -tags {floor3 wall} $w create line 264 179 264 133 -fill $color -tags {floor3 wall} $w create line 238 179 264 179 -fill $color -tags {floor3 wall} $w create line 273 207 273 193 -fill $color -tags {floor3 wall} $w create line 273 235 273 250 -fill $color -tags {floor3 wall} $w create line 273 224 273 219 -fill $color -tags {floor3 wall} $w create line 273 193 307 193 -fill $color -tags {floor3 wall} $w create line 273 222 307 222 -fill $color -tags {floor3 wall} $w create line 273 250 307 250 -fill $color -tags {floor3 wall} $w create line 384 247 376 247 -fill $color -tags {floor3 wall} $w create line 340 206 307 206 -fill $color -tags {floor3 wall} $w create line 340 187 340 170 -fill $color -tags {floor3 wall} $w create line 340 210 340 201 -fill $color -tags {floor3 wall} $w create line 340 247 340 224 -fill $color -tags {floor3 wall} $w create line 340 241 307 241 -fill $color -tags {floor3 wall} $w create line 376 247 376 170 -fill $color -tags {floor3 wall} $w create line 307 250 307 170 -fill $color -tags {floor3 wall} $w create line 376 170 307 170 -fill $color -tags {floor3 wall} $w create line 315 129 315 170 -fill $color -tags {floor3 wall} $w create line 376 283 366 283 -fill $color -tags {floor3 wall} $w create line 376 283 376 275 -fill $color -tags {floor3 wall} $w create line 399 275 376 275 -fill $color -tags {floor3 wall} $w create line 341 275 320 275 -fill $color -tags {floor3 wall} $w create line 341 283 350 283 -fill $color -tags {floor3 wall} $w create line 298 275 298 329 -fill $color -tags {floor3 wall} $w create line 308 275 298 275 -fill $color -tags {floor3 wall} $w create line 243 322 243 275 -fill $color -tags {floor3 wall} $w create line 243 275 284 275 -fill $color -tags {floor3 wall} $w create line 258 322 226 322 -fill $color -tags {floor3 wall} $w create line 212 370 212 322 -fill $color -tags {floor3 wall} $w create line 214 322 177 322 -fill $color -tags {floor3 wall} $w create line 163 370 163 322 -fill $color -tags {floor3 wall} $w create line 165 322 129 322 -fill $color -tags {floor3 wall} $w create line 84 322 117 322 -fill $color -tags {floor3 wall} $w create line 71 322 64 322 -fill $color -tags {floor3 wall} $w create line 115 322 115 370 -fill $color -tags {floor3 wall} $w create line 66 322 66 370 -fill $color -tags {floor3 wall} $w create line 52 322 21 322 -fill $color -tags {floor3 wall} $w create line 21 331 0 331 -fill $color -tags {floor3 wall} $w create line 21 331 21 133 -fill $color -tags {floor3 wall} $w create line 96 133 21 133 -fill $color -tags {floor3 wall} $w create line 176 129 96 129 -fill $color -tags {floor3 wall} $w create line 315 133 176 133 -fill $color -tags {floor3 wall} $w create line 315 129 399 129 -fill $color -tags {floor3 wall} $w create line 399 311 350 311 -fill $color -tags {floor3 wall} $w create line 350 329 258 329 -fill $color -tags {floor3 wall} $w create line 258 322 258 370 -fill $color -tags {floor3 wall} $w create line 60 370 258 370 -fill $color -tags {floor3 wall} $w create line 60 370 60 391 -fill $color -tags {floor3 wall} $w create line 0 391 0 331 -fill $color -tags {floor3 wall} $w create line 60 391 0 391 -fill $color -tags {floor3 wall} $w create line 307 250 307 242 -fill $color -tags {floor3 wall} $w create line 273 250 307 250 -fill $color -tags {floor3 wall} $w create line 258 250 243 250 -fill $color -tags {floor3 wall} } gcl/gcl-tk/demos/mkForm.lisp000077500000000000000000000036331242227143400162500ustar00rootroot00000000000000;;# mkForm w ;; ;; Create a top-level window that displays a bunch of entries with ;; tabs set up to move between them. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defvar *tablist*) (defun mkForm (&optional (w '.form)) (setq *tablist* nil) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Form Demonstration") (wm :iconname w "Form") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :width "4i" :text "This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries. Click the \"OK\" button or type return when you're done.") (dolist (i '(f1 f2 f3 f4 f5)) (frame (conc w '|.| i) :bd "1m") (entry (conc w '|.| i '.entry) :relief "sunken" :width 40) (bind (conc w '|.| i '.entry) "" '(Tab *tabList*)) (bind (conc w '|.| i '.entry) "" `(destroy ',w)) (label (conc w '|.| i '.label)) (pack (conc w '|.| i '.entry) :side "right") (pack (conc w '|.| i '.label) :side "left") (push (conc i '.entry) *tablist*)) (setq *tablist* (nreverse *tablist*)) (funcall (conc w '.f1.label) :config :text "Name: ") (funcall (conc w '.f2.label) :config :text "Address: ") (funcall (conc w '.f5.label) :config :text "Phone: ") (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.f1) (conc w '.f2) (conc w '.f3) (conc w '.f4) (conc w '.f5) (conc w '.ok) :side "top" :fill "x") ) ;; The procedure below is invoked in response to tabs in the entry ;; windows. It moves the focus to the next window in the tab list. ;; Arguments: ;; ;; list - Ordered list of windows to receive focus (defun Tab (list) (setq i (position (focus :return t) list)) (cond ((null i) (setq i 0)) (t (incf i) (if (>= i (length list) ) (setq i 0)))) (focus (nth i list )) ) gcl/gcl-tk/demos/mkForm.tcl000077500000000000000000000030321242227143400160540ustar00rootroot00000000000000# mkForm w # # Create a top-level window that displays a bunch of entries with # tabs set up to move between them. # # Arguments: # w - Name to use for new top-level window. proc mkForm {{w .form}} { global tabList catch {destroy $w} toplevel $w dpos $w wm title $w "Form Demonstration" wm iconname $w "Form" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -width 4i \ -text "This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries. Click the \"OK\" button or type return when you're done." foreach i {f1 f2 f3 f4 f5} { frame $w.$i -bd 1m entry $w.$i.entry -relief sunken -width 40 bind $w.$i.entry "Tab \$tabList" bind $w.$i.entry "destroy $w" label $w.$i.label pack $w.$i.entry -side right pack $w.$i.label -side left } $w.f1.label config -text Name: $w.f2.label config -text Address: $w.f5.label config -text Phone: button $w.ok -text OK -command "destroy $w" pack $w.msg $w.f1 $w.f2 $w.f3 $w.f4 $w.f5 $w.ok -side top -fill x set tabList "$w.f1.entry $w.f2.entry $w.f3.entry $w.f4.entry $w.f5.entry" } # The procedure below is invoked in response to tabs in the entry # windows. It moves the focus to the next window in the tab list. # Arguments: # # list - Ordered list of windows to receive focus proc Tab {list} { set i [lsearch $list [focus]] if {$i < 0} { set i 0 } else { incr i if {$i >= [llength $list]} { set i 0 } } focus [lindex $list $i] } gcl/gcl-tk/demos/mkHScale.lisp000077500000000000000000000030041242227143400164740ustar00rootroot00000000000000;;# mkHScale w ;; ;; Create a top-level window that displays a horizontal scale. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defun mkHScale (&optional (w '.scale2)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Horizontal Scale Demonstration") (wm :iconname w "Scale") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 :text "A bar and a horizontal scale are displayed below. (if :you click or drag mouse button 1 in the scale, you can change the width of the bar. Click the \"OK\" button when you're finished.") (frame (conc w '.frame) :borderwidth 10) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.frame) (conc w '.ok) :side "top" :fill "x") (frame (conc w '.frame.top) :borderwidth 15) (scale (conc w '.frame.scale) :orient "horizontal" :length 280 :from 0 :to 250 :command (tk-conc "setWidth " w ".frame.top.inner") :tickinterval 50 :bg "Bisque1") (frame (conc w '.frame.top.inner) :width 20 :height 40 :relief "raised" :borderwidth 2 :bg "SteelBlue1") (pack (conc w '.frame.top) :side "top" :expand "yes" :anchor "sw") (pack (conc w '.frame.scale) :side "bottom" :expand "yes" :anchor "nw") (pack (conc w '.frame.top.inner) :expand "yes" :anchor "sw") (funcall (conc w '.frame.scale) :set 20) ) (defun setWidth (w width) (funcall w :config :width ${width} :height 40) ) gcl/gcl-tk/demos/mkHScale.tcl000077500000000000000000000023171242227143400163150ustar00rootroot00000000000000# mkHScale w # # Create a top-level window that displays a horizontal scale. # # Arguments: # w - Name to use for new top-level window. proc mkHScale {{w .scale2}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Horizontal Scale Demonstration" wm iconname $w "Scale" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "A bar and a horizontal scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the width of the bar. Click the \"OK\" button when you're finished." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg $w.frame $w.ok -side top -fill x frame $w.frame.top -borderwidth 15 scale $w.frame.scale -orient horizontal -length 280 -from 0 -to 250 \ -command "setWidth $w.frame.top.inner" -tickinterval 50 \ -bg Bisque1 pack $w.frame.top -side top -expand yes -anchor sw pack $w.frame.scale -side bottom -expand yes -anchor nw frame $w.frame.top.inner -relief raised -borderwidth 2 \ -bg SteelBlue1 pack $w.frame.top.inner -expand yes -anchor sw $w.frame.scale set 20 } proc setWidth {w width} { $w config -width $width } gcl/gcl-tk/demos/mkIcon.tcl000077500000000000000000000037411242227143400160500ustar00rootroot00000000000000# mkIcon w # # Create a top-level window that displays a bunch of iconic # buttons. # # Arguments: # w - Name to use for new top-level window. proc mkIcon {{w .icon}} { global tk_library catch {destroy $w} toplevel $w dpos $w wm title $w "Iconic Button Demonstration" wm iconname $w "Icons" label $w.msg -wraplength 5i -justify left -text "This window shows three ways of using bitmaps or images in radiobuttons and checkbuttons. On the left are two radiobuttons, each of which displays a bitmap and an indicator. In the middle is a checkbutton that displays a different image depending on whether it is selected or not. On the right is a checkbutton that displays a single bitmap but changes its background color to indicate whether or not it is selected." pack $w.msg -side top frame $w.buttons pack $w.buttons -side bottom -fill x -pady 2m button $w.buttons.dismiss -text Dismiss -command "destroy $w" pack $w.buttons.dismiss -side left -expand 1 image create bitmap flagup \ -file [file join $tk_library demos images flagup.bmp] \ -maskfile [file join $tk_library demos images flagup.bmp] image create bitmap flagdown \ -file [file join $tk_library demos images flagdown.bmp] \ -maskfile [file join $tk_library demos images flagdown.bmp] frame $w.frame -borderwidth 10 pack $w.frame -side top checkbutton $w.frame.b1 -image flagdown -selectimage flagup \ -indicatoron 0 $w.frame.b1 configure -selectcolor [$w.frame.b1 cget -background] checkbutton $w.frame.b2 \ -bitmap @[file join $tk_library demos images letters.bmp] \ -indicatoron 0 -selectcolor SeaGreen1 frame $w.frame.left pack $w.frame.left $w.frame.b1 $w.frame.b2 -side left -expand yes -padx 5m radiobutton $w.frame.left.b3 \ -bitmap @[file join $tk_library demos images letters.bmp] \ -variable letters -value full radiobutton $w.frame.left.b4 \ -bitmap @[file join $tk_library demos images noletter.bmp] \ -variable letters -value empty pack $w.frame.left.b3 $w.frame.left.b4 -side top -expand yes } gcl/gcl-tk/demos/mkItems.lisp000077500000000000000000000353221242227143400164260ustar00rootroot00000000000000;;# mkItems w ;; ;; Create a top-level window containing a canvas that displays the ;; various item types and allows them to be selected and moved. This ;; demo can be used to test out the point-hit and rectangle-hit code ;; for items. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defvar *color-display* nil) (defun mkItems (&optional (w '.citems)) (declare (special c tk_library)) (if (winfo :exists w :return 'boolean) (destroy w)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Canvas Item Demonstration") (wm :iconname w "Items") (wm :minsize w 100 100) (setq c (conc w '.frame2.c)) (message (conc w '.msg) :font :Adobe-Times-Medium-R-Normal--*-180-* :width "13c" :bd 2 :relief "raised" :text #u"This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area.") (frame (conc w '.frame2) :relief "raised" :bd 2) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) :side "top" :fill "x") (pack (conc w '.frame2) :side "top" :fill "both" :expand "yes") (pack (conc w '.ok) :side "bottom" :pady 5 :anchor "center") (scrollbar (conc w '.frame2.vscroll) :relief "sunken" :command (tk-conc c " yview")) (scrollbar (conc w '.frame2.hscroll) :orient "horiz" :relief "sunken" :command (tk-conc c " xview")) (canvas c :scrollregion "0c 0c 30c 24c" :width "15c" :height "10c" :relief "sunken" :borderwidth 2 :xscrollcommand (tk-conc w ".frame2.hscroll set") :yscrollcommand (tk-conc w ".frame2.vscroll set")) (pack (conc w '.frame2.hscroll) :side "bottom" :fill "x") (pack (conc w '.frame2.vscroll) :side "right" :fill "y") (pack c :in (conc w '.frame2) :expand "yes" :fill "both") ;; Display a 3x3 rectangular grid. (funcall c :create "rect" "0c" "0c" "30c" "24c" :width 2) (funcall c :create "line" "0c" "8c" "30c" "8c" :width 2) (funcall c :create "line" "0c" "16c" "30c" "16c" :width 2) (funcall c :create "line" "10c" "0c" "10c" "24c" :width 2) (funcall c :create "line" "20c" "0c" "20c" "24c" :width 2) (setq font1 :Adobe-Helvetica-Medium-R-Normal--*-120-*) (setq font2 :Adobe-Helvetica-Bold-R-Normal--*-240-*) (if (> (winfo :depth c :return 'number) 1) (progn (setq *color-display* t) (setq blue "DeepSkyBlue3") (setq red "red") (setq bisque "bisque3") (setq green "SeaGreen3")) (progn (setq blue "black") (setq red "black") (setq bisque "black") (setq green "black"))) ;; Set up demos within each of the areas of the grid. (funcall c :create "text" "5c" ".2c" :text "Lines" :anchor "n") (funcall c :create "line" "1c" "1c" "3c" "1c" "1c" "4c" "3c" "4c" :width "2m" :fill blue :cap "butt" :join "miter" :tags "item") (funcall c :create "line" "4.67c" "1c" "4.67c" "4c" :arrow "last" :tags "item") (funcall c :create "line" "6.33c" "1c" "6.33c" "4c" :arrow "both" :tags "item") (funcall c :create "line" "5c" "6c" "9c" "6c" "9c" "1c" "8c" "1c" "8c" "4.8c" "8.8c" "4.8c" "8.8c" "1.2c" "8.2c" "1.2c" "8.2c" "4.6c" "8.6c" "4.6c" "8.6c" "1.4c" "8.4c" "1.4c" "8.4c" "4.4c" :fill "red" :width 3 :tags "item") (funcall c :create "line" "1c" "5c" "7c" "5c" "7c" "7c" "9c" "7c" :width ".5c" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :arrow "both" :arrowshape "15 15 7" :tags "item") (funcall c :create "line" "1c" "7c" "1.75c" "5.8c" "2.5c" "7c" "3.25c" "5.8c" "4c" "7c" :width ".5c" :cap "round" :join "round" :tags "item") (funcall c :create "text" "15c" ".2c" :text "Curves (smoothed :lines)" :anchor "n") (funcall c :create "line" "11c" "4c" "11.5c" "1c" "13.5c" "1c" "14c" "4c" :smooth "on" :fill blue :tags "item") (funcall c :create "line" "15.5c" "1c" "19.5c" "1.5c" "15.5c" "4.5c" "19.5c" "4c" :smooth "on" :arrow "both" :width 3 :tags "item") (funcall c :create "line" "12c" "6c" "13.5c" "4.5c" "16.5c" "7.5c" "18c" "6c" "16.5c" "4.5c" "13.5c" "7.5c" "12c" "6c" :smooth "on" :width "3m" :cap "round" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill red :tags "item") (funcall c :create "text" '25c ".2c" :text "Polygons" :anchor "n") (funcall c :create "polygon" "21c" "1.0c" "22.5c" "1.75c" "24c" "1.0c" "23.25c" "2.5c" "24c" "4.0c" "22.5c" "3.25c" "21c" "4.0c" "21.75c" "2.5c" :fill green :tags "item") (funcall c :create "polygon" "25c" "4c" "25c" "4c" "25c" "1c" "26c" "1c" "27c" "4c" "28c" "1c" "29c" "1c" "29c" "4c" "29c" "4c" :fill red :smooth "on" :tags "item") (funcall c :create "polygon" "22c" "4.5c" "25c" "4.5c" "25c" "6.75c" "28c" "6.75c" "28c" "5.25c" "24c" "5.25c" "24c" "6.0c" "26c" "6c" "26c" "7.5c" "22c" "7.5c" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :tags "item") (funcall c :create "text" "5c" "8.2c" :text "Rectangles" :anchor "n") (funcall c :create "rectangle" "1c" "9.5c" "4c" "12.5c" :outline red :width "3m" :tags "item") (funcall c :create "rectangle" "0.5c" "13.5c" "4.5c" "15.5c" :fill green :tags "item") (funcall c :create "rectangle" "6c" "10c" "9c" "15c" :outline "" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item") (funcall c :create "text" "15c" "8.2c" :text "Ovals" :anchor "n") (funcall c :create "oval" "11c" "9.5c" "14c" "12.5c" :outline red :width "3m" :tags "item") (funcall c :create "oval" "10.5c" "13.5c" "14.5c" "15.5c" :fill green :tags "item") (funcall c :create "oval" "16c" "10c" "19c" "15c" :outline "" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item") (funcall c :create "text" "25c" "8.2c" :text "Text" :anchor "n") (funcall c :create "rectangle" "22.4c" "8.9c" "22.6c" "9.1c") (funcall c :create "text" "22.5c" "9c" :anchor "n" :font font1 :width "4c" :text "A short string of text, word-wrapped, justified left, and anchored north (at :the top). The rectangles show the anchor points for each piece of text." :tags "item") (funcall c :create "rectangle" "25.4c" "10.9c" "25.6c" "11.1c") (funcall c :create "text" "25.5c" "11c" :anchor "w" :font font1 :fill blue :text #u"Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." :justify "center" :tags "item") (funcall c :create "rectangle" "24.9c" "13.9c" "25.1c" "14.1c") (funcall c :create "text" "25c" "14c" :font font2 :anchor "c" :fill red :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :text "Stippled characters" :tags "item") (funcall c :create "text" "5c" "16.2c" :text "Arcs" :anchor "n") (funcall c :create "arc" "0.5c" "17c" "7c" "20c" :fill green :outline "black" :start 45 :extent 270 :style "pieslice" :tags "item") (funcall c :create "arc" "6.5c" "17c" "9.5c" "20c" :width "4m" :style "arc" :fill blue :start -135 :extent 270 :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :tags "item") (funcall c :create "arc" "0.5c" "20c" "9.5c" "24c" :width "4m" :style "pieslice" :fill "" :outline red :start 225 :extent -90 :tags "item") (funcall c :create "arc" "5.5c" "20.5c" "9.5c" "23.5c" :width "4m" :style "chord" :fill blue :outline "" :start 45 :extent 270 :tags "item") (funcall c :create "text" "15c" "16.2c" :text "Bitmaps" :anchor "n") (funcall c :create "bitmap" "13c" "20c" :bitmap "@" : *tk-library* : "/demos/images/face.bmp" :tags "item") (funcall c :create "bitmap" "17c" "18.5c" :bitmap "@" : *tk-library* : "/demos/images/noletter.bmp" :tags "item") (funcall c :create "bitmap" "17c" "21.5c" :bitmap "@" : *tk-library* : "/demos/images/letters.bmp" :tags "item") (funcall c :create "text" "25c" "16.2c" :text "Windows" :anchor "n") (button (conc c '.button) :text "Press Me" :command `(butPress ',c ',red)) (funcall c :create "window" "21c" "18c" :window (conc c '.button) :anchor "nw" :tags "item") (bind "Entry" "" '(emacs-move %W %A )) (bind "Entry" "" "") (entry (conc c '.entry) :width 20 :relief "sunken") (funcall (conc c '.entry) :insert "end" "Edit this text") (funcall c :create "window" "21c" "21c" :window (conc c '.entry) :anchor "nw" :tags "item") (scale (conc c '.scale) :from 0 :to 100 :length "6c" :sliderlength '.4c :width ".5c" :tickinterval 0) (funcall c :create "window" "28.5c" "17.5c" :window (conc c '.scale) :anchor "n" :tags "item") (funcall c :create "text" "21c" "17.9c" :text "Button" :anchor "sw") (funcall c :create "text" "21c" "20.9c" :text "Entry" :anchor "sw") (funcall c :create "text" "28.5c" "17.4c" :text "Scale" :anchor "s") ;; Set up event bindings for canvas: (funcall c :bind "item" "" `(itemEnter ',c)) (funcall c :bind "item" "" `(itemLeave ',c)) (bind c "<2>" (tk-conc c " scan mark %x %y")) (bind c "" (tk-conc c " scan dragto %x %y")) (bind c "<3>" `(itemMark ',c |%x| |%y|)) (bind c "" `(itemStroke ',c |%x| |%y|)) (bind c "" `(itemsUnderArea ',c)) (bind c "<1>" `(itemStartDrag ',c |%x| |%y|)) (bind c "" `(itemDrag ',c |%x| |%y|)) (bind w "" `(focus ',c)) ) ;; Utility procedures for highlighting the item under the pointer: (defvar *restorecmd* nil) (defun itemEnter (c &aux type bg) ; (global :*restorecmd*) (let ((current (funcall c :find "withtag" "current" :return 'string))) (if (equal current "") (return-from itementer nil)) (itemleave nil) (if (not *color-display*) (progn (itemLeave nil) (return-from itementer nil))) (setq type (funcall c :type current :return 'string)) (if (equal type "window") (progn (itemLeave nil) (return-from itemEnter nil))) (if (equal type "bitmap") (progn (setq bg (nth 4 (funcall c :itemconf current :background :return 'list-strings))) (push `(,c :itemconfig ',current :background ',bg) *restorecmd*) (funcall c :itemconfig current :background "SteelBlue2") (return-from itemEnter nil))) (setq fill (nth 4 (funcall c :itemconfig current :fill :return 'list-strings))) (if (or (member type '("rectangle" "oval" "arg") :test 'equal) (equal fill "")) (progn (setq outline (nth 4 (funcall c :itemconfig current :outline :return 'list-strings))) (push `(,c :itemconfig ',current :outline ',outline) *restorecmd*) (funcall c :itemconfig current :outline "SteelBlue2")) (progn (push `(,c :itemconfig ',current :fill ,fill) *restorecmd*) (funcall c :itemconfig current :fill "SteelBlue2"))) ) ) (defun itemLeave (c) ; (global :*restorecmd*) (let ((tem *restorecmd*)) (setq *restorecmd* nil) (dolist (v tem) (eval v)))) ;; Utility procedures for stroking out a rectangle and printing what's ;; underneath the rectangle's area. (defun itemMark (c x y) ; (global :areaX1 areaY1) (setq areaX1 (funcall c :canvasx x :return 'string)) (setq areaY1 (funcall c :canvasy y :return 'string)) (funcall c :delete "area") ) (defun itemStroke (c x y ) (declare (special areaX1 areaY1 areaX2 areaY2)) (or *recursive* (let ((*recursive* t)) (setq x (funcall c :canvasx x :return 'string)) (setq y (funcall c :canvasy y :return 'string)) (progn (setq areaX2 x) (setq areaY2 y) ;; this next return 'stringis simply for TIMING!!! ;; to make it wait for the result before going into subsequent!! (funcall c :delete "area" :return 'string) (funcall c :addtag "area" "withtag" (funcall c :create "rect" areaX1 areaY1 x y :outline "black" :return 'string)) )))) (defun itemsUnderArea (c) ; (global :areaX1 areaY1 areaX2 areaY2) (setq area (funcall c :find "withtag" "area" :return 'string)) (setq me c) (setq items "") (dolist (i (funcall c :find "enclosed" areaX1 areaY1 areaX2 areaY2 :return 'list-strings)) (if (search "item" (funcall c :gettags i :return 'string)) (setq items (tk-conc items " " i)))) (print (tk-conc "Items enclosed by area: " items)) (setq items "") (dolist (i (funcall c :find "overlapping" areaX1 areaY1 areaX2 areaY2 :return 'list-strings)) (if (search "item" (funcall c :gettags i :return 'string)) (setq items (tk-conc items " " i)))) (print (tk-conc "Items overlapping area: " items)) (terpri) (force-output) ) (setq areaX1 0) (setq areaY1 0) (setq areaX2 0) (setq areaY2 0) ;; Utility procedures to support dragging of items. (defvar *lastX* 0) (defvar *lastY* 0) (defun itemStartDrag (c x y) ; (global :*lastX* *lastY*) (setq *lastX* (funcall c :canvasx x :return 'number)) (setq *lastY* (funcall c :canvasy y :return 'number)) ) (defun itemDrag (c x y) ; (global :*lastX* *lastY*) (setq x (funcall c :canvasx x :return 'number)) (setq y (funcall c :canvasy y :return 'number)) (funcall c :move "current" (- x *lastX*) (- y *lastY*)) (setq *lastX* x) (setq *lastY* y) ) (defvar *recursive* nil) (defun itemDrag (c x y) ; (global :*lastX* *lastY*) (cond (*recursive* ) (t (let ((*recursive* t)) (setq x (funcall c :canvasx x :return 'number)) (setq y (funcall c :canvasy y :return 'number)) (funcall c :move "current" (- x *lastX*) (- y *lastY*)) (setq *lastX* x) (setq *lastY* y))))) ;; Procedure that's invoked when the button embedded in the "canvas" ;; is invoked. (defun butPress (w color) (setq i (funcall w :create "text" "25c" "18.1c" :text "Ouch!!" :fill color :anchor "n" :return 'string)) (after 500 (tk-conc w " delete " i)) ) (defvar *last-kill* "") ;(bind ".citems.frame2.c.entry" "" '(emacs-move %W %A )) (defun emacs-move (a key) (let* ((win a) ;; if this window is from tcl it is not yet a lisp function. ;; steal it... build it into coerce-result... (foo (or (fboundp win) (setf (symbol-function win) (make-widget-instance win nil)))) (pos (funcall win :index "insert" :return 'number)) char new) (setq new (case (setq char (aref key 0)) (#\^B (max 0 (- pos 1))) (#\^F (max 0 (+ pos 1))) (#\^A 0) (#\^E "end"))) ; (print (list a char key)) (cond (new (funcall win :icursor new)) ((eql char #\^D) (funcall win :delete pos )) ((or (eql char #\^K) (eql char #\v)) (setq *last-kill* (subseq (funcall win :get :return 'string) pos)) (funcall win :delete pos "end" )) ((eql char #\^Y) (funcall win :insert pos *last-kill*)) (t (funcall win :insert pos key))))) gcl/gcl-tk/demos/mkItems.tcl000077500000000000000000000234231242227143400162400ustar00rootroot00000000000000# mkItems w # # Create a top-level window containing a canvas that displays the # various item types and allows them to be selected and moved. This # demo can be used to test out the point-hit and rectangle-hit code # for items. # # Arguments: # w - Name to use for new top-level window. proc mkItems {{w .citems}} { global c tk_library catch {destroy $w} toplevel $w dpos $w wm title $w "Canvas Item Demonstration" wm iconname $w "Items" wm minsize $w 100 100 set c $w.frame2.c message $w.msg -font -Adobe-Times-Medium-R-Normal--*-180-* -width 13c \ -bd 2 -relief raised -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area." frame $w.frame2 -relief raised -bd 2 button $w.ok -text "OK" -command "destroy $w" pack $w.msg -side top -fill x pack $w.frame2 -side top -fill both -expand yes pack $w.ok -side bottom -pady 5 -anchor center canvas $c -scrollregion {0c 0c 30c 24c} -width 15c -height 10c \ -xscroll "$w.frame2.hscroll set" -yscroll "$w.frame2.vscroll set" scrollbar $w.frame2.vscroll -relief sunken -command "$c yview" scrollbar $w.frame2.hscroll -orient horiz -relief sunken -command "$c xview" pack $w.frame2.hscroll -side bottom -fill x pack $w.frame2.vscroll -side right -fill y pack $c -in $w.frame2 -expand yes -fill both # Display a 3x3 rectangular grid. $c create rect 0c 0c 30c 24c -width 2 $c create line 0c 8c 30c 8c -width 2 $c create line 0c 16c 30c 16c -width 2 $c create line 10c 0c 10c 24c -width 2 $c create line 20c 0c 20c 24c -width 2 set font1 -Adobe-Helvetica-Medium-R-Normal--*-120-* set font2 -Adobe-Helvetica-Bold-R-Normal--*-240-* if {[winfo depth $c] > 1} { set blue DeepSkyBlue3 set red red set bisque bisque3 set green SeaGreen3 } else { set blue black set red black set bisque black set green black } # Set up demos within each of the areas of the grid. $c create text 5c .2c -text Lines -anchor n $c create line 1c 1c 3c 1c 1c 4c 3c 4c -width 2m -fill $blue \ -cap butt -join miter -tags item $c create line 4.67c 1c 4.67c 4c -arrow last -tags item $c create line 6.33c 1c 6.33c 4c -arrow both -tags item $c create line 5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c \ 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c 8.4c 4.4c \ -width 3 -fill $red -tags item $c create line 1c 5c 7c 5c 7c 7c 9c 7c -width .5c \ -stipple @$tk_library/demos/bitmaps/grey.25 \ -arrow both -arrowshape {15 15 7} -tags item $c create line 1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c \ -cap round -join round -tags item $c create text 15c .2c -text "Curves (smoothed lines)" -anchor n $c create line 11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on \ -fill $blue -tags item $c create line 15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on \ -arrow both -width 3 -tags item $c create line 12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c \ 16.5c 4.5c 13.5c 7.5c 12c 6c -smooth on -width 3m -cap round \ -stipple @$tk_library/demos/bitmaps/grey.25 -fill $red -tags item $c create text 25c .2c -text Polygons -anchor n $c create polygon 21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c \ 24c 4.0c 22.5c 3.25c 21c 4.0c 21.75c 2.5c -fill $green -tags item $c create polygon 25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c \ 29c 1c 29c 4c 29c 4c -fill $red -smooth on -tags item $c create polygon 22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c \ 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c \ -stipple @$tk_library/demos/bitmaps/grey.25 -tags item $c create text 5c 8.2c -text Rectangles -anchor n $c create rectangle 1c 9.5c 4c 12.5c -outline $red -width 3m -tags item $c create rectangle 0.5c 13.5c 4.5c 15.5c -fill $green -tags item $c create rectangle 6c 10c 9c 15c -outline {} \ -stipple @$tk_library/demos/bitmaps/grey.25 -fill $blue -tags item $c create text 15c 8.2c -text Ovals -anchor n $c create oval 11c 9.5c 14c 12.5c -outline $red -width 3m -tags item $c create oval 10.5c 13.5c 14.5c 15.5c -fill $green -tags item $c create oval 16c 10c 19c 15c -outline {} \ -stipple @$tk_library/demos/bitmaps/grey.25 -fill $blue -tags item $c create text 25c 8.2c -text Text -anchor n $c create rectangle 22.4c 8.9c 22.6c 9.1c $c create text 22.5c 9c -anchor n -font $font1 -width 4c \ -text "A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text." -tags item $c create rectangle 25.4c 10.9c 25.6c 11.1c $c create text 25.5c 11c -anchor w -font $font1 -fill $blue \ -text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." \ -justify center -tags item $c create rectangle 24.9c 13.9c 25.1c 14.1c $c create text 25c 14c -font $font2 -anchor c -fill $red \ -stipple @$tk_library/demos/bitmaps/grey.5 \ -text "Stippled characters" -tags item $c create text 5c 16.2c -text Arcs -anchor n $c create arc 0.5c 17c 7c 20c -fill $green -outline black \ -start 45 -extent 270 -style pieslice -tags item $c create arc 6.5c 17c 9.5c 20c -width 4m -style arc \ -fill $blue -start -135 -extent 270 \ -stipple @$tk_library/demos/bitmaps/grey.25 -tags item $c create arc 0.5c 20c 9.5c 24c -width 4m -style pieslice \ -fill {} -outline $red -start 225 -extent -90 -tags item $c create arc 5.5c 20.5c 9.5c 23.5c -width 4m -style chord \ -fill $blue -outline {} -start 45 -extent 270 -tags item $c create text 15c 16.2c -text Bitmaps -anchor n $c create bitmap 13c 20c -bitmap @$tk_library/demos/bitmaps/face -tags item $c create bitmap 17c 18.5c \ -bitmap @$tk_library/demos/bitmaps/noletters -tags item $c create bitmap 17c 21.5c \ -bitmap @$tk_library/demos/bitmaps/letters -tags item $c create text 25c 16.2c -text Windows -anchor n button $c.button -text "Press Me" -command "butPress $c $red" $c create window 21c 18c -window $c.button -anchor nw -tags item entry $c.entry -width 20 -relief sunken $c.entry insert end "Edit this text" $c create window 21c 21c -window $c.entry -anchor nw -tags item scale $c.scale -from 0 -to 100 -length 6c -sliderlength .4c \ -width .5c -tickinterval 0 $c create window 28.5c 17.5c -window $c.scale -anchor n -tags item $c create text 21c 17.9c -text Button: -anchor sw $c create text 21c 20.9c -text Entry: -anchor sw $c create text 28.5c 17.4c -text Scale: -anchor s # Set up event bindings for canvas: $c bind item "itemEnter $c" $c bind item "itemLeave $c" bind $c <2> "$c scan mark %x %y" bind $c "$c scan dragto %x %y" bind $c <3> "itemMark $c %x %y" bind $c "itemStroke $c %x %y" bind $c "itemsUnderArea $c" bind $c <1> "itemStartDrag $c %x %y" bind $c "itemDrag $c %x %y" bind $w "focus $c" } # Utility procedures for highlighting the item under the pointer: proc itemEnter {c} { global restoreCmd if {[winfo depth $c] <= 1} { set restoreCmd {} return } set type [$c type current] if {$type == "window"} { set restoreCmd {} return } if {$type == "bitmap"} { set bg [lindex [$c itemconf current -background] 4] set restoreCmd [list $c itemconfig current -background $bg] $c itemconfig current -background SteelBlue2 return } set fill [lindex [$c itemconfig current -fill] 4] if {(($type == "rectangle") || ($type == "oval") || ($type == "arc")) && ($fill == "")} { set outline [lindex [$c itemconfig current -outline] 4] set restoreCmd "$c itemconfig current -outline $outline" $c itemconfig current -outline SteelBlue2 } else { set restoreCmd "$c itemconfig current -fill $fill" $c itemconfig current -fill SteelBlue2 } } proc itemLeave {c} { global restoreCmd eval $restoreCmd } # Utility procedures for stroking out a rectangle and printing what's # underneath the rectangle's area. proc itemMark {c x y} { global areaX1 areaY1 set areaX1 [$c canvasx $x] set areaY1 [$c canvasy $y] $c delete area } proc itemStroke {c x y} { global areaX1 areaY1 areaX2 areaY2 set x [$c canvasx $x] set y [$c canvasy $y] if {($areaX1 != $x) && ($areaY1 != $y)} { $c delete area $c addtag area withtag [$c create rect $areaX1 $areaY1 $x $y \ -outline black] set areaX2 $x set areaY2 $y } } proc itemsUnderArea {c} { global areaX1 areaY1 areaX2 areaY2 set area [$c find withtag area] set items "" foreach i [$c find enclosed $areaX1 $areaY1 $areaX2 $areaY2] { if {[lsearch [$c gettags $i] item] != -1} { lappend items $i } } puts stdout "Items enclosed by area: $items" set items "" foreach i [$c find overlapping $areaX1 $areaY1 $areaX2 $areaY2] { if {[lsearch [$c gettags $i] item] != -1} { lappend items $i } } puts stdout "Items overlapping area: $items" } set areaX1 0 set areaY1 0 set areaX2 0 set areaY2 0 # Utility procedures to support dragging of items. proc itemStartDrag {c x y} { global lastX lastY set lastX [$c canvasx $x] set lastY [$c canvasy $y] } proc itemDrag {c x y} { global lastX lastY set x [$c canvasx $x] set y [$c canvasy $y] $c move current [expr $x-$lastX] [expr $y-$lastY] set lastX $x set lastY $y } # Procedure that's invoked when the button embedded in the canvas # is invoked. proc butPress {w color} { set i [$w create text 25c 18.1c -text "Ouch!!" -fill $color -anchor n] after 500 "$w delete $i" } gcl/gcl-tk/demos/mkLabel.lisp000077500000000000000000000031241242227143400163570ustar00rootroot00000000000000;;# mkLabel w ;; ;; Create a top-level window that displays a bunch of labels. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defun mkLabel (&optional (w '.l1)) ; (global :tk_library) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Label Demonstration") (wm :iconname w "Labels") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 :text "Five labels are displayed below: three textual ones on the left, and a bitmap label and a text label on the right. Labels are pretty boring because you can't do anything with them. Click the \"OK\" button when you've seen enough.") (frame (conc w '.left)) (frame (conc w '.right)) (button (conc w '.ok) :text "OK" :command `(destroy ',w)) (pack (conc w '.msg) :side "top") (pack (conc w '.ok) :side "bottom" :fill "x") (pack (conc w '.left) (conc w '.right) :side "left" :expand "yes" :padx 10 :pady 10 :fill "both") (label (conc w '.left.l1) :text "First label") (label (conc w '.left.l2) :text "Second label, raised just for fun" :relief "raised") (label (conc w '.left.l3) :text "Third label, sunken" :relief "sunken") (pack (conc w '.left.l1) (conc w '.left.l2) (conc w '.left.l3) :side "top" :expand "yes" :pady 2 :anchor "w") (label (conc w '.right.bitmap) :bitmap "@": *tk-library* : "/demos/images/face" :borderwidth 2 :relief "sunken") (label (conc w '.right.caption) :text "Tcl/Tk Proprietor") (pack (conc w '.right.bitmap) (conc w '.right.caption) :side "top") ) gcl/gcl-tk/demos/mkLabel.tcl000077500000000000000000000024671242227143400162030ustar00rootroot00000000000000# mkLabel w # # Create a top-level window that displays a bunch of labels. # # Arguments: # w - Name to use for new top-level window. proc mkLabel {{w .l1}} { global tk_library catch {destroy $w} toplevel $w dpos $w wm title $w "Label Demonstration" wm iconname $w "Labels" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "Five labels are displayed below: three textual ones on the left, and a bitmap label and a text label on the right. Labels are pretty boring because you can't do anything with them. Click the \"OK\" button when you've seen enough." frame $w.left frame $w.right button $w.ok -text OK -command "destroy $w" pack $w.msg -side top pack $w.ok -side bottom -fill x pack $w.left $w.right -side left -expand yes -padx 10 -pady 10 -fill both label $w.left.l1 -text "First label" label $w.left.l2 -text "Second label, raised just for fun" -relief raised label $w.left.l3 -text "Third label, sunken" -relief sunken pack $w.left.l1 $w.left.l2 $w.left.l3 \ -side top -expand yes -pady 2 -anchor w label $w.right.bitmap -bitmap @$tk_library/demos/images/face.bmp \ -borderwidth 2 -relief sunken label $w.right.caption -text "Tcl/Tk Proprietor" pack $w.right.bitmap $w.right.caption -side top } gcl/gcl-tk/demos/mkListbox.lisp000077500000000000000000000033671242227143400167750ustar00rootroot00000000000000(in-package "TK") (defun mklistbox (&optional (w '.listbox)) (toplevel w ) (dpos w) (wm :title w "Listbox Demonstration (50 states)") (wm :iconname w "Listbox") (wm :minsize w 1 1) (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 :text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. Click the OK button when you've seen enough.") (frame (conc w '.frame) :borderwidth 10) (button (conc w '.ok) :text "OK" :command `(destroy ',w)) (pack (conc w '.frame) :side "top" :expand "yes" :fill "y") (pack (conc w '.ok) :side "bottom" :fill "x") (scrollbar (conc w '.frame '.scroll) :relief "sunken" :command (tk-conc w ".frame.list yview")) (listbox (conc w '.frame.list) :yscroll (tk-conc w ".frame.scroll set") :relief "sunken" :setgrid 1) (pack (conc w '.frame.scroll) :side "right" :fill "y") (pack (conc w '.frame.list) :side "left" :expand "yes" :fill "both") (funcall (conc w '.frame.list) :insert 0 "Alabama" "Alaska" "Arizona" "Arkansas" "California" "Colorado" "Connecticut" "Delaware" "Florida" "Georgia" "Hawaii" "Idaho" "Illinois" "Indiana" "Iowa" "Kansas" "Kentucky" "Louisiana" "Maine" "Maryland" "Massachusetts" "Michigan" "Minnesota" "Mississippi" "Missouri" "Montana" "Nebraska" "Nevada" "New Hampshire" "New Jersey" "New Mexico" "New York" "North Carolina" "North Dakota" "Ohio" "Oklahoma" "Oregon" "Pennsylvania" "Rhode Island" "South Carolina" "South Dakota" "Tennessee" "Texas" "Utah" "Vermont" "Virginia" "Washington" "West Virginia" "Wisconsin" "Wyoming") w) gcl/gcl-tk/demos/mkListbox.tcl000077500000000000000000000033011242227143400165740ustar00rootroot00000000000000# mkListbox w # # Create a top-level window that displays a listbox with the names of the # 50 states. # # Arguments: # w - Name to use for new top-level window. proc mkListbox {{w .l1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Listbox Demonstration (50 states)" wm iconname $w "Listbox" wm minsize $w 1 1 message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg -side top pack $w.frame -side top -expand yes -fill y pack $w.ok -side bottom -fill x scrollbar $w.frame.scroll -relief sunken -command "$w.frame.list yview" listbox $w.frame.list -yscroll "$w.frame.scroll set" -relief sunken \ -setgrid 1 pack $w.frame.scroll -side right -fill y pack $w.frame.list -side left -expand yes -fill both $w.frame.list insert 0 Alabama Alaska Arizona Arkansas California \ Colorado Connecticut Delaware Florida Georgia Hawaii Idaho Illinois \ Indiana Iowa Kansas Kentucky Louisiana Maine Maryland \ Massachusetts Michigan Minnesota Mississippi Missouri \ Montana Nebraska Nevada "New Hampshire" "New Jersey" "New Mexico" \ "New York" "North Carolina" "North Dakota" \ Ohio Oklahoma Oregon Pennsylvania "Rhode Island" \ "South Carolina" "South Dakota" \ Tennessee Texas Utah Vermont Virginia Washington \ "West Virginia" Wisconsin Wyoming } gcl/gcl-tk/demos/mkListbox2.tcl000077500000000000000000000114261242227143400166650ustar00rootroot00000000000000# mkListbox2 w # # Create a top-level window containing a listbox showing a bunch of # colors from the X color database. # # Arguments: # w - Name to use for new top-level window. proc mkListbox2 {{w .l2}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Listbox Demonstration (colors)" wm iconname $w "Listbox" wm minsize $w 1 1 message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "A listbox containing several color values is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. If you double-click button 1 on a color, then the background for the window will be changed to that color. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg -side top pack $w.ok -side bottom -fill x pack $w.frame -side top -expand yes -fill y scrollbar $w.frame.scroll -relief sunken -command "$w.frame.list yview" listbox $w.frame.list -yscroll "$w.frame.scroll set" -relief sunken \ -setgrid 1 pack $w.frame.list $w.frame.scroll -side left -fill y $w.frame.list insert 0 snow1 snow2 snow3 snow4 seashell1 seashell2 \ seashell3 seashell4 AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 \ AntiqueWhite4 bisque1 bisque2 bisque3 bisque4 PeachPuff1 \ PeachPuff2 PeachPuff3 PeachPuff4 NavajoWhite1 NavajoWhite2 \ NavajoWhite3 NavajoWhite4 LemonChiffon1 LemonChiffon2 \ LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2 cornsilk3 \ cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2 \ honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 \ LavenderBlush3 LavenderBlush4 MistyRose1 MistyRose2 \ MistyRose3 MistyRose4 azure1 azure2 azure3 azure4 \ SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4 RoyalBlue1 \ RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4 \ DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 \ SteelBlue2 SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 \ DeepSkyBlue3 DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 \ SkyBlue4 LightSkyBlue1 LightSkyBlue2 LightSkyBlue3 \ LightSkyBlue4 SlateGray1 SlateGray2 SlateGray3 SlateGray4 \ LightSteelBlue1 LightSteelBlue2 LightSteelBlue3 \ LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 \ LightBlue4 LightCyan1 LightCyan2 LightCyan3 LightCyan4 \ PaleTurquoise1 PaleTurquoise2 PaleTurquoise3 PaleTurquoise4 \ CadetBlue1 CadetBlue2 CadetBlue3 CadetBlue4 turquoise1 \ turquoise2 turquoise3 turquoise4 cyan1 cyan2 cyan3 cyan4 \ DarkSlateGray1 DarkSlateGray2 DarkSlateGray3 \ DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 \ aquamarine4 DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 \ DarkSeaGreen4 SeaGreen1 SeaGreen2 SeaGreen3 SeaGreen4 \ PaleGreen1 PaleGreen2 PaleGreen3 PaleGreen4 SpringGreen1 \ SpringGreen2 SpringGreen3 SpringGreen4 green1 green2 \ green3 green4 chartreuse1 chartreuse2 chartreuse3 \ chartreuse4 OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 \ DarkOliveGreen1 DarkOliveGreen2 DarkOliveGreen3 \ DarkOliveGreen4 khaki1 khaki2 khaki3 khaki4 \ LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 \ LightGoldenrod4 LightYellow1 LightYellow2 LightYellow3 \ LightYellow4 yellow1 yellow2 yellow3 yellow4 gold1 gold2 \ gold3 gold4 goldenrod1 goldenrod2 goldenrod3 goldenrod4 \ DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3 DarkGoldenrod4 \ RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1 \ IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 \ sienna4 burlywood1 burlywood2 burlywood3 burlywood4 wheat1 \ wheat2 wheat3 wheat4 tan1 tan2 tan3 tan4 chocolate1 \ chocolate2 chocolate3 chocolate4 firebrick1 firebrick2 \ firebrick3 firebrick4 brown1 brown2 brown3 brown4 salmon1 \ salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2 \ LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 \ DarkOrange1 DarkOrange2 DarkOrange3 DarkOrange4 coral1 \ coral2 coral3 coral4 tomato1 tomato2 tomato3 tomato4 \ OrangeRed1 OrangeRed2 OrangeRed3 OrangeRed4 red1 red2 red3 \ red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4 HotPink1 \ HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 \ LightPink1 LightPink2 LightPink3 LightPink4 PaleVioletRed1 \ PaleVioletRed2 PaleVioletRed3 PaleVioletRed4 maroon1 \ maroon2 maroon3 maroon4 VioletRed1 VioletRed2 VioletRed3 \ VioletRed4 magenta1 magenta2 magenta3 magenta4 orchid1 \ orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4 \ MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 \ DarkOrchid1 DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 \ purple2 purple3 purple4 MediumPurple1 MediumPurple2 \ MediumPurple3 MediumPurple4 thistle1 thistle2 thistle3 \ thistle4 bind $w.frame.list \ "$w config -bg \[lindex \[selection get\] 0\] $w.frame config -bg \[lindex \[selection get\] 0\] $w.msg config -bg \[lindex \[selection get\] 0\]" } gcl/gcl-tk/demos/mkListbox3.tcl000077500000000000000000000040701242227143400166630ustar00rootroot00000000000000# mkListbox3 w # # Create a top-level window containing a listbox with a bunch of well-known # sayings. The listbox can be scrolled or scanned in two dimensions. # # Arguments: # w - Name to use for new top-level window. proc mkListbox3 {{w .l3}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Listbox Demonstration (well-known sayings)" wm iconname $w "Listbox" wm minsize $w 1 1 message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "The listbox below contains a collection of well-known sayings. You can scan the list using either of the scrollbars or by dragging in the listbox window with button 2 pressed. Click the \"OK\" button when you're done." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg -side top pack $w.ok -side bottom -fill x pack $w.frame -side top -expand yes -fill y scrollbar $w.frame.yscroll -relief sunken -command "$w.frame.list yview" scrollbar $w.frame.xscroll -relief sunken -orient horizontal \ -command "$w.frame.list xview" listbox $w.frame.list -width 20 -height 10 -yscroll "$w.frame.yscroll set" \ -xscroll "$w.frame.xscroll set" -relief sunken -setgrid 1 pack $w.frame.yscroll -side right -fill y pack $w.frame.xscroll -side bottom -fill x pack $w.frame.list -expand yes -fill y $w.frame.list insert 0 "Waste not, want not" "Early to bed and early to rise makes a man healthy, wealthy, and wise" "Ask not what your country can do for you, ask what you can do for your country" "I shall return" "NOT" "A picture is worth a thousand words" "User interfaces are hard to build" "Thou shalt not steal" "A penny for your thoughts" "Fool me once, shame on you; fool me twice, shame on me" "Every cloud has a silver lining" "Where there's smoke there's fire" "It takes one to know one" "Curiosity killed the cat" "Take this job and shove it" "Up a creek without a paddle" "I'm mad as hell and I'm not going to take it any more" "An apple a day keeps the doctor away" "Don't look a gift horse in the mouth" } gcl/gcl-tk/demos/mkPlot.lisp000077500000000000000000000055511242227143400162640ustar00rootroot00000000000000(in-package "TK") ;;# mkPlot w ;; ;; Create a top-level window containing a canvas displaying a simple ;; graph with data points that can be moved interactively. ;; ;; Arguments: ;; w - Name to use for new top-level window. (defun mkPlot ( &optional (w '.plot ) &aux c font x y item) (toplevel w ) (dpos w) (wm :title w "Plot Demonstration " : w) (wm :iconname w "Plot") (setq c (conc w '.c)) (message (conc w '.msg) :font :Adobe-Times-Medium-R-Normal-*-180-* :width 400 :bd 2 :relief "raised" :text "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1.") (canvas c :relief "raised" :width 450 :height 300) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.c) :side "top" :fill "x") (pack (conc w '.ok) :side "bottom" :pady 5) (setq font :Adobe-helvetica-medium-r-*-180-*) (funcall c :create "line" 100 250 400 250 :width 2) (funcall c :create "line" 100 250 100 50 :width 2) (funcall c :create "text" 225 20 :text "A Simple Plot" :font font :fill "brown") (sloop for i to 10 do (setq x (+ 100 (* i 30))) (funcall c :create "line" x 250 x 245 :width 2) (funcall c :create "text" x 254 :text (* 10 i) :anchor "n" :font font)) (sloop for i to 5 do (setq y (- 250 (* i 40))) (funcall c :create "line" 100 y 105 y :width 2) (funcall c :create "text" 96 y :text (* i 50) : ".0" :anchor "e" :font font)) (sloop for point in '((12 56) (20 94) (33 98) (32 120) (61 180) (75 160) (98 223)) do (setq x (+ 100 (* 3 (nth 0 point)))) (setq y (- 250 (truncate (* 4 (nth 1 point)) 5))) (setq item (funcall c :create "oval" (- x 6) (- y 6) (+ x 6) (+ y 6) :width 1 :outline "black" :fill "SkyBlue2" :return 'string )) (funcall c :addtag "point" "withtag" item) ) (funcall c :bind "point" "" c : " itemconfig current -fill red") (funcall c :bind "point" "" c : " itemconfig current -fill SkyBlue2") (funcall c :bind "point" "<1>" `(plotdown ',c |%x| |%y|)) (funcall c :bind "point" "" c : " dtag selected") (bind c "" `(plotmove ',c |%x| |%y|)) ) (defvar plotlastX 0) (defvar plotlastY 0) (defun plotDown (w x y) (funcall w :dtag "selected") (funcall w :addtag "selected" "withtag" "current") (funcall w :raise "current") (setq plotlastY y) (setq plotlastX x) ) (defun plotMove (w x y &aux ) (let ((oldx plotlastX) (oldy plotlastY)) ;; Note plotmove may be called recursively... since ;; the funcall may call something which calls this. ;; so we must set the global plotlastx before the funcall.. (setq plotlastx x) (setq plotlastY y) (funcall w :move "selected" (- x oldx) (- y oldy)) ) ) gcl/gcl-tk/demos/mkPlot.tcl000077500000000000000000000044551242227143400161010ustar00rootroot00000000000000# mkPlot w # # Create a top-level window containing a canvas displaying a simple # graph with data points that can be moved interactively. # # Arguments: # w - Name to use for new top-level window. proc mkPlot {{w .plot}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Plot Demonstration" wm iconname $w "Plot" set c $w.c message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 400 \ -bd 2 -relief raised -text "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1." canvas $c -relief raised -width 450 -height 300 button $w.ok -text "OK" -command "destroy $w" pack $w.msg $w.c -side top -fill x pack $w.ok -side bottom -pady 5 set font -Adobe-helvetica-medium-r-*-180-* $c create line 100 250 400 250 -width 2 $c create line 100 250 100 50 -width 2 $c create text 225 20 -text "A Simple Plot" -font $font -fill brown for {set i 0} {$i <= 10} {incr i} { set x [expr {100 + ($i*30)}] $c create line $x 250 $x 245 -width 2 $c create text $x 254 -text [expr 10*$i] -anchor n -font $font } for {set i 0} {$i <= 5} {incr i} { set y [expr {250 - ($i*40)}] $c create line 100 $y 105 $y -width 2 $c create text 96 $y -text [expr $i*50].0 -anchor e -font $font } foreach point {{12 56} {20 94} {33 98} {32 120} {61 180} {75 160} {98 223}} { set x [expr {100 + (3*[lindex $point 0])}] set y [expr {250 - (4*[lindex $point 1])/5}] set item [$c create oval [expr $x-6] [expr $y-6] \ [expr $x+6] [expr $y+6] -width 1 -outline black \ -fill SkyBlue2] $c addtag point withtag $item } $c bind point "$c itemconfig current -fill red" $c bind point "$c itemconfig current -fill SkyBlue2" $c bind point <1> "plotDown $c %x %y" $c bind point "$c dtag selected" bind $c "plotMove $c %x %y" } set plot(lastX) 0 set plot(lastY) 0 proc plotDown {w x y} { global plot $w dtag selected $w addtag selected withtag current $w raise current set plot(lastX) $x set plot(lastY) $y } proc plotMove {w x y} { global plot $w move selected [expr $x-$plot(lastX)] [expr $y-$plot(lastY)] set plot(lastX) $x set plot(lastY) $y } gcl/gcl-tk/demos/mkPuzzle.tcl000077500000000000000000000040341242227143400164450ustar00rootroot00000000000000# mkPuzzle w # # Create a top-level window containing a 15-puzzle game. # # Arguments: # w - Name to use for new top-level window. proc mkPuzzle {{w .p1}} { global xpos ypos catch {destroy $w} toplevel $w dpos $w wm title $w "15-Puzzle Demonstration" wm iconname $w "15-Puzzle" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "A 15-puzzle appears below as a collection of buttons. Click on any of the pieces next to the space, and that piece will slide over the space. Continue this until the pieces are arranged in numerical order from upper-left to lower-right. Click the \"OK\" button when you've finished playing." frame $w.frame -width 120 -height 120 -borderwidth 2 -relief sunken \ -bg Bisque3 button $w.ok -text OK -command "destroy $w" pack $w.msg -side top pack $w.frame -side top -padx 5 -pady 5 pack $w.ok -side bottom -fill x set order {3 1 6 2 5 7 15 13 4 11 8 9 14 10 12} for {set i 0} {$i < 15} {set i [expr $i+1]} { set num [lindex $order $i] set xpos($num) [expr ($i%4)*.25] set ypos($num) [expr ($i/4)*.25] button $w.frame.$num -relief raised -text $num \ -command "puzzle.switch $w $num" place $w.frame.$num -relx $xpos($num) -rely $ypos($num) \ -relwidth .25 -relheight .25 } set xpos(space) .75 set ypos(space) .75 } # Procedure invoked by buttons in the puzzle to resize the puzzle entries: proc puzzle.switch {w num} { global xpos ypos if {(($ypos($num) >= ($ypos(space) - .01)) && ($ypos($num) <= ($ypos(space) + .01)) && ($xpos($num) >= ($xpos(space) - .26)) && ($xpos($num) <= ($xpos(space) + .26))) || (($xpos($num) >= ($xpos(space) - .01)) && ($xpos($num) <= ($xpos(space) + .01)) && ($ypos($num) >= ($ypos(space) - .26)) && ($ypos($num) <= ($ypos(space) + .26)))} { set tmp $xpos(space) set xpos(space) $xpos($num) set xpos($num) $tmp set tmp $ypos(space) set ypos(space) $ypos($num) set ypos($num) $tmp place $w.frame.$num -relx $xpos($num) -rely $ypos($num) } } gcl/gcl-tk/demos/mkRadio.lisp000077500000000000000000000057731242227143400164120ustar00rootroot00000000000000(in-package "TK") ;;# mkRadio w ;; ;; Create a top-level window that displays a bunch of radio buttons. ;; ;; Arguments: ;; w - Name to use for new top-level window. (defun mkRadio (&optional (w '.r1)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Radiobutton Demonstration") (wm :iconname w "Radiobuttons") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 :text "Two groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. Click the \"See Variables\" button to see the current values of the variables. Click the \"OK\" button when you've seen enough.") (frame (conc w '.frame) :borderwidth 10) (frame (conc w '.frame2)) (pack (conc w '.msg) :side "top") (pack (conc w '.msg) :side "top") (pack (conc w '.frame) :side "top" :fill "x" :pady 10) (pack (conc w '.frame2) :side "bottom" :fill "x") (frame (conc w '.frame.left)) (frame (conc w '.frame.right)) (pack (conc w '.frame.left) (conc w '.frame.right) :side "left" :expand "yes") (radiobutton (conc w '.frame.left.b1) :text "Point Size 10" :variable 'size :relief "flat" :value 10) (radiobutton (conc w '.frame.left.b2) :text "Point Size 12" :variable 'size :relief "flat" :value 12) (radiobutton (conc w '.frame.left.b3) :text "Point Size 18" :variable 'size :relief "flat" :value 18) (radiobutton (conc w '.frame.left.b4) :text "Point Size 24" :variable 'size :relief "flat" :value 24) (pack (conc w '.frame.left.b1) (conc w '.frame.left.b2) (conc w '.frame.left.b3) (conc w '.frame.left.b4) :side "top" :pady 2 :anchor "w") (radiobutton (conc w '.frame.right.b1) :text "Red" :variable 'color :relief "flat" :value "red") (radiobutton (conc w '.frame.right.b2) :text "Green" :variable 'color :relief "flat" :value "green") (radiobutton (conc w '.frame.right.b3) :text "Blue" :variable 'color :relief "flat" :value "blue") (radiobutton (conc w '.frame.right.b4) :text "Yellow" :variable 'color :relief "flat" :value "yellow") (radiobutton (conc w '.frame.right.b5) :text "Orange" :variable 'color :relief "flat" :value "orange") (radiobutton (conc w '.frame.right.b6) :text "Purple" :variable 'color :relief "flat" :value "purple") (pack (conc w '.frame.right.b1) (conc w '.frame.right.b2) (conc w '.frame.right.b3) (conc w '.frame.right.b4) (conc w '.frame.right.b5) (conc w '.frame.right.b6) :side "top" :pady 2 :anchor "w") (button (conc w '.frame2.ok) :text "OK" :command (tk-conc "destroy " w) :width 12) (button (conc w '.frame2.vars) :text "See Variables" :width 12 :command `(showvars (conc ',w '.dialog) '(size color))) (pack (conc w '.frame2.ok) (conc w '.frame2.vars) :side "left" :expand "yes" :fill "x") ) gcl/gcl-tk/demos/mkRadio.tcl000077500000000000000000000050201242227143400162060ustar00rootroot00000000000000# mkRadio w # # Create a top-level window that displays a bunch of radio buttons. # # Arguments: # w - Name to use for new top-level window. proc mkRadio {{w .r1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Radiobutton Demonstration" wm iconname $w "Radiobuttons" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "Two groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. Click the \"See Variables\" button to see the current values of the variables. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 frame $w.frame2 pack $w.msg -side top pack $w.msg -side top pack $w.frame -side top -fill x -pady 10 pack $w.frame2 -side bottom -fill x frame $w.frame.left frame $w.frame.right pack $w.frame.left $w.frame.right -side left -expand yes radiobutton $w.frame.left.b1 -text "Point Size 10" -variable size \ -relief flat -value 10 radiobutton $w.frame.left.b2 -text "Point Size 12" -variable size \ -relief flat -value 12 radiobutton $w.frame.left.b3 -text "Point Size 18" -variable size \ -relief flat -value 18 radiobutton $w.frame.left.b4 -text "Point Size 24" -variable size \ -relief flat -value 24 pack $w.frame.left.b1 $w.frame.left.b2 $w.frame.left.b3 $w.frame.left.b4 \ -side top -pady 2 -anchor w radiobutton $w.frame.right.b1 -text "Red" -variable color \ -relief flat -value red radiobutton $w.frame.right.b2 -text "Green" -variable color \ -relief flat -value green radiobutton $w.frame.right.b3 -text "Blue" -variable color \ -relief flat -value blue radiobutton $w.frame.right.b4 -text "Yellow" -variable color \ -relief flat -value yellow radiobutton $w.frame.right.b5 -text "Orange" -variable color \ -relief flat -value orange radiobutton $w.frame.right.b6 -text "Purple" -variable color \ -relief flat -value purple pack $w.frame.right.b1 $w.frame.right.b2 $w.frame.right.b3 \ $w.frame.right.b4 $w.frame.right.b5 $w.frame.right.b6 \ -side top -pady 2 -anchor w button $w.frame2.ok -text OK -command "destroy $w" -width 12 button $w.frame2.vars -text "See Variables" -width 12\ -command "showVars $w.dialog size color" pack $w.frame2.ok $w.frame2.vars -side left -expand yes -fill x } gcl/gcl-tk/demos/mkRuler.lisp000077500000000000000000000121461242227143400164350ustar00rootroot00000000000000;;# mkRuler w ;; ;; Create a canvas demonstration consisting of a ruler. ;; ;; Arguments: ;; w - Name to use for new top-level window. ;; This file implements a canvas widget that displays a ruler with tab stops ;; that can be set individually. The only procedure that should be invoked ;; from outside the file is the first one, which creates the canvas. (in-package "TK") (defun mkRuler (&optional (w '.ruler)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Ruler Demonstration") (wm :iconname w "Ruler") (setq c (conc w '.c)) (message (conc w '.msg) :font :Adobe-Times-Medium-R-Normal-*-180-* :width "13c" :relief "raised" :bd 2 :text "This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. (if :you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button.") (canvas c :width "14.8c" :height "2.5c" :relief "raised") (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.c) :side "top" :fill "x") (pack (conc w '.ok) :side "bottom" :pady 5) (setf *v* (gensym)) (setf (get *v* 'grid) '.25c) (setf (get *v* 'left) (winfo :fpixels c "1c" :return t)) (setf (get *v* 'right) (winfo :fpixels c "13c" :return t)) (setf (get *v* 'top) (winfo :fpixels c "1c" :return t)) (setf (get *v* 'bottom) (winfo :fpixels c "1.5c" :return t)) (setf (get *v* 'size) (winfo :fpixels c '.2c :return t)) (setf (get *v* 'normalStyle) '(:fill "black")) (if (> (read-from-string (winfo :depth c)) 1) (progn (setf (get *v* 'activeStyle) '(:fill "red" :stipple "")) (setf (get *v* 'deleteStyle) `(:stipple "@" : ,*tk-library* :"/demos/bitmaps/grey.25" :fill "red")) );;else (progn (setf (get *v* 'activeStyle) '(:fill "black" :stipple "" )) (setf (get *v* 'deleteStyle) `(:stipple "@" : ,*tk-library* : "/demos/bitmaps/grey.25" :fill "black")) )) (funcall c :create "line" "1c" "0.5c" "1c" "1c" "13c" "1c" "13c" "0.5c" :width 1) (dotimes (i 12) (let (( x (+ i 1))) (funcall c :create "line" x :"c" "1c" x :"c" "0.6c" :width 1) (funcall c :create "line" x :".25c" "1c" x :".25c" "0.8c" :width 1) (funcall c :create "line" x :".5c" "1c" x :".5c" "0.7c" :width 1) (funcall c :create "line" x :".75c" "1c" x :".75c" "0.8c" :width 1) (funcall c :create "text" x :".15c" '.75c :text i :anchor "sw") )) (funcall c :addtag "well" "withtag" (funcall c :create "rect" "13.2c" "1c" "13.8c" "0.5c" :outline "black" :fill (nth 4 (funcall c :config :background :return 'list-strings)))) (funcall c :addtag "well" "withtag" (rulerMkTab c (winfo :pixels c "13.5c" :return t) (winfo :pixels c '.65c :return t))) (funcall c :bind "well" "<1>" `(rulerNewTab ',c |%x| |%y|)) (funcall c :bind "tab" "<1>" `(demo_selectTab ',c |%x| |%y|)) (bind c "" `(rulerMoveTab ',c |%x| |%y|)) (bind c "" `(rulerReleaseTab ',c)) ) (defun rulerMkTab (c x y) (funcall c :create "polygon" x y (+ x (get *v* 'size)) (+ y (get *v* 'size)) (- x (get *v* 'size)) (+ y (get *v* 'size)) :return 'string ) ) (defun rulerNewTab (c x y) (funcall c :addtag "active" "withtag" (rulerMkTab c x y)) (funcall c :addtag "tab" "withtag" "active") (setf (get *v* 'x) x) (setf (get *v* 'y) y) (rulerMoveTab c x y) ) (defvar *recursive* nil) ;; prevent recursive calls (defun rulerMoveTab (c x y &aux cx cy (*recursive* *recursive*) ) (cond (*recursive* (return-from rulerMoveTab)) (t (setq *recursive* t))) (if (equal (funcall c :find "withtag" "active" :return 'string) "") (return-from rulerMoveTab nil)) (setq cx (funcall c :canvasx x (get *v* 'grid) :return t)) (setq cy (funcall c :canvasy y :return t)) (if (< cx (get *v* 'left))(setq cx (get *v* 'left))) (if (> cx (get *v* 'right))(setq cx (get *v* 'right))) (if (and (>= cy (get *v* 'top)) (<= cy (get *v* 'bottom))) (progn (setq cy (+ 2 (get *v* 'top))) (apply c :itemconf "active" (get *v* 'activestyle))) (progn (setq cy (- cy (get *v* 'size) 2)) (apply c :itemconf "active"(get *v* 'deletestyle))) ) (funcall c :move "active" (- cx (get *v* 'x)) (- cy (get *v* 'y)) ) (setf (get *v* 'x) cx) (setf (get *v* 'y) cy) ) (defun demo_selectTab (c x y) (setf (get *v* 'x) (funcall c :canvasx x (get *v* 'grid) :return t)) (setf (get *v* 'y) (+ 2 (get *v* 'top))) (funcall c :addtag "active" "withtag" "current") (apply c :itemconf "active" (get *v* 'activeStyle)) (funcall c :raise "active") ) (defun rulerReleaseTab (c ) (if (equal (funcall c :find "withtag" "active" :return 'string) "") (return-from rulerReleaseTab nil)) (if (not (eql (get *v* 'y) (+ 2 (get *v* 'top)))) (funcall c :delete "active") (progn (apply c :itemconf "active" (get *v* 'normalStyle)) (funcall c :dtag "active") ) )) gcl/gcl-tk/demos/mkRuler.tcl000077500000000000000000000074761242227143400162620ustar00rootroot00000000000000# mkRuler w # # Create a canvas demonstration consisting of a ruler. # # Arguments: # w - Name to use for new top-level window. # This file implements a canvas widget that displays a ruler with tab stops # that can be set individually. The only procedure that should be invoked # from outside the file is the first one, which creates the canvas. proc mkRuler {{w .ruler}} { global tk_library upvar #0 demo_rulerInfo v catch {destroy $w} toplevel $w dpos $w wm title $w "Ruler Demonstration" wm iconname $w "Ruler" set c $w.c message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 13c \ -relief raised -bd 2 -text "This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button." canvas $c -width 14.8c -height 2.5c -relief raised button $w.ok -text "OK" -command "destroy $w" pack $w.msg $w.c -side top -fill x pack $w.ok -side bottom -pady 5 set v(grid) .25c set v(left) [winfo fpixels $c 1c] set v(right) [winfo fpixels $c 13c] set v(top) [winfo fpixels $c 1c] set v(bottom) [winfo fpixels $c 1.5c] set v(size) [winfo fpixels $c .2c] set v(normalStyle) "-fill black" if {[winfo depth $c] > 1} { set v(activeStyle) "-fill red -stipple {}" set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \ -fill red" } else { set v(activeStyle) "-fill black -stipple {}" set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \ -fill black" } $c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1 for {set i 0} {$i < 12} {incr i} { set x [expr $i+1] $c create line ${x}c 1c ${x}c 0.6c -width 1 $c create line $x.25c 1c $x.25c 0.8c -width 1 $c create line $x.5c 1c $x.5c 0.7c -width 1 $c create line $x.75c 1c $x.75c 0.8c -width 1 $c create text $x.15c .75c -text $i -anchor sw } $c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \ -outline black -fill [lindex [$c config -bg] 4]] $c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \ [winfo pixels $c .65c]] $c bind well <1> "rulerNewTab $c %x %y" $c bind tab <1> "demo_selectTab $c %x %y" bind $c "rulerMoveTab $c %x %y" bind $c "rulerReleaseTab $c" } proc rulerMkTab {c x y} { upvar #0 demo_rulerInfo v $c create polygon $x $y [expr $x+$v(size)] [expr $y+$v(size)] \ [expr $x-$v(size)] [expr $y+$v(size)] } proc rulerNewTab {c x y} { upvar #0 demo_rulerInfo v $c addtag active withtag [rulerMkTab $c $x $y] $c addtag tab withtag active set v(x) $x set v(y) $y rulerMoveTab $c $x $y } proc rulerMoveTab {c x y} { upvar #0 demo_rulerInfo v if {[$c find withtag active] == ""} { return } set cx [$c canvasx $x $v(grid)] set cy [$c canvasy $y] if {$cx < $v(left)} { set cx $v(left) } if {$cx > $v(right)} { set cx $v(right) } if {($cy >= $v(top)) && ($cy <= $v(bottom))} { set cy [expr $v(top)+2] eval "$c itemconf active $v(activeStyle)" } else { set cy [expr $cy-$v(size)-2] eval "$c itemconf active $v(deleteStyle)" } $c move active [expr $cx-$v(x)] [expr $cy-$v(y)] set v(x) $cx set v(y) $cy } proc demo_selectTab {c x y} { upvar #0 demo_rulerInfo v set v(x) [$c canvasx $x $v(grid)] set v(y) [expr $v(top)+2] $c addtag active withtag current eval "$c itemconf active $v(activeStyle)" $c raise active } proc rulerReleaseTab c { upvar #0 demo_rulerInfo v if {[$c find withtag active] == {}} { return } if {$v(y) != [expr $v(top)+2]} { $c delete active } else { eval "$c itemconf active $v(normalStyle)" $c dtag active } } gcl/gcl-tk/demos/mkScroll.tcl000077500000000000000000000054351242227143400164200ustar00rootroot00000000000000# mkScroll w # # Create a top-level window containing a simple canvas that can # be scrolled in two dimensions. # # Arguments: # w - Name to use for new top-level window. proc mkScroll {{w .cscroll}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Scrollable Canvas Demonstration" wm iconname $w "Canvas" wm minsize $w 100 100 set c $w.frame.c message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \ -relief raised -bd 2 -text "This window displays a canvas widget that can be scrolled either using the scrollbars or by dragging with button 2 in the canvas. If you click button 1 on one of the rectangles, its indices will be printed on stdout." frame $w.frame -relief raised -bd 2 button $w.ok -text "OK" -command "destroy $w" pack $w.msg -side top -fill x pack $w.ok -side bottom -pady 5 pack $w.frame -side top -expand yes -fill both canvas $c -scrollregion {-10c -10c 50c 20c} \ -xscrollcommand "$w.frame.hscroll set" -yscrollcommand "$w.frame.vscroll set" scrollbar $w.frame.vscroll -relief sunken -command "$c yview" scrollbar $w.frame.hscroll -orient horiz -relief sunken -command "$c xview" pack $w.frame.vscroll -side right -fill y pack $w.frame.hscroll -side bottom -fill x pack $c -expand yes -fill both set bg [lindex [$c config -bg] 4] for {set i 0} {$i < 20} {incr i} { set x [expr {-10 + 3*$i}] for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ -outline black -fill $bg -tags rect $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ -anchor center -tags text } } $c bind all "scrollEnter $c" $c bind all "scrollLeave $c" $c bind all <1> "scrollButton $c" bind $c <2> "$c scan mark %x %y" bind $c "$c scan dragto %x %y" } proc scrollEnter canvas { global oldFill set id [$canvas find withtag current] if {[lsearch [$canvas gettags current] text] >= 0} { set id [expr $id-1] } set oldFill [lindex [$canvas itemconfig $id -fill] 4] if {[winfo depth $canvas] > 1} { $canvas itemconfigure $id -fill SeaGreen1 } else { $canvas itemconfigure $id -fill black $canvas itemconfigure [expr $id+1] -fill white } } proc scrollLeave canvas { global oldFill set id [$canvas find withtag current] if {[lsearch [$canvas gettags current] text] >= 0} { set id [expr $id-1] } $canvas itemconfigure $id -fill $oldFill $canvas itemconfigure [expr $id+1] -fill black } proc scrollButton canvas { global oldFill set id [$canvas find withtag current] if {[lsearch [$canvas gettags current] text] < 0} { set id [expr $id+1] } puts stdout "You buttoned at [lindex [$canvas itemconf $id -text] 4]" } gcl/gcl-tk/demos/mkSearch.lisp000077500000000000000000000116131242227143400165470ustar00rootroot00000000000000;;# mkTextSearch w (in-package "TK") ;; ;; Create a top-level window containing a text widget that allows you ;; to load a file and highlight all instances of a given string. ;; ;; Arguments: ;; w - Name to use for new top-level window. (defun mkTextSearch (&optional (w '.search) &aux (textwin (conc w '.t))) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Text Demonstration - Search and Highlight") (wm :iconname w "Text Search") (frame (conc w '.file)) (label (conc w '.file.label) :text "File name:" :width 13 :anchor "w") (entry (conc w '.file.entry) :width 40 :relief "sunken" :bd 2 :textvariable 'fileName) (button (conc w '.file.button) :text "Load File" :command `(TextLoadFile ',textwin fileName)) (pack (conc w '.file.label) (conc w '.file.entry) :side "left") (pack (conc w '.file.button) :side "left" :pady 5 :padx 10) (bind (conc w '.file.entry) "" `(progn (TextLoadFile ',textwin fileName) (focus (conc ',w '.string.entry)))) (frame (conc w '.string)) (label (conc w '.string.label) :text "Search string:" :width 13 :anchor "w") (entry (conc w '.string.entry) :width 40 :relief "sunken" :bd 2 :textvariable 'searchString) (button (conc w '.string.button) :text "Highlight" :command `(TextSearch ',textwin searchString "search")) (pack (conc w '.string.label) (conc w '.string.entry) :side "left") (pack (conc w '.string.button) :side "left" :pady 5 :padx 10) (bind (conc w '.string.entry) "" `(TextSearch ',textwin searchString "search")) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (text textwin :relief "raised" :bd 2 :yscrollcommand (tk-conc w ".s set") :setgrid "true") (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) (pack (conc w '.file) (conc w '.string) :side "top" :fill "x") (pack (conc w '.ok) :side "bottom" :fill "x") (pack (conc w '.s) :side "right" :fill "y") (pack textwin :expand "yes" :fill "both") ;; Set up display styles for text highlighting. (let* (com (bg (if (> (read-from-string (winfo :depth w)) 1) "SeaGreen4" "black")) on (fun #'(lambda () (when (myerrorset (progn (funcall textwin :tag :configure "search" :background (if on bg "") :foreground (if on "white" "")) t)) (setq on (not on)) (myerrorset (after 500 com)) )))) (setq com (tcl-create-command fun nil nil)) (setq bil fun) (funcall fun )) (funcall textwin :insert 0.0 " This window demonstrates how to use the tagging facilities in text widgets to implement a searching mechanism. First, type a file name in the top entry, then type or click on \"Load File\". Then type a string in the lower entry and type or click on \"Load File\". This will cause all of the instances of the string to be tagged with the tag \"search\", and it will arrange for the tag's display attributes to change to make all of the strings blink. " ) (funcall textwin :mark :set 'insert 0.0) (bind w "" (tk-conc "focus " w ".file.entry")) ) (setq fileName "") (setq searchString "") ;; The utility procedure below loads a file into a text widget, ;; discarding the previous contents of the widget. Tags for the ;; old widget are not affected, however. ;; Arguments: ;; ;; w - The window into which to load the file. Must be a ;; text widget. ;; file - The name of the file to load. Must be readable. (defun TextLoadFile (w file) (with-open-file (st file) (let ((ar (make-array 3000 :element-type 'string-char :fill-pointer 0)) (n (file-length st)) m) (funcall w :delete "1.0" 'end) (while (> n 0) (setq m (min (array-total-size ar) n)) (setq n (- n m)) (si::fread ar 0 m st) (setf (fill-pointer ar) m) (funcall w :insert 'end ar))))) ;; The utility procedure below searches for all instances of a ;; given string in a text widget and applies a given tag to each ;; instance found. ;; Arguments: ;; ;; w - The window in which to search. Must be a text widget. ;; string - The string to search for. The search is done using ;; exact matching only; no special characters. ;; tag - Tag to apply to each instance of a matching string. (defun TextSearch (w string tag) (funcall w :tag :remove 'search 0.0 'end) (let ((mark "mine") (m (length string))) (funcall w :mark :set "mine" "0.0") (while (funcall w :compare mark '< 'end :return 'boolean) (let ((s (funcall w :get mark mark : " + 3000 chars" :return 'string)) (n 0) tem) (while (setq tem (search string s :start2 n)) (funcall w :tag :add 'search mark : " + " : tem : " chars" mark : " + " : (setq n (+ tem m)) : " chars")) (funcall w :mark :set mark mark : " + " : (- 3000 m) : " chars"))))) gcl/gcl-tk/demos/mkSearch.tcl000077500000000000000000000112041242227143400163560ustar00rootroot00000000000000# mkTextSearch w # # Create a top-level window containing a text widget that allows you # to load a file and highlight all instances of a given string. # # Arguments: # w - Name to use for new top-level window. proc mkTextSearch {{w .search}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Text Demonstration - Search and Highlight" wm iconname $w "Text Search" frame $w.file label $w.file.label -text "File name:" -width 13 -anchor w entry $w.file.entry -width 40 -relief sunken -bd 2 -textvariable fileName button $w.file.button -text "Load File" \ -command "TextLoadFile $w.t \$fileName" pack $w.file.label $w.file.entry -side left pack $w.file.button -side left -pady 5 -padx 10 bind $w.file.entry " TextLoadFile $w.t \$fileName focus $w.string.entry " frame $w.string label $w.string.label -text "Search string:" -width 13 -anchor w entry $w.string.entry -width 40 -relief sunken -bd 2 \ -textvariable searchString button $w.string.button -text "Highlight" \ -command "TextSearch $w.t \$searchString search" pack $w.string.label $w.string.entry -side left pack $w.string.button -side left -pady 5 -padx 10 bind $w.string.entry "TextSearch $w.t \$searchString search" button $w.ok -text OK -command "destroy $w" text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true scrollbar $w.s -relief flat -command "$w.t yview" pack $w.file $w.string -side top -fill x pack $w.ok -side bottom -fill x pack $w.s -side right -fill y pack $w.t -expand yes -fill both # Set up display styles for text highlighting. if {[winfo depth $w] > 1} { TextToggle "$w.t tag configure search -background \ SeaGreen4 -foreground white" 800 "$w.t tag configure \ search -background {} -foreground {}" 200 } else { TextToggle "$w.t tag configure search -background \ black -foreground white" 800 "$w.t tag configure \ search -background {} -foreground {}" 200 } $w.t insert 0.0 {\ This window demonstrates how to use the tagging facilities in text widgets to implement a searching mechanism. First, type a file name in the top entry, then type or click on "Load File". Then type a string in the lower entry and type or click on "Load File". This will cause all of the instances of the string to be tagged with the tag "search", and it will arrange for the tag's display attributes to change to make all of the strings blink. } $w.t mark set insert 0.0 bind $w "focus $w.file.entry" } set fileName "" set searchString "" # The utility procedure below loads a file into a text widget, # discarding the previous contents of the widget. Tags for the # old widget are not affected, however. # Arguments: # # w - The window into which to load the file. Must be a # text widget. # file - The name of the file to load. Must be readable. proc TextLoadFile {w file} { set f [open $file] $w delete 1.0 end while {![eof $f]} { $w insert end [read $f 10000] } close $f } # The utility procedure below searches for all instances of a # given string in a text widget and applies a given tag to each # instance found. # Arguments: # # w - The window in which to search. Must be a text widget. # string - The string to search for. The search is done using # exact matching only; no special characters. # tag - Tag to apply to each instance of a matching string. proc TextSearch {w string tag} { $w tag remove search 0.0 end scan [$w index end] %d numLines set l [string length $string] for {set i 1} {$i <= $numLines} {incr i} { if {[string first $string [$w get $i.0 $i.1000]] == -1} { continue } set line [$w get $i.0 $i.1000] set offset 0 while 1 { set index [string first $string $line] if {$index < 0} { break } incr offset $index $w tag add $tag $i.[expr $offset] $i.[expr $offset+$l] incr offset $l set line [string range $line [expr $index+$l] 1000] } } } # The procedure below is invoked repeatedly to invoke two commands # at periodic intervals. It normally reschedules itself after each # execution but if an error occurs (e.g. because the window was # deleted) then it doesn't reschedule itself. # Arguments: # # cmd1 - Command to execute when procedure is called. # sleep1 - Ms to sleep after executing cmd1 before executing cmd2. # cmd2 - Command to execute in the *next* invocation of this # procedure. # sleep2 - Ms to sleep after executing cmd2 before executing cmd1 again. proc TextToggle {cmd1 sleep1 cmd2 sleep2} { catch { eval $cmd1 after $sleep1 [list TextToggle $cmd2 $sleep2 $cmd1 $sleep1] } } gcl/gcl-tk/demos/mkStyles.lisp000077500000000000000000000121571242227143400166310ustar00rootroot00000000000000;;# mkStyles w ;; ;; Create a top-level window with a text widget that demonstrates the ;; various display styles that are available in texts. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defun mkStyles (&optional (w '.styles) &aux (textwin (conc w '.t)) ) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Text Demonstration - Display Styles") (wm :iconname w "Text Styles") (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) (text textwin :relief "raised" :bd 2 :yscrollcommand (tk-conc w ".s set") :setgrid "true" :width 70 :height 28) (pack (conc w '.ok) :side "bottom" :fill "x") (pack (conc w '.s) :side "right" :fill "y") (pack textwin :expand "yes" :fill "both") ;; Set up display styles (funcall textwin :tag :configure 'bold :font :Adobe-Courier-Bold-O-Normal-*-120-*) (funcall textwin :tag :configure 'big :font :Adobe-Courier-Bold-R-Normal-*-140-*) (funcall textwin :tag :configure 'verybig :font :Adobe-Helvetica-Bold-R-Normal-*-240-*) (if (> (read-from-string (winfo :depth w)) 1) (progn (funcall textwin :tag :configure 'color1 :background "#eed5b7") (funcall textwin :tag :configure 'color2 :foreground "red") (funcall textwin :tag :configure 'raised :background "#eed5b7" :relief "raised" :borderwidth 1) (funcall textwin :tag :configure 'sunken :background "#eed5b7" :relief "sunken" :borderwidth 1) ) ;;else (progn (funcall textwin :tag :configure 'color1 :background "black" :foreground "white") (funcall textwin :tag :configure 'color2 :background "black" :foreground "white") (funcall textwin :tag :configure 'raised :background "white" :relief "raised" :borderwidth 1) (funcall textwin :tag :configure 'sunken :background "white" :relief "sunken" :borderwidth 1) )) (funcall textwin :tag :configure 'bgstipple :background "black" :borderwidth 0 :bgstipple "gray25") (funcall textwin :tag :configure 'fgstipple :fgstipple "gray50") (funcall textwin :tag :configure 'underline :underline "on") (funcall textwin :insert 0.0 " Text widgets like this one allow you to display information in a variety of styles. Display styles are controlled using a mechanism called " ) (insertWithTags textwin "tags" 'bold) (insertWithTags textwin ". Tags are just textual names that you can apply to one or more ranges of characters within a text widget. You can configure tags with various display styles. (if :you do this, then the tagged characters will be displayed with the styles you chose. The available display styles are: " ) (insertWithTags textwin " 1. Font." 'big) (insertWithTags textwin " You can choose any X font, ") (insertWithTags textwin "large" "verybig") (insertWithTags textwin " or ") (insertWithTags textwin "small. ") (insertWithTags textwin " 2. Color." 'big) (insertWithTags textwin " You can change either the ") (insertWithTags textwin "background" "color1") (insertWithTags textwin " or ") (insertWithTags textwin "foreground" "color2") (insertWithTags textwin " color, or ") (insertWithTags textwin "both" "color1" "color2") (insertWithTags textwin ". ") (insertWithTags textwin " 3. Stippling." 'big) (insertWithTags textwin " You can cause either the ") (insertWithTags textwin "background" 'bgstipple) (insertWithTags textwin " or ") (insertWithTags textwin "foreground" 'fgstipple) (insertWithTags textwin " information to be drawn with a stipple fill instead of a solid fill. ") (insertWithTags textwin " 4. Underlining." 'big) (insertWithTags textwin " You can ") (insertWithTags textwin "underline" "underline") (insertWithTags textwin " ranges of text. ") (insertWithTags textwin " 5. 3-D effects." 'big) (insertWithTags textwin " You can arrange for the background to be drawn with a border that makes characters appear either ") (insertWithTags textwin "raised" "raised") (insertWithTags textwin " or ") (insertWithTags textwin "sunken" "sunken") (insertWithTags textwin ". ") (insertWithTags textwin " 6. Yet to come." 'big) (insertWithTags textwin " More display effects will be coming soon, such as the ability to change line justification and perhaps line spacing.") (funcall textwin :mark :set 'insert 0.0) (bind w "" (tk-conc "focus " w ".t")) ) ;; The procedure below inserts text into a given text widget and ;; applies one or more tags to that text. The arguments are: ;; ;; w Window in which to insert ;; text Text to insert (it's :inserted at the "insert" mark) ;; args One or more tags to apply to text. (if :this is empty ;; then all tags are removed from the text. (defun insertWithTags (w text &rest args) (let (( start (funcall w :index 'insert :return 'string))) (funcall w :insert 'insert text) (dolist (v (funcall w :tag :names start :return 'list-strings)) (funcall w :tag :remove v start 'insert)) (dolist (i args) (funcall w :tag :add i start 'insert)))) gcl/gcl-tk/demos/mkStyles.tcl000077500000000000000000000104031242227143400164340ustar00rootroot00000000000000# mkStyles w # # Create a top-level window with a text widget that demonstrates the # various display styles that are available in texts. # # Arguments: # w - Name to use for new top-level window. proc mkStyles {{w .styles}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Text Demonstration - Display Styles" wm iconname $w "Text Styles" button $w.ok -text OK -command "destroy $w" text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true \ -width 70 -height 28 scrollbar $w.s -relief flat -command "$w.t yview" pack $w.ok -side bottom -fill x pack $w.s -side right -fill y pack $w.t -expand yes -fill both # Set up display styles $w.t tag configure bold -font -Adobe-Courier-Bold-O-Normal-*-120-* $w.t tag configure big -font -Adobe-Courier-Bold-R-Normal-*-140-* $w.t tag configure verybig -font -Adobe-Helvetica-Bold-R-Normal-*-240-* if {[winfo depth $w] > 1} { $w.t tag configure color1 -background #eed5b7 $w.t tag configure color2 -foreground red $w.t tag configure raised -background #eed5b7 -relief raised \ -borderwidth 1 $w.t tag configure sunken -background #eed5b7 -relief sunken \ -borderwidth 1 } else { $w.t tag configure color1 -background black -foreground white $w.t tag configure color2 -background black -foreground white $w.t tag configure raised -background white -relief raised \ -borderwidth 1 $w.t tag configure sunken -background white -relief sunken \ -borderwidth 1 } $w.t tag configure bgstipple -background black -borderwidth 0 \ -bgstipple gray25 $w.t tag configure fgstipple -fgstipple gray50 $w.t tag configure underline -underline on $w.t insert 0.0 {\ Text widgets like this one allow you to display information in a variety of styles. Display styles are controlled using a mechanism called } insertWithTags $w.t tags bold insertWithTags $w.t {. Tags are just textual names that you can apply to one or more ranges of characters within a text widget. You can configure tags with various display styles. If you do this, then the tagged characters will be displayed with the styles you chose. The available display styles are: } insertWithTags $w.t { 1. Font.} big insertWithTags $w.t { You can choose any X font, } insertWithTags $w.t large verybig insertWithTags $w.t { or } insertWithTags $w.t {small. } insertWithTags $w.t { 2. Color.} big insertWithTags $w.t { You can change either the } insertWithTags $w.t background color1 insertWithTags $w.t { or } insertWithTags $w.t foreground color2 insertWithTags $w.t { color, or } insertWithTags $w.t both color1 color2 insertWithTags $w.t {. } insertWithTags $w.t { 3. Stippling.} big insertWithTags $w.t { You can cause either the } insertWithTags $w.t background bgstipple insertWithTags $w.t { or } insertWithTags $w.t foreground fgstipple insertWithTags $w.t { information to be drawn with a stipple fill instead of a solid fill. } insertWithTags $w.t { 4. Underlining.} big insertWithTags $w.t { You can } insertWithTags $w.t underline underline insertWithTags $w.t { ranges of text. } insertWithTags $w.t { 5. 3-D effects.} big insertWithTags $w.t { You can arrange for the background to be drawn with a border that makes characters appear either } insertWithTags $w.t raised raised insertWithTags $w.t { or } insertWithTags $w.t sunken sunken insertWithTags $w.t {. } insertWithTags $w.t { 6. Yet to come.} big insertWithTags $w.t { More display effects will be coming soon, such as the ability to change line justification and perhaps line spacing.} $w.t mark set insert 0.0 bind $w "focus $w.t" } # The procedure below inserts text into a given text widget and # applies one or more tags to that text. The arguments are: # # w Window in which to insert # text Text to insert (it's inserted at the "insert" mark) # args One or more tags to apply to text. If this is empty # then all tags are removed from the text. proc insertWithTags {w text args} { set start [$w index insert] $w insert insert $text foreach tag [$w tag names $start] { $w tag remove $tag $start insert } foreach i $args { $w tag add $i $start insert } } gcl/gcl-tk/demos/mkTear.tcl000077500000000000000000000014501242227143400160460ustar00rootroot00000000000000# mkTear w # # Create a top-level window that displays a help message on tear-off # menus. # # Arguments: # w - Name to use for new top-level window. proc mkTear {{w .t1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Information On Tear-Off Menus" wm iconname $w "Info" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 250 \ -text "To tear off a menu, press mouse button 2 over the menubutton for the menu, then drag the menu with button 2 held down. You can reposition a torn-off menu by pressing button 2 on it and dragging again. To unpost the menu, click mouse button 1 over the menu's menubutton. Click the \"OK\" button when you're finished with this window." button $w.ok -text OK -command "destroy $w" pack $w.msg $w.ok -pady 5 } gcl/gcl-tk/demos/mkTextBind.lisp000077500000000000000000000100501242227143400170550ustar00rootroot00000000000000;;# mkTextBind w ;; ;; Create a top-level window that illustrates how you can bind ;; Tcl commands to regions of text in a text widget. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defun mkTextBind (&optional (w '.bindings) &aux bold normal (textwin (conc w '.t ) )) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Text Demonstration - Tag Bindings") (wm :iconname w "Text Bindings") (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) (text textwin :relief "raised" :bd 2 :yscrollcommand (tk-conc w ".s set") :setgrid "true" :width 60 :height 28 :font "-Adobe-Helvetica-Bold-R-Normal-*-120-*") (pack (conc w '.ok) :side "bottom" :fill "x") (pack (conc w '.s) :side "right" :fill "y") (pack textwin :expand "yes" :fill "both") ;; Set up display styles (if (> (read-from-string (winfo :depth w)) 1) (progn (setq bold '(:foreground "red")) (setq normal '(:foreground "")) );;else (progn (setq bold '(:foreground "white" :background "black")) (setq normal '(:foreground "" :background "")) )) (funcall textwin :insert 0.0 "The same tag mechanism that controls display styles in text widgets can also be used to associate Tcl commands with regions of text, so that mouse or keyboard actions on the text cause particular Tcl commands to be invoked. For example, in the text below the descriptions of the canvas demonstrations have been tagged. When you move the mouse over a demo description the description lights up, and when you press button 3 over a description then that particular demonstration is invoked. This demo package contains a number of demonstrations of Tk's canvas widgets. Here are brief descriptions of some of the demonstrations that are available: " ) (let ((blank-lines (format nil "~2%"))) (insertWithTags textwin "1. Samples of all the different types of items that can be created in canvas widgets." "d1") (insertWithTags textwin blank-lines) (insertWithTags textwin "2. A simple two-dimensional plot that allows you to adjust the :positions of the data points." "d2") (insertWithTags textwin blank-lines) (insertWithTags textwin "3. Anchoring and justification modes for text items." "d3") (insertWithTags textwin blank-lines) (insertWithTags textwin "4. An editor for arrow-head shapes for line items." "d4") (insertWithTags textwin blank-lines) (insertWithTags textwin "5. A ruler with facilities for editing tab stops." "d5") (insertWithTags textwin blank-lines) (insertWithTags textwin "6. A grid that demonstrates how canvases can be scrolled." "d6")) (dolist (tag '("d1" "d2" "d3" "d4" "d5" "d6")) (funcall textwin :tag :bind tag "" `(,textwin :tag :configure ,tag ,@bold)) (funcall textwin :tag :bind tag "" `(,textwin :tag :configure ,tag ,@normal)) ) (funcall textwin :tag :bind "d1" "<3>" 'mkItems) (funcall textwin :tag :bind "d2" "<3>" 'mkPlot) (funcall textwin :tag :bind "d3" "<3>" "mkCanvText") (funcall textwin :tag :bind "d4" "<3>" "mkArrow") (funcall textwin :tag :bind "d5" "<3>" 'mkRuler) (funcall textwin :tag :bind "d6" "<3>" "mkScroll") (funcall textwin :mark 'set 'insert 0.0) (bind w "" (tk-conc "focus " w ".t")) ) ;; The procedure below inserts text into a given text widget and ;; applies one or more tags to that text. The arguments are: ;; ;; w Window in which to insert ;; text Text to insert (it's :inserted at the "insert" mark) ;; args One or more tags to apply to text. (if :this is empty ;; then all tags are removed from the text. (defun insertWithTags (w text &rest args) (let (( start (funcall w :index 'insert :return 'string))) (funcall w :insert 'insert text) (dolist (v (funcall w :tag "names" start :return 'list-strings)) (funcall w :tag 'remove v start "insert")) (dolist (i args) (funcall w :tag 'add i start 'insert)))) gcl/gcl-tk/demos/mkTextBind.tcl000077500000000000000000000064431242227143400167030ustar00rootroot00000000000000# mkTextBind w # # Create a top-level window that illustrates how you can bind # Tcl commands to regions of text in a text widget. # # Arguments: # w - Name to use for new top-level window. proc mkTextBind {{w .bindings}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Text Demonstration - Tag Bindings" wm iconname $w "Text Bindings" button $w.ok -text OK -command "destroy $w" text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true \ -width 60 -height 28 \ -font "-Adobe-Helvetica-Bold-R-Normal-*-120-*" scrollbar $w.s -relief flat -command "$w.t yview" pack $w.ok -side bottom -fill x pack $w.s -side right -fill y pack $w.t -expand yes -fill both # Set up display styles if {[winfo depth $w] > 1} { set bold "-foreground red" set normal "-foreground {}" } else { set bold "-foreground white -background black" set normal "-foreground {} -background {}" } $w.t insert 0.0 {\ The same tag mechanism that controls display styles in text widgets can also be used to associate Tcl commands with regions of text, so that mouse or keyboard actions on the text cause particular Tcl commands to be invoked. For example, in the text below the descriptions of the canvas demonstrations have been tagged. When you move the mouse over a demo description the description lights up, and when you press button 3 over a description then that particular demonstration is invoked. This demo package contains a number of demonstrations of Tk's canvas widgets. Here are brief descriptions of some of the demonstrations that are available: } insertWithTags $w.t \ {1. Samples of all the different types of items that can be created in canvas widgets.} d1 insertWithTags $w.t \n\n insertWithTags $w.t \ {2. A simple two-dimensional plot that allows you to adjust the positions of the data points.} d2 insertWithTags $w.t \n\n insertWithTags $w.t \ {3. Anchoring and justification modes for text items.} d3 insertWithTags $w.t \n\n insertWithTags $w.t \ {4. An editor for arrow-head shapes for line items.} d4 insertWithTags $w.t \n\n insertWithTags $w.t \ {5. A ruler with facilities for editing tab stops.} d5 insertWithTags $w.t \n\n insertWithTags $w.t \ {6. A grid that demonstrates how canvases can be scrolled.} d6 foreach tag {d1 d2 d3 d4 d5 d6} { $w.t tag bind $tag "$w.t tag configure $tag $bold" $w.t tag bind $tag "$w.t tag configure $tag $normal" } $w.t tag bind d1 <3> mkItems $w.t tag bind d2 <3> mkPlot $w.t tag bind d3 <3> mkCanvText $w.t tag bind d4 <3> mkArrow $w.t tag bind d5 <3> mkRuler $w.t tag bind d6 <3> mkScroll $w.t mark set insert 0.0 bind $w "focus $w.t" } # The procedure below inserts text into a given text widget and # applies one or more tags to that text. The arguments are: # # w Window in which to insert # text Text to insert (it's inserted at the "insert" mark) # args One or more tags to apply to text. If this is empty # then all tags are removed from the text. proc insertWithTags {w text args} { set start [$w index insert] $w insert insert $text foreach tag [$w tag names $start] { $w tag remove $tag $start insert } foreach i $args { $w tag add $i $start insert } } gcl/gcl-tk/demos/mkVScale.lisp000077500000000000000000000030011242227143400165070ustar00rootroot00000000000000(in-package "TK") ;;# mkVScale w ;; ;; Create a top-level window that displays a vertical scale. ;; ;; Arguments: ;; w - Name to use for new top-level window. (defun mkVScale (&optional (w '.vscale )) ; (catch {destroy w}) (toplevel w) (dpos w) (wm :title w "Vertical Scale Demonstration") (wm :iconname w "Scale") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 :text "A bar and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the height of the bar. Click the OK button when you're finished.") (frame (conc w '.frame) :borderwidth 10) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.frame) (conc w '.ok)) (scale (conc w '.frame.scale) :orient "vertical" :length 280 :from 0 :to 250 :command #'(lambda (height) ; (print height) (setHeight (conc w '.frame.right.inner) height)) :tickinterval 50 :bg "Bisque1") (frame (conc w '.frame.right) :borderwidth 15) (frame (conc w '.frame.right.inner) :width 40 :height 20 :relief "raised" :borderwidth 2 :bg "SteelBlue1") (pack (conc w '.frame.scale) :side "left" :anchor "ne") (pack (conc w '.frame.right) :side "left" :anchor "nw") (funcall (conc w '.frame.scale) :set 20) (pack (conc w '.frame.right.inner) :expand "yes" :anchor "nw") ) (defun setHeight (w height) (funcall w :config :width 40 :height height) ) gcl/gcl-tk/demos/mkVScale.tcl000077500000000000000000000023001242227143400163230ustar00rootroot00000000000000# mkVScale w # # Create a top-level window that displays a vertical scale. # # Arguments: # w - Name to use for new top-level window. proc mkVScale {{w .scale1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Vertical Scale Demonstration" wm iconname $w "Scale" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "A bar and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the height of the bar. Click the \"OK\" button when you're finished." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg $w.frame $w.ok scale $w.frame.scale -orient vertical -length 280 -from 0 -to 250 \ -command "setHeight $w.frame.right.inner" -tickinterval 50 \ -bg Bisque1 frame $w.frame.right -borderwidth 15 pack $w.frame.scale -side left -anchor ne pack $w.frame.right -side left -anchor nw $w.frame.scale set 20 frame $w.frame.right.inner -width 40 -height 20 -relief raised \ -borderwidth 2 -bg SteelBlue1 pack $w.frame.right.inner -expand yes -anchor nw } proc setHeight {w height} { $w config -height $height } gcl/gcl-tk/demos/mkdialog.lisp000077500000000000000000000047511242227143400166060ustar00rootroot00000000000000;;# mkDialog w msgArgs list list '... (in-package "TK") ;; ;; Create a dialog box with a message and any number of buttons at ;; the bottom. ;; ;; Arguments: ;; w - Name to use for new top-level window. ;; msgArgs - List of arguments to use when creating the message of the ;; dialog box (e.g. :text, justifcation, etc.) ;; list - A two-element list that describes one of the buttons that ;; will appear at the bottom of the dialog. The first element ;; gives the text to be displayed in the button and the second ;; gives the command to be invoked when the button is invoked. (defun mkDialog (w msgArgs &rest args) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w :class "Dialog") (wm :title w "Dialog box") (wm :iconname w "Dialog") ;; Create two frames in the main window. The top frame will hold the ;; message and the bottom one will hold the buttons. Arrange them ;; one above the other, with any extra vertical space split between ;; them. (frame (conc w '.top) :relief "raised" :border 1) (frame (conc w '.bot) :relief "raised" :border 1) (pack (conc w '.top) (conc w '.bot) :side "top" :fill "both" :expand "yes") ;; Create the message widget and arrange for it to be centered in the ;; top frame. (apply 'message (conc w '.top.msg) :justify "center" :font :Adobe-times-medium-r-normal--*-180* msgArgs) (pack (conc w '.top.msg) :side "top" :expand "yes" :padx 3 :pady 3) ;; Create as many buttons as needed and arrange them from left to right ;; in the bottom frame. Embed the left button in an additional sunken ;; frame to indicate that it is the default button, and arrange for that ;; button to be invoked as the default action for clicks and returns in ;; the dialog. (if (> (length args) 0) (let ((i 1) arg) (setq arg (nth 0 args)) (frame (conc w '.bot.0) :relief "sunken" :border 1) (pack (conc w '.bot.0) :side "left" :expand "yes" :padx 10 :pady 10) (button (conc w '.bot.0.button) :text (nth 0 arg) :command `(progn ,(nth 1 arg)(destroy ',w))) (pack (conc w '.bot.0.button) :expand "yes" :padx 6 :pady 6) (bind w "" `(progn ,(nth 1 arg)(destroy ',w))) (focus w) (dolist (arg (cdr args)) (setq i (+ i 1)) (button (conc w '.bot. i) :text (nth 0 arg) :command `(progn ,(nth 1 arg)(destroy ',w))) (pack (conc w '.bot. i) :side "left" :expand "yes" :padx 10) ) )) (bind w "" `(focus ',w)) (focus w) ) gcl/gcl-tk/demos/nqthm-stack.lisp000077500000000000000000000044601242227143400172460ustar00rootroot00000000000000(in-package "TK") ;; turn on history; ;(MAINTAIN-REWRITE-PATH t) (defun nqthm-stack (&optional (w '.nqthm)) (toplevel w) (dpos w) (wm :title w "Nqthm Stack Frames") (wm :iconname w "Nqthm Stack") (wm :minsize w 1 1) (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 :text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. Click the OK button when you've seen enough.") (frame (conc w '.frame) :borderwidth 10) (button (conc w '.ok) :text "OK" :command `(destroy ',w)) (button (conc w '.redo) :text "Show Frames" :command `(show-frames)) (checkbutton (conc w '.rew) :text "Maintain Frames" :variable '(boolean user::do-frames) :command '(user::MAINTAIN-REWRITE-PATH user::do-frames)) (pack (conc w '.frame) :side "top" :expand "yes" :fill "y") (pack (conc w '.rew)(conc w '.redo) (conc w '.ok) :side "bottom" :fill "x") (scrollbar (conc w '.frame '.scroll) :relief "sunken" :command (tk-conc w ".frame.list yview")) (listbox (conc w '.frame.list) :yscroll (tk-conc w ".frame.scroll set") :relief "sunken" :setgrid 1) (pack (conc w '.frame.scroll) :side "right" :fill "y") (pack (conc w '.frame.list) :side "left" :expand "yes" :fill "both") (setq *list-box* (conc w '.frame.list))) (in-package "USER") (defun tk::show-frames() (funcall tk::*list-box* :delete 0 "end") (apply tk::*list-box* :insert 0 (sloop::sloop for i below user::REWRITE-PATH-STK-PTR do (setq tem (aref user::REWRITE-PATH-STK i)) (setq tem (display-rewrite-path-token (nth 0 tem) (nth 3 tem))) (cond ((consp tem) (setq tem (format nil "~a" tem)))) collect tem))) (defun display-rewrite-path-token (prog term) (case prog (ADD-EQUATIONS-TO-POT-LST (access linear-lemma name term)) (REWRITE-WITH-LEMMAS (access rewrite-rule name term)) ((REWRITE REWRITE-WITH-LINEAR) (ffn-symb term)) ((SET-SIMPLIFY-CLAUSE-POT-LST SIMPLIFY-CLAUSE) "clause") (t (er hard (prog term) |Unexpected| |prog| |in| |call| |of| display-rewrite-path-token |on| (!ppr prog nil) |and| (!ppr term (quote |.|))))))gcl/gcl-tk/demos/showVars.lisp000077500000000000000000000021051242227143400166220ustar00rootroot00000000000000(in-package "TK") ;;# showVars w var var var '... ;; ;; Create a top-level window that displays a bunch of global variable values ;; and keeps the display up-to-date even when the variables change value ;; ;; Arguments: ;; w - Name to use for new top-level window. ;; var - Name of variable to monitor. (defun showVars (w args) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (wm :title w "Variable values") (label (conc w '.title) :text "Variable values:" :width 20 :anchor "center" :font :Adobe-helvetica-medium-r-normal--*-180*) (pack (conc w '.title) :side "top" :fill "x") (dolist (i args) (frame (conc w '|.| i)) (label (conc w '|.| i '.name) :text (tk-conc i ": ")) (label (conc w '|.| i '.value) :textvariable (list (or (get i 'text-variable-type) t) i)) (pack (conc w '|.| i '.name) (conc w '|.| i '.value) :side "left") (pack (conc w '|.| i) :side "top" :anchor "w") ) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.ok) :side "bottom" :pady 2) ) gcl/gcl-tk/demos/showVars.tcl000077500000000000000000000014401242227143400164360ustar00rootroot00000000000000# showVars w var var var ... # # Create a top-level window that displays a bunch of global variable values # and keeps the display up-to-date even when the variables change value # # Arguments: # w - Name to use for new top-level window. # var - Name of variable to monitor. proc showVars {w args} { catch {destroy $w} toplevel $w wm title $w "Variable values" label $w.title -text "Variable values:" -width 20 -anchor center \ -font -Adobe-helvetica-medium-r-normal--*-180* pack $w.title -side top -fill x foreach i $args { frame $w.$i label $w.$i.name -text "$i: " label $w.$i.value -textvar $i pack $w.$i.name $w.$i.value -side left pack $w.$i -side top -anchor w } button $w.ok -text OK -command "destroy $w" pack $w.ok -side bottom -pady 2 } gcl/gcl-tk/demos/tclIndex000077500000000000000000000126661242227143400156270ustar00rootroot00000000000000# Tcl autoload index file, version 2.0 # This file is generated by the "auto_mkindex" command # and sourced to set up indexing information for one or # more commands. Typically each line is a command that # sets an element in the auto_index array, where the # element name is the name of a command and the value is # a script that loads the command. set auto_index(mkCheck) [list source [file join $dir mkCheck.tcl]] set auto_index(mkListbox2) [list source [file join $dir mkListbox2.tcl]] set auto_index(mkLabel) [list source [file join $dir mkLabel.tcl]] set auto_index(mkListbox3) [list source [file join $dir mkListbox3.tcl]] set auto_index(mkPuzzle) [list source [file join $dir mkPuzzle.tcl]] set auto_index(puzzle.switch) [list source [file join $dir mkPuzzle.tcl]] set auto_index(mkArrow) [list source [file join $dir mkArrow.tcl]] set auto_index(arrowSetup) [list source [file join $dir mkArrow.tcl]] set auto_index(arrowMove1) [list source [file join $dir mkArrow.tcl]] set auto_index(arrowMove2) [list source [file join $dir mkArrow.tcl]] set auto_index(arrowMove3) [list source [file join $dir mkArrow.tcl]] set auto_index(mkBasic) [list source [file join $dir mkBasic.tcl]] set auto_index(mkBitmaps) [list source [file join $dir mkBitmaps.tcl]] set auto_index(bitmapRow) [list source [file join $dir mkBitmaps.tcl]] set auto_index(mkButton) [list source [file join $dir mkButton.tcl]] set auto_index(mkCanvText) [list source [file join $dir mkCanvText.tcl]] set auto_index(mkTextConfig) [list source [file join $dir mkCanvText.tcl]] set auto_index(textEnter) [list source [file join $dir mkCanvText.tcl]] set auto_index(textB1Press) [list source [file join $dir mkCanvText.tcl]] set auto_index(textB1Move) [list source [file join $dir mkCanvText.tcl]] set auto_index(textBs) [list source [file join $dir mkCanvText.tcl]] set auto_index(mkDialog) [list source [file join $dir mkDialog.tcl]] set auto_index(mkEntry) [list source [file join $dir mkEntry.tcl]] set auto_index(mkEntry2) [list source [file join $dir mkEntry2.tcl]] set auto_index(mkFloor) [list source [file join $dir mkFloor.tcl]] set auto_index(floorDisplay) [list source [file join $dir mkFloor.tcl]] set auto_index(roomChanged) [list source [file join $dir mkFloor.tcl]] set auto_index(bg1) [list source [file join $dir mkFloor.tcl]] set auto_index(bg2) [list source [file join $dir mkFloor.tcl]] set auto_index(bg3) [list source [file join $dir mkFloor.tcl]] set auto_index(fg1) [list source [file join $dir mkFloor.tcl]] set auto_index(fg2) [list source [file join $dir mkFloor.tcl]] set auto_index(fg3) [list source [file join $dir mkFloor.tcl]] set auto_index(mkForm) [list source [file join $dir mkForm.tcl]] set auto_index(Tab) [list source [file join $dir mkForm.tcl]] set auto_index(mkHScale) [list source [file join $dir mkHScale.tcl]] set auto_index(setWidth) [list source [file join $dir mkHScale.tcl]] set auto_index(mkIcon) [list source [file join $dir mkIcon.tcl]] set auto_index(iconCmd) [list source [file join $dir mkIcon.tcl]] set auto_index(mkItems) [list source [file join $dir mkItems.tcl]] set auto_index(itemEnter) [list source [file join $dir mkItems.tcl]] set auto_index(itemLeave) [list source [file join $dir mkItems.tcl]] set auto_index(itemMark) [list source [file join $dir mkItems.tcl]] set auto_index(itemStroke) [list source [file join $dir mkItems.tcl]] set auto_index(itemsUnderArea) [list source [file join $dir mkItems.tcl]] set auto_index(itemStartDrag) [list source [file join $dir mkItems.tcl]] set auto_index(itemDrag) [list source [file join $dir mkItems.tcl]] set auto_index(butPress) [list source [file join $dir mkItems.tcl]] set auto_index(mkListbox) [list source [file join $dir mkListbox.tcl]] set auto_index(mkPlot) [list source [file join $dir mkPlot.tcl]] set auto_index(plotDown) [list source [file join $dir mkPlot.tcl]] set auto_index(plotMove) [list source [file join $dir mkPlot.tcl]] set auto_index(mkRadio) [list source [file join $dir mkRadio.tcl]] set auto_index(mkRuler) [list source [file join $dir mkRuler.tcl]] set auto_index(rulerMkTab) [list source [file join $dir mkRuler.tcl]] set auto_index(rulerNewTab) [list source [file join $dir mkRuler.tcl]] set auto_index(rulerMoveTab) [list source [file join $dir mkRuler.tcl]] set auto_index(demo_selectTab) [list source [file join $dir mkRuler.tcl]] set auto_index(rulerReleaseTab) [list source [file join $dir mkRuler.tcl]] set auto_index(mkScroll) [list source [file join $dir mkScroll.tcl]] set auto_index(scrollEnter) [list source [file join $dir mkScroll.tcl]] set auto_index(scrollLeave) [list source [file join $dir mkScroll.tcl]] set auto_index(scrollButton) [list source [file join $dir mkScroll.tcl]] set auto_index(mkTextSearch) [list source [file join $dir mkSearch.tcl]] set auto_index(TextLoadFile) [list source [file join $dir mkSearch.tcl]] set auto_index(TextSearch) [list source [file join $dir mkSearch.tcl]] set auto_index(TextToggle) [list source [file join $dir mkSearch.tcl]] set auto_index(mkStyles) [list source [file join $dir mkStyles.tcl]] set auto_index(insertWithTags) [list source [file join $dir mkStyles.tcl]] set auto_index(mkTear) [list source [file join $dir mkTear.tcl]] set auto_index(mkTextBind) [list source [file join $dir mkTextBind.tcl]] set auto_index(insertWithTags) [list source [file join $dir mkTextBind.tcl]] set auto_index(mkVScale) [list source [file join $dir mkVScale.tcl]] set auto_index(setHeight) [list source [file join $dir mkVScale.tcl]] set auto_index(showVars) [list source [file join $dir showVars.tcl]] gcl/gcl-tk/demos/widget.lisp000077500000000000000000000244041242227143400162770ustar00rootroot00000000000000 (in-package "TK") ;; ;; This "script" demonstrates the various widgets provided by Tk, ;; along with many of the features of the Tk toolkit. This file ;; only contains code to generate the main window for the ;; application, which invokes individual demonstrations. The ;; code for the actual demonstrations is contained in separate ;; ".tcl" files is this directory, which are auto-loaded by Tcl ;; when they are needed. To find the code for a particular ;; demo, look below for the procedure that's invoked by its menu ;; entry, then grep for the file that contains the procedure ;; definition. (tk-do (concatenate 'string "set auto_path \"" *tk-library* "/demos " "$auto_path\"")) ;; add teh current path to the auto_path so that we find the ;; .tcl demos for older demos not in new releases.. (tk-do (concatenate 'string "lappend auto_path [file dirname " (namestring (truename si::*load-pathname*)) "]")) ;(setq si::*load-path* (cons (tk-conc si::*lib-directory* "gcl-tk/demos/") si::*load-path*)) (load (merge-pathnames "index.lsp" si::*load-pathname*)) (wm :title '|.| "Widget Demonstration") ;;------------------------------------------------------- ;; The code below create the main window, consisting of a ;; menu bar and a message explaining the basic operation ;; of the program. ;;------------------------------------------------------- (frame '.menu :relief "raised" :borderwidth 1) (message '.msg :font :Adobe-times-medium-r-normal--*-180* :relief "raised" :width 500 :borderwidth 1 :text "This application demonstrates the widgets provided by the GCL Tk toolkit. The menus above are organized by widget type: each menu contains one or more demonstrations of a particular type of widget. To invoke a demonstration, press mouse button 1 over one of the menu buttons above, drag the mouse to the desired entry in the menu, then release the mouse button.) (To exit this demonstration, invoke the \"Quit\" entry in the \"Misc\" menu.") (pack '.menu :side "top" :fill "x") (pack '.msg :side "bottom" :expand "yes" :fill "both") ;;------------------------------------------------------- ;; The code below creates all the menus, which invoke procedures ;; to create particular demonstrations of various widgets. ;;------------------------------------------------------- (menubutton '.menu.button :text "Labels/Buttons" :menu '.menu.button.m :underline 7) (menu '.menu.button.m) (.menu.button.m :add 'command :label "Labels" :command "mkLabel" :underline 0) (.menu.button.m :add 'command :label "Buttons" :command "mkButton" :underline 0) (.menu.button.m :add 'command :label "Checkbuttons" :command "mkCheck" :underline 0) (.menu.button.m :add 'command :label "Radiobuttons" :command 'mkRadio :underline 0) (.menu.button.m :add 'command :label "15-puzzle" :command "mkPuzzle" :underline 0) (.menu.button.m :add 'command :label "Iconic buttons" :command "mkIcon" :underline 0) (menubutton '.menu.listbox :text "Listboxes" :menu '.menu.listbox.m :underline 0) (menu '.menu.listbox.m) (.menu.listbox.m :add 'command :label "States" :command 'mkListbox :underline 0) (.menu.listbox.m :add 'command :label "Colors" :command "mkListbox2" :underline 0) (.menu.listbox.m :add 'command :label "Well-known sayings" :command "mkListbox3" :underline 0) (menubutton '.menu.entry :text "Entries" :menu '.menu.entry.m :underline 0) (menu '.menu.entry.m) (.menu.entry.m :add 'command :label "Without scrollbars" :command 'mkentry :underline 4) (.menu.entry.m :add 'command :label "With scrollbars" :command 'mkEntry2 :underline 0) (.menu.entry.m :add 'command :label "Simple form" :command 'mkForm :underline 0) (menubutton '.menu.text :text "Text" :menu '.menu.text.m :underline 0) (menu '.menu.text.m) (.menu.text.m :add 'command :label "Basic text" :command 'mkBasic :underline 0) (.menu.text.m :add 'command :label "Display styles" :command 'mkStyles :underline 0) (.menu.text.m :add 'command :label "Command bindings" :command 'mkTextBind :underline 0) (.menu.text.m :add 'command :label "Search" :command "mkTextSearch" :underline 0) (menubutton '.menu.scroll :text "Scrollbars" :menu '.menu.scroll.m :underline 0) (menu '.menu.scroll.m) (.menu.scroll.m :add 'command :label "Vertical" :command "mkListbox2" :underline 0) (.menu.scroll.m :add 'command :label "Horizontal" :command "mkEntry2" :underline 0) (menubutton '.menu.scale :text "Scales" :menu '.menu.scale.m :underline 2) (menu '.menu.scale.m) (.menu.scale.m :add 'command :label "Vertical" :command 'mkVScale :underline 0) (.menu.scale.m :add 'command :label "Horizontal" :command 'mkHScale :underline 0) (menubutton '.menu.canvas :text "Canvases" :menu '.menu.canvas.m :underline 0) (menu '.menu.canvas.m) (.menu.canvas.m :add 'command :label "Item types" :command 'mkItems :underline 0) (.menu.canvas.m :add 'command :label "2-D plot" :command 'mkPlot :underline 0) (.menu.canvas.m :add 'command :label "Text" :command "mkCanvText" :underline 0) (.menu.canvas.m :add 'command :label "Arrow shapes" :command "mkArrow" :underline 0) (.menu.canvas.m :add 'command :label "Ruler" :command 'mkRuler :underline 0) (.menu.canvas.m :add 'command :label "Scrollable canvas" :command "mkScroll" :underline 0) (.menu.canvas.m :add 'command :label "Floor plan" :command "mkFloor" :underline 0) (menubutton '.menu.menu :text "Menus" :menu '.menu.menu.m :underline 0) (menu '.menu.menu.m) (.menu.menu.m :add 'command :label "Print hello" :command '(print "Hello") :accelerator "Control+a" :underline 6) (bind '|.| "" '(print "Hello")) (.menu.menu.m :add 'command :label "Print goodbye" :command '(print "Goodbye") :accelerator "Control+b" :underline 6) (bind '|.| "" '(format t "Goodbye")) (.menu.menu.m :add 'command :label "Light blue background" :command '(.msg :configure :bg "LightBlue1") :underline 0) (.menu.menu.m :add 'command :label "Info on tear-off menus" :command "mkTear" :underline 0) (.menu.menu.m :add 'cascade :label "Check buttons" :menu '.menu.menu.m.check :underline 0) (.menu.menu.m :add 'cascade :label "Radio buttons" :menu '.menu.menu.m.radio :underline 0) (.menu.menu.m :add 'command :bitmap "@": *tk-library* :"/demos/bitmaps/pattern" :command ' (mkDialog '.pattern '(:text "The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry." :aspect 250 ))) (menu '.menu.menu.m.check) (.menu.menu.m.check :add 'check :label "Oil checked" :variable 'oil) (.menu.menu.m.check :add 'check :label "Transmission checked" :variable 'trans) (.menu.menu.m.check :add 'check :label "Brakes checked" :variable 'brakes) (.menu.menu.m.check :add 'check :label "Lights checked" :variable 'lights) (.menu.menu.m.check :add 'separator) (.menu.menu.m.check :add 'command :label "Show current values" :command '(showVars '.menu.menu.dialog '(oil trans brakes lights))) (.menu.menu.m.check :invoke 1) (.menu.menu.m.check :invoke 3) (menu '.menu.menu.m.radio) (.menu.menu.m.radio :add 'radio :label "10 point" :variable 'pointSize :value 10) (.menu.menu.m.radio :add 'radio :label "14 point" :variable 'pointSize :value 14) (.menu.menu.m.radio :add 'radio :label "18 point" :variable 'pointSize :value 18) (.menu.menu.m.radio :add 'radio :label "24 point" :variable 'pointSize :value 24) (.menu.menu.m.radio :add 'radio :label "32 point" :variable 'pointSize :value 32) (.menu.menu.m.radio :add 'sep) (.menu.menu.m.radio :add 'radio :label "Roman" :variable 'style :value "roman") (.menu.menu.m.radio :add 'radio :label "Bold" :variable 'style :value "bold") (.menu.menu.m.radio :add 'radio :label "Italic" :variable 'style :value "italic") (.menu.menu.m.radio :add 'sep) (.menu.menu.m.radio :add 'command :label "Show current values" :command '(showVars '.menu.menu.dialog '(pointSize style))) (.menu.menu.m.radio :invoke 1) (.menu.menu.m.radio :invoke 7) (menubutton '.menu.misc :text "Misc" :menu '.menu.misc.m :underline 1) (menu '.menu.misc.m) (.menu.misc.m :add 'command :label "Modal dialog (local grab)" :command ' (progn (mkDialog '.modal '(:text "This dialog box is a modal one. It uses Tk's \"grab\" command to create a \"local grab\" on the dialog box. The grab prevents any pointer related events from getting to any other windows in the application. If you press the \"OK\" button below (or hit the Return key) then the dialog box will go away and things will return to normal." :aspect 250 :justify "left") '("OK" nil) '("Hi" (print "hi"))) (wm :geometry '.modal "+10+10") (tk-wait-til-exists '.modal) ; (tkwait :visibility '.modal) (grab '.modal) (tkwait :window '.modal) ) :underline 0) (.menu.misc.m :add 'command :label "Modal dialog (global grab)" :command '(progn (mkDialog '.modal '(:text "This is another modal dialog box. However, in this case a \"global grab\" is used, which locks up the display so you can't talk to any windows in any applications anywhere, except for the dialog. If you press the \"OK\" button below (or hit the Return key) then the dialog box will go away and things will return to normal." :aspect 250 :justify "left") '("OK" nil) '("Hi" (print "hi1"))) (wm :geometry '.modal "+10+10") (tk-wait-til-exists '.modal) ;(tkwait :visibility '.modal) (grab :set :global '.modal) (tkwait :window '.modal) ) :underline 0) (.menu.misc.m :add 'command :label "Built-in bitmaps" :command "mkBitmaps" :underline 0) (.menu.misc.m :add 'command :label "GC monitor" :command 'mkgcmonitor :underline 0) (.menu.misc.m :add 'command :label "Quit" :command "destroy ." :underline 0) (pack '.menu.button '.menu.listbox '.menu.entry '.menu.text '.menu.scroll '.menu.scale '.menu.canvas '.menu.menu '.menu.misc :side "left") ;; Set up for keyboard-based menu traversal (bind '|.| "" '(progn (if (and (equal |%d| "NotifyVirtual") (equal |%m| "NotifyNormal")) (focus '.menu) ))) ;; make the meta key do traversal bindings (bind '.menu "" "tk_traverseToMenu %W %A") (tk-menu-bar '.menu '.menu.button '.menu.listbox '.menu.entry '.menu.text '.menu.scroll '.menu.scale '.menu.canvas '.menu.menu '.menu.misc) ;; Position a dialog box at a reasonable place on the screen. (defun dpos (w) (wm :geometry w "+60+25") ) ;; some of the widgets are tcl and need this. (tk-do "proc dpos w { wm geometry $w +300+300 }") gcl/gcl-tk/dir.sed000077500000000000000000000000561242227143400142640ustar00rootroot00000000000000/DIR=/a\ DIR=/home/wfs/gcl-2.0/gcl-tk /DIR=/d gcl/gcl-tk/gcl-1.tcl000077500000000000000000000025751242227143400144300ustar00rootroot00000000000000 set LongestMatchPossible 3000 proc MarkRegexps { w regexp tag tags {start 0.0} {end end}} { upvar #0 LongestMatchPossible longest $w mark set MaRe $start set found 0 while {[$w compare MaRe < $end]} { set began MaRe set text [$w get MaRe "MaRe + [expr 10 * $longest] chars"] set limit [expr 9 * $longest] set begin 0 set last "-1 -1" while {[regexp -indices $regexp $text all j1 j2 j3 j4 j5 j6 j7 j8 \ j9 ]} { incr found set i 1 set endmatch [lindex $all 1] $w tag add $tag "MaRe + [expr $begin + [lindex $all 0]] chars" \ "MaRe + [expr $begin + [lindex $all 1]] chars" foreach ta $tags { set all [set j$i] incr i if { $all != "-1 -1" } { # puts stdout "ta=$ta taa=[set $ta]" # puts stdout "found $endmatch: `[string range $text [lindex $all 0] [lindex $all 1]]'" $w tag add $ta "MaRe + [expr $begin + [lindex $all 0]] chars" \ "MaRe + [expr $begin + [lindex $all 1]] chars" } } # puts stdout "found $endmatch: `[string range $text [expr $endmatch - 10] \ [expr $endmatch + 4]]'" set text [string range $text $endmatch end] incr begin $endmatch if {[expr $begin >= $limit]} { set limit $begin ;break} } $w mark set MaRe "MaRe + $limit chars" } # puts stdout "found $found matches" } gcl/gcl-tk/gcl.tcl000077500000000000000000000025761242227143400142730ustar00rootroot00000000000000 # some extensions for gcl # of course these could be in lisp, but keeping them on the # tk side of the pipe can cut down overhead. for large things # like getting a file proc TextLoadFile {w file} { set f [open $file] $w delete 1.0 end while {![eof $f]} { $w insert end [read $f 10000] } close $f } proc insertWithTags {w text args} { set start [$w index insert] $w insert insert $text foreach tag [$w tag names $start] { $w tag remove $tag $start insert } foreach i $args { $w tag add $i $start insert } } # in WINDOW if TAG is set at INDEX then return the range # of indices for which tag is set including index. proc get_tag_range {w tag index} { set i 1 set index [$w index $index] set range "" set ok 0 # puts stdout $index foreach v [$w tag names $index] { if {$v == $tag} {set ok 1}} while $ok { set range [$w tag nextrange $tag "$index -$i chars" "$index +1 char"] if {[llength $range ] >= 2} { break;} if {[$w compare "$index - $i chars" <= "0.0 + 1 chars" ]} { break;} set i [expr $i + 1] } return $range } proc MultipleTagAdd {win tag start l} { set prev -1 foreach v $l { puts stdout $v if { "$prev" == "-1" } { set prev $v } else { $win tag add $tag "$start + $prev chars" "$start + $v chars" set prev -1 }}} gcl/gcl-tk/gcl_cmpinit.lsp000077500000000000000000000000271242227143400160170ustar00rootroot00000000000000(load "tk-package.lsp")gcl/gcl-tk/gcl_guisl.h000077500000000000000000000001771242227143400151360ustar00rootroot00000000000000 static L1(); static L2(); static char * VVi[2]={ #define Cdata VV[1] (char *)(L1), (char *)(L2) }; #define VV ((object *)VVi) gcl/gcl-tk/gcltksrv.bat000077500000000000000000000002271242227143400153400ustar00rootroot00000000000000set GCL_TK_DIR=c:/cvs/gcl/gcl-tk set TCL_LIBRARY=c:/lang/tcl/lib/tcl8.3 set TK_LIBRARY=c:/lang/tcl/lib/tcl8.3 start %GCL_TK_DIR%/gcltkaux %1 %2 %3 gcl/gcl-tk/gcltksrv.in000077500000000000000000000013461242227143400152030ustar00rootroot00000000000000#!/bin/sh # where to find bitmaps, # and the class bindings in /usr/local/lib/tk/tk.tcl GCL_TK_DIR=/home/wfs/gcl-2.0/gcl-tk TK_XLIB_DIR=/usr/local/X11R6/lib if [ -d "${TK_XLIB_DIR}" ] ; then export LD_LIBRARY_PATH LD_LIBRARY_PATH=${LD_LIBRARY_PATH}:${TK_XLIB_DIR} fi #check to see if TK_LIBRARY set in users environment ok.. if [ -f ${TK_LIBRARY}/tk.tcl ] ;then true; else TK_LIBRARY=/var/X11/lib/X11/tk if [ -f ${TK_LIBRARY}/tk.tcl ] ;then export TK_LIBRARY ; fi export TK_LIBRARY fi if [ -f ${TCL_LIBRARY}/init.tcl ] ;then true; else TCL_LIBRARY=/usr/local/lib/tcl if [ -f ${TCL_LIBRARY}/init.tcl ] ; then export TCL_LIBRARY ; fi fi if [ $# -ge 4 ] ;then DISPLAY=$4 ; export DISPLAY; fi exec ${GCL_TK_DIR}/gcltkaux $1 $2 $3 gcl/gcl-tk/gcltksrv.in.interp000077500000000000000000000004421242227143400164770ustar00rootroot00000000000000#!/bin/sh # comment \ export GCL_TK_DIR ; \ GCL_TK_DIR=/d2/wfs/gcl-2.3/gcl-tk #comment \ export DISPLAY; DISPLAY=$4 ; exec wish "$0" "$@" set host [lindex $argv 0] set port [lindex $argv 1] set pid [lindex $argv 2] source $env(GCL_TK_DIR)/decode.tcl GclAnswerSocket $host $port $pid gcl/gcl-tk/gcltksrv.prev000077500000000000000000000006441242227143400155510ustar00rootroot00000000000000#!/bin/sh # where to find bitmaps, # and the class bindings in /usr/local/lib/tk/tk.tcl TK_LIBRARY=/var/X11/lib/X11/tk DIR=/d19/staff/wfs/ngcl-2.0/gcl-tk TK_LIBRARY=/public/lib/tk DIR=/d19/staff/wfs/ngcl-2.0/gcl-tk #put correct dir if [ -f ${TK_LIBRARY}/tk.tcl ] ; then true; else TK_LIBRARY=/usr/local/lib/tk export TK_LIBRARY fi if [ $# -ge 4 ] ;then DISPLAY=$4 ; export DISPLAY; fi exec ${DIR}/gcltkaux $1 $2 $3 gcl/gcl-tk/guis.c000077500000000000000000000264601242227143400141330ustar00rootroot00000000000000/* Copyright (C) 1994 Rami el Charif, W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL 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 Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define IN_GUIS #include #include #include #ifdef __cplusplus extern "C" { #endif #include #ifndef _WIN32 # include # ifdef PLATFORM_NEXT # include # include # else # include # include # endif #endif /* #include */ #include #ifndef _WIN32 #include #endif #include #include #include #ifdef __cplusplus #ifdef PLATFORM_NEXT extern unsigned long inet_addr( char *cp ); extern char *inet_ntoa ( struct in_addr in ); #endif } #endif #ifdef PLATFORM_LINUX #include #endif #include #ifdef __svr4__ #include #endif #ifdef PLATFORM_NEXT /* somehow, this is getting lost... */ #undef bzero #define bzero(b,len) memset(b,0,len) #endif #include "guis.h" #ifndef TRUE #define TRUE (1) #define FALSE (0) #endif FILE *pstreamDebug; int fDebugSockets; /* #ifdef PLATFORM_SUNOS */ /* static void notice_input( ); */ /* #else */ /* static void notice_input(); */ /* #endif */ int hdl = -1; void TkX_Wish (); pid_t parent; int debug; #ifdef _WIN32 #include #include /* Keep track of socket initialisations */ int w32_socket_initialisations = 0; WSADATA WSAData; /* Use threads instead of fork() */ /* Struct to hold args for thread. */ typedef struct _TAS { char **argv; int argc; int rv; int delay; } TAS; #endif #include "comm.c" #ifdef _WIN32 #define SET_SESSION_ID() 0 UINT WINAPI tf1 ( void *tain ) { TAS *ta = (TAS *) tain; UINT rv = 0; if (SET_SESSION_ID() == -1) { fprintf ( stderr, "tf: Error - set session id failed : %d\n", errno ); } if ( w32_socket_init() >= 0 ) { dsfd = sock_connect_to_name ( ta->argv[1], atoi ( ta->argv[2] ), 0); if ( dsfd ) { fprintf ( stderr, "connected to %s %s\n", ta->argv[1], ta->argv[2] ); TkX_Wish ( ta->argc, ta->argv ); fprintf ( stderr, "Wish shell done\n" ); sock_close_connection ( dsfd ); ta->rv = 0; } else { fprintf ( stderr, "Error: Can't connect to socket host=%s, port=%s, errno=%d\n", ta->argv[1], ta->argv[2], errno ); fflush ( stderr ); ta->rv = -1; } w32_socket_exit(); } else { fprintf ( stderr, "tf: Can't initialise sockets - w32_socket_init failed.\n" ); } _endthreadex ( 0 ); return ( 0 ); } int w32_socket_init(void) { int rv = 0; if (w32_socket_initialisations++) { rv = 0; } else { if (WSAStartup(0x0101, &WSAData)) { w32_socket_initialisations = 0; fprintf ( stderr, "WSAStartup failed\n" ); WSACleanup(); rv = -1; } } return rv; } int w32_socket_exit(void) { int rv = 0; if ( w32_socket_initialisations == 0 || --w32_socket_initialisations > 0 ) { rv = 0; } else { rv = WSACleanup(); } return rv; } #endif /* Start up our Graphical User Interface connecting to NETWORK-ADDRESS on PORT to process PID. If fourth argument WAITING causes debugging flags to be turned on and also causes a wait in a loop for WAITING seconds (giving a human debugger time to attach to the forked process). */ #ifdef SGC int sgc_enabled=0; #endif int delay; int main(argc, argv,envp) int argc; char *argv[]; char *envp[]; { int rv = 0; { int i = argc; pstreamDebug = stderr; while (--i > 3) { if (strcmp(argv[i],"-delay")==0) { delay = atoi(argv[i+1]);} if (strcmp(argv[i],"-debug")==0) {debug = 1; fDebugSockets = -1;} } } if (argc >= 4) { #ifdef _WIN32 UINT dwThreadID; HANDLE hThread; TAS targs; void *pTA = (void *) &targs; targs.argv = argv; targs.argc = argc; targs.rv = 0; targs.delay = delay; hThread = (HANDLE) _beginthreadex ( NULL, 0, tf1, pTA, 0, &dwThreadID ); if ( 0 == hThread ) { dfprintf ( stderr, "Error: Couldn't create thread.\n" ); rv = -1; } if ( WAIT_OBJECT_0 != WaitForSingleObject ( hThread, INFINITE ) ) { dfprintf ( stderr, "Error: Couldn't wait for thread to exit.\n" ); rv = -1; } CloseHandle ( hThread ); #else /* _WIN32 */ pid_t p; parent = atoi(argv[3]); dfprintf(stderr,"guis, parent is : %d\n", parent); #ifdef MUST_USE_VFORK p = vfork(); #else p = fork(); #endif dfprintf(stderr, "guis, vfork returned : %d\n", p); if (p == -1) { dfprintf(stderr, "Error !!! vfork failed %d\n", errno); return -1; } else if (p) { dfprintf(stderr, "guis,vforked child : %d\n", p); _exit(p); /* return p; */ } else { #ifndef SET_SESSION_ID #if defined(__svr4__) || defined(ATT) #define SET_SESSION_ID() setsid() #else #ifdef BSD #define SET_SESSION_ID() (setpgrp() ? -1 : 0) #endif #endif #endif if (SET_SESSION_ID() == -1) { dfprintf(stderr, "Error !!! setsid failed : %d\n", errno); } dsfd = sock_connect_to_name(argv[1], atoi(argv[2]), 0); if (dsfd) { dfprintf(stderr, "connected to %s %s" , argv[1], argv[2]); /* give chance for someone to attach with gdb and to set waiting to 0 */ while (-- delay >=0) sleep(1); { TkX_Wish(argc, argv); } dfprintf(stderr, "Wish shell done\n"); sock_close_connection(dsfd); return 0; } else { dfprintf(stderr, "Error !!! Can't connect to socket host=%s, port=%s, errno=%d\n" , argv[1], argv[2], errno); fflush(stderr); return -1; } } #endif /* _WIN32 */ } else { int i; fprintf ( stderr, "gcltkaux: Error - expecting more arguments, but found:\n" ); fflush(stderr); for ( i = 0; ifd ); free(sfd->read_buffer); free(sfd); } /* #ifdef PLATFORM_SUNOS */ /* static void */ /* notice_input( int sig, int code, struct sigcontext *s, char *a ) */ /* #else */ /* static void */ /* notice_input( sig ) */ /* int sig; */ /* #endif */ /* { */ /* signal( SIGIO, notice_input ); */ /* dfprintf(stderr, "\nNoticed input!\n" ); */ /* } */ static int message_id; int sock_write_str2( sfd, type, hdr, hdrsize,text, length ) struct connection_state *sfd; enum mtype type; char *hdr; int hdrsize; const char *text; int length; { char buf[0x1000]; char *p = buf; int m; int n_written; struct message_header *msg; msg = (struct message_header *) buf; if (length == 0) length = strlen(text); m = length + hdrsize; msg->magic1=MAGIC1; msg->magic2=MAGIC2; msg->type = type; msg->flag = 0; STORE_3BYTES(msg->size,m); STORE_3BYTES(msg->msg_id,message_id); message_id++; p = buf + MESSAGE_HEADER_SIZE; bcopy(hdr,p,hdrsize); p+= hdrsize; if (sizeof(buf) >= (length + hdrsize + MESSAGE_HEADER_SIZE)) { bcopy(text,p,length); n_written = write1(sfd,buf,(length + hdrsize + MESSAGE_HEADER_SIZE)); } else { n_written = write1(sfd,buf, hdrsize + MESSAGE_HEADER_SIZE); n_written += write1(sfd, text, length); } if (n_written != (length + hdrsize + MESSAGE_HEADER_SIZE)) {perror("sock_write_str: Did not write full message"); return -1;} return n_written; } #define READ_BUF_STRING_AVAIL 1 #define READ_BUF_DATA_ON_PORT 2 #define DEFAULT_TIMEOUT_FOR_TK_READ (100 * HZ) struct message_header * guiParseMsg1(sfd,buf,bufleng) char *buf; int bufleng; struct connection_state *sfd; { int m; int body_length; int tot; struct message_header *msg; msg = (struct message_header *) buf; m= read1(sfd,msg,MESSAGE_HEADER_SIZE,DEFAULT_TIMEOUT_FOR_TK_READ); if (m == MESSAGE_HEADER_SIZE) { if ( msg->magic1!=MAGIC1 || msg->magic2!=MAGIC2) { fprintf(stderr,"bad magic..flushing buffers"); while(read1(sfd,buf,bufleng,0) > 0); return 0;} GET_3BYTES(msg->size,body_length); tot = body_length+MESSAGE_HEADER_SIZE; if (tot >= bufleng) {msg = (void *)malloc(tot+1); bcopy(buf,msg,MESSAGE_HEADER_SIZE);} m = read1(sfd,&(msg->body), body_length,DEFAULT_TIMEOUT_FOR_TK_READ); if (m == body_length) { return msg;}} if (m < 0) exit(1); { static int bad_read_allowed=4; if (bad_read_allowed-- < 0) exit(1); } dfprintf(stderr,"reading from lisp timed out or not enough read"); return 0; } void error(s) char *s; { fprintf(stderr,"%s",s); abort(); } void write_timeout_error(s) char *s; { fprintf(stderr,"write timeout: %s",s); abort(); } void connection_failure(s) char *s; { fprintf(stderr,"connection_failure:%s",s); abort(); } object make_fixnum1(long i) { static union lispunion lu; lu.FIX.FIXVAL=i; return &lu; } gcl/gcl-tk/guis.h000077500000000000000000000032561242227143400141360ustar00rootroot00000000000000#ifndef _GUIS_H_ #define _GUIS_H_ #include #define NO_PRELINK_UNEXEC_DIVERSION #include "include.h" #ifdef NeXT typedef int pid_t; #endif #ifndef _ANSI_ARGS_ #ifdef __STDC__ #define _ANSI_ARGS_(x) x #else #define _ANSI_ARGS_(x) () #endif #endif #define STRING_HEADER_FORMAT "%4.4d" #define CB_STRING_HEADER (5) /* #define GET_STRING_SIZE_FROM_HEADER(__buf, __plgth) \ sscanf(__buf, STRING_HEADER_FORMAT, __plgth); */ /* sscanf is braindead on SunOS */ #define GET_STRING_SIZE_FROM_HEADER(__buf, __plgth) \ {\ __buf[CB_STRING_HEADER - 1] = 0;\ *__plgth = atoi(__buf);\ __buf[4] = '';\ } /* need to have opportunity to collapse message to reduce trafic */ #define MSG_STRAIGHT_TCL_CMD 0 #define MSG_CREATE_COMMAND 1 /* #define MSG_ */ typedef struct _guiMsg { pid_t pidSender; int vMajor; int vMinor; int idx; int fSignal; int fAck; int IdMsg; char *szData; char *szMsg; } guiMsg; #define MSG_IDX(__p) (__p->idx) #define MSG_COMMAND(__p) (__p->IdMsg) #define MSG_NEED_ACK(__p) (__p->fAck) #define MSG_NEED_SIGNAL_PARENT(__p) (__p->fSignal) #define MSG_TCL_STR(__p) (__p->szData) #define MSG_DATA_STR(__p) (__p->szData) /* #define MSG_(__p) (__p->) */ #include "sheader.h" struct message_header * guiParseMsg1(); extern pid_t parent; struct connection_state * sock_connect_to_name(); void sock_close_connection( ); int sock_read_str(); guiMsg *guiParseMsg(); void guiFreeMsg(); void guiCreateThenBindCallback(); int guiBindCallback(); #endif int sock_write_str2(struct connection_state *,enum mtype, char *, int,const char *,int); object fSclear_connection(fixnum); object fScheck_fd_for_input(fixnum,fixnum); #define SI_makefun(a_,b_,c_) gcl/gcl-tk/helpers.lisp000077500000000000000000000012711242227143400153440ustar00rootroot00000000000000 (in-package "TK") (setq controls '( after exit lower place send tkvars winfo focus option raise tk tkwait wm destroy grab pack selection tkerror update tk_listboxSingleSelect)) (setq widgets '( button listbox scale canvas menu scrollbar checkbutton menubutton text entry message frame label radiobutton toplevel )) (defun get-options (com) (let ((tem (funcall com "jo" :return 'string)) (cond ((equal (subseq tem 0 (length s)) s) (setq tem (subseq tem (length s))) (setq tem (substitute #\space #\, tem)) (setq tem (list-string tem)) (setq tem (delete "or" tem :test 'equal)) (mapcar #'(lambda (x) (intern (string-upcase x) :keyword)) tem) )))) gcl/gcl-tk/index.lsp000077500000000000000000000034621242227143400146440ustar00rootroot00000000000000 (in-package "TK") (AUTOLOAD 'FILE-TO-STRING '|info|) (AUTOLOAD 'ATOI '|info|) (AUTOLOAD 'INFO-GET-TAGS '|info|) (AUTOLOAD 'RE-QUOTE-STRING '|info|) (AUTOLOAD 'GET-MATCH '|info|) (AUTOLOAD 'GET-NODES '|info|) (AUTOLOAD 'GET-INDEX-NODE '|info|) (AUTOLOAD 'NODES-FROM-INDEX '|info|) (AUTOLOAD 'GET-NODE-INDEX '|info|) (AUTOLOAD 'ALL-MATCHES '|info|) (AUTOLOAD 'NODE-OFFSET '|info|) (AUTOLOAD 'SETUP-INFO '|info|) (AUTOLOAD 'GET-INFO-CHOICES '|info|) (AUTOLOAD 'ADD-FILE '|info|) (AUTOLOAD 'INFO-ERROR '|info|) (AUTOLOAD 'INFO-GET-FILE '|info|) (AUTOLOAD 'WAITING '|info|) (AUTOLOAD 'END-WAITING '|info|) (AUTOLOAD 'INFO-SUBFILE '|info|) (AUTOLOAD 'INFO-NODE-FROM-POSITION '|info|) (AUTOLOAD 'SHOW-INFO '|info|) (AUTOLOAD 'INFO-AUX '|info|) (AUTOLOAD 'INFO-SEARCH '|info|) (AUTOLOAD 'IDESCRIBE '|info|) (AUTOLOAD 'INFO '|info|) (AUTOLOAD 'DEFAULT-INFO-HOTLIST '|info|) (AUTOLOAD 'ADD-TO-HOTLIST '|info|) (AUTOLOAD 'LIST-MATCHES '|info|) (AUTOLOAD 'SIMPLE-LISTBOX '|tinfo|) (AUTOLOAD 'INSERT-STANDARD-LISTBOX '|tinfo|) (AUTOLOAD 'LISTBOX-MOVE '|tinfo|) (AUTOLOAD 'NEW-WINDOW '|tinfo|) (AUTOLOAD 'INSERT-INFO-CHOICES '|tinfo|) (AUTOLOAD 'OFFER-CHOICES '|tinfo|) (AUTOLOAD 'GET-INFO-APROPOS '|tinfo|) (AUTOLOAD 'SHOW-INFO-KEY '|tinfo|) (AUTOLOAD 'MKINFO '|tinfo|) (AUTOLOAD 'INFO-TEXT-SEARCH '|tinfo|) (AUTOLOAD 'PRINT-NODE '|tinfo|) (AUTOLOAD 'INFO-SHOW-HISTORY '|tinfo|) (AUTOLOAD 'SHOW-THIS-NODE '|tinfo|) (AUTOLOAD 'SCROLL-SET-FIX-XREF-CLOSURE '|tinfo|) (AUTOLOAD 'FIX-XREF '|tinfo|) (AUTOLOAD 'INSERT-FONTIFIED '|tinfo|) (AUTOLOAD 'SECTION-HEADER '|tinfo|) (AUTOLOAD 'INSERT-STRING '|tinfo|) (AUTOLOAD 'INSERT-STRING-WITH-REGEXP '|tinfo|) (AUTOLOAD 'COUNT-CHAR '|tinfo|) (AUTOLOAD 'START-OF-ITH-LINE '|tinfo|) (AUTOLOAD 'INDEX-TO-POSITION '|tinfo|) (SETQ SYSTEM::*LOAD-PATH* (APPEND '("/usr/local/gcl-2.2/gcl-tk/") SYSTEM::*LOAD-PATH*))gcl/gcl-tk/intrs.h000077500000000000000000000000001242227143400143060ustar00rootroot00000000000000gcl/gcl-tk/makefile000066400000000000000000000040121242227143400145020ustar00rootroot00000000000000 .SUFFIXES: .SUFFIXES: .o .lsp .lisp .c CC=cc LD_ORDINARY_CC=${CC} GCLTKCC=${CC} # Need libX11.a and libtcl.a, machine.defs may say where.. CC = gcc HDIR = ../h ODIR = ../o GCLIB = ../o/gcllib.a -include ../makedefs CFLAGS1=$(CFLAGS) -I../o -I../h ${TK_INCLUDE} ${TCL_INCLUDE} ${TK_XINCLUDES} all: gcltksrv tkl.o tinfo.o demos/gc-monitor.o gcltkaux (cd demos ; \ echo '(load "../tkl.o")(TK::GET-AUTOLOADS (directory "*.lisp"))' | ../../unixport/$(FLISP)) .lisp.o: echo "(compile-file \"$*.lisp\" :c-file nil :c-debug nil)" | ../unixport/$(FLISP) .lsp.o: echo "(compile-file \"$*.lsp\" :c-file nil :c-debug nil)" | ../unixport/$(FLISP) GUIOS = guis.o tkAppInit.o tkMain.o clean:: rm -f ${GUIOS} $(OFILES) gcltkaux gcltksrv *.o */*.o demos/index.lsp *.fn demos/*.fn .c.o: $(GCLTKCC) -c $(CFLAGS1) ${ODIR_DEBUG} $*.c # for some reason -lieee is on various linux systems in the list of requireds.. gcltkaux: $(GUIOS) $(LD_ORDINARY_CC) $(GUIOS) $(LDFLAGS) -o gcltkaux ${TK_LIB_SPEC} ${TCL_LIB_SPEC} gcltksrv: makefile cat gcltksrv.in | sed -e "s!TK_LIBRARY=.*!TK_LIBRARY=${TK_LIBRARY}!g" \ -e "s!TCL_LIBRARY=.*!TCL_LIBRARY=${TCL_LIBRARY}!g" \ -e "s!TK_XLIB_DIR=.*!TK_XLIB_DIR=${TK_XLIB_DIR}!g" \ -e "s!GCL_TK_DIR=.*!GCL_TK_DIR=${GCLDIR}/gcl-tk!g" > gcltksrv chmod a+x gcltksrv gcltksrv.interp: makefile cat gcltksrv.in.interp | sed -e "s!TK_LIBRARY=.*!TK_LIBRARY=${TK_LIBRARY}!g" \ -e "s!TK_XLIB_DIR=.*!TK_XLIB_DIR=${TK_XLIB_DIR}!g" \ -e "s!TCL_LIBRARY=.*!TCL_LIBRARY=${TCL_LIBRARY}!g" \ -e "s!GCL_TK_DIR=.*!GCL_TK_DIR=${GCLDIR}/gcl-tk!g" > gcltksrv.interp chmod a+x gcltksrv.interp INTERESTING=*.lsp *.lisp tk*.c guis.c sockets.c comm.c Makefile demos/*.lisp *.h tar: tar cvf - ${INTERESTING} | gzip -c > /u/wfs/sock-`date +%y%m%d`.tgz tags: etags *.lsp *.lisp tk*.c guis.c sockets.c guis.h our_io.c tkAppInit.o : tkAppInit.c tkMain.o : tkMain.c tkXAppInit.o : tkXAppInit.c tkXshell.o : tkXshell.c guis.o : guis.c guis.h comm.c sheader.h sockets.c: our_io.c sheader.h socketsl.o: socketsl.lisp sockets.c gcl/gcl-tk/makefile.prev000066400000000000000000000060211242227143400154570ustar00rootroot00000000000000 .SUFFIXES: .SUFFIXES: .o .lsp .lisp .c CC=cc LD_ORDINARY_CC=${CC} # Need libX11.a and libtcl.a, machine.defs may say where.. CC = gcc HDIR = ../h ODIR = ../o GCLIB = ../o/gcllib.a # begin makedefs # use=386-linux LIBS= -lm GCLDIR=/d2/wfs/gcl-2.3 SHELL=/bin/sh MACHINE=386-linux TK_CONFIG_PREFIX="/usr/lib" TCL_CONFIG_PREFIX="/usr/lib" #could not find dir so using: INFO_DIR="unknown" TK_INCLUDE="-I/usr/include" TK_VERSION=4.1 TCL_VERSION=7.5 TK_LIB_SPEC=-L/usr/lib -ltk TK_LIBRARY=/usr/lib/tk4.1 TCL_LIBRARY=/usr/lib/tcl7.5 TK_BUILD_LIB_SPEC=-L/usr/src/tk4.1/unix -ltk TK_XLIBSW=-L/usr/X11R6/lib -lX11 TK_XLIB_DIR=/usr/X11R6/lib TK_XINCLUDES=# no special path needed TCL_LIB_SPEC=-L/usr/lib -ltcl TCL_DL_LIBS=-ldl TCL_LIBS=-ldl -lieee -lm HAVE_X11=-DHAVE_X11 # Machine dependent makefile definitions for intel 386,486 running linux LBINDIR=/usr/local/bin OFLAG = -O LIBS = -lm ODIR_DEBUG= -O4 # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. # (the -pipe is just since our file system is slow..) CC = gcc -pipe -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char LDCC=${CC} # note for linuxaout on an elf machine add -b i486-linuxaout # CC = gcc -pipe -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char -b i486-linuxaout # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym SFASL = $(ODIR)/sfasl.o MPFILES= $(MPDIR)/mpi-386d.o $(MPDIR)/libmport.a # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s LIBFILES=bsearch.o # the make to use for saved_kcp the profiler. KCP=kcp-bsd # end makedefs CFLAGS1=$(CFLAGS) -I../o -I../h ${TK_INCLUDE} ${TK_XINCLUDES} all: gcltkaux tkl.o tinfo.o gcltksrv demos/gc-monitor.o .lisp.o: echo "(compile-file \"$*.lisp\" :c-file nil :c-debug nil)" | ../unixport/saved_gcl .lsp.o: echo "(compile-file \"$*.lsp\" :c-file t :c-debug t)" | ../unixport/saved_gcl GUIOS = guis.o tkAppInit.o tkMain.o clean:: rm -f ${GUIOS} $(OFILES) gcltkaux gcltksrv *.o */*.o .c.o: $(CC) -c $(CFLAGS1) ${ODIR_DEBUG} $*.c gcltkaux: $(GUIOS) $(LD_ORDINARY_CC) $(GUIOS) -o gcltkaux ${TK_LIB_SPEC} ${TK_BUILD_LIB_SPEC} ${TK_XLIBSW} ${TK_XINCLUDES} ${TCL_LIB_SPEC} ${TCL_DL_LIBS} ${TCL_LIBS} ${LIBS} ${GCLIB} gcltksrv: makefile cat gcltksrv.in | sed -e "s:TK_LIBRARY=.*:TK_LIBRARY=${TK_LIBRARY}:g" \ -e "s:TK_XLIB_DIR=.*:TK_XLIB_DIR=${TK_XLIB_DIR}:g" \ -e "s:GCL_TK_DIR=.*:GCL_TK_DIR=${GCLDIR}/gcl-tk:g" > gcltksrv chmod a+x gcltksrv INTERESTING=*.lsp *.lisp tk*.c guis.c sockets.c comm.c Makefile demos/*.lisp *.h tar: tar cvf - ${INTERESTING} | gzip -c > /u/wfs/sock-`date +%y%m%d`.tgz tags: etags *.lsp *.lisp tk*.c guis.c sockets.c guis.h our_io.c tkAppInit.o : tkAppInit.c tkMain.o : tkMain.c tkXAppInit.o : tkXAppInit.c tkXshell.o : tkXshell.c guis.o : guis.c guis.h comm.c sheader.h sockets.c: our_io.c sheader.h socketsl.o: socketsl.lisp sockets.c gcl/gcl-tk/ngcltksrv000077500000000000000000000003651242227143400147540ustar00rootroot00000000000000#!/bin/sh #comment \ export DISPLAY=$4 ; host=$1;port=$2 ;pid=$3 ; exec wish "$0" "$@" set host [lindex $argv 0] set port [lindex $argv 1] set pid [lindex $argv 2] source /home/wfs/gcl-2.3/gcl-tk/decode.tcl GclAnswerSocket $host $port $pid gcl/gcl-tk/our_io.c000077500000000000000000000037231242227143400144550ustar00rootroot00000000000000 #include #ifndef NO_DEFUN #ifndef DEFUN #define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,doc) ret fname #endif #endif #ifndef HZ #define HZ 60 #endif #ifndef SET_TIMEVAL #define SET_TIMEVAL(t,timeout) \ t.tv_sec = timeout/HZ; t.tv_usec = (int) ((timeout%HZ)*(1000000.0)/HZ) #endif DEFUN("CHECK-FD-FOR-INPUT",int,fScheck_fd_for_input, SI,0,0,NONE,II,IO,OO,OO, "Check FD a file descriptor for data to read, waiting TIMEOUT clicks \ for data to become available. Here there are \ INTERNAL-TIME-UNITS-PER-SECOND in one second. Return is 1 if data \ available on FD, 0 if timeout reached and -1 if failed.") (fd,timeout) int fd; int timeout; { fd_set inp; int n; struct timeval t; SET_TIMEVAL(t,timeout); FD_ZERO(&inp); FD_SET(fd, &inp); n = select(fd + 1, &inp, NULL, NULL, &t); if (n < 0) return -1; else if (FD_ISSET(fd, &inp)) return 1; else return 0; } /* read from FD into BUF, M bytes allowing TIMEOUT if necessary. return number of bytes read. */ our_read(fd,buf,m,timeout) int fd,m,timeout; char *buf; { int r,tot=0; char *p = buf; while(tot < m && (fScheck_fd_for_input(fd,timeout)>0)) { r = read(fd,p,m); if (r == 0) return tot; if (r == -1) { if (errno != EAGAIN) return -1;} else { tot += r; p += r; }} return tot; } /* write to FD file descriptor from BUF sending NBYTES. */ our_write(fd,buf,nbytes) char *buf; int fd,nbytes; { int result = 0; int m; int n = nbytes; char *p=buf; while (n>0) { m=write(fd,p,n); if (m< 0) { perror("write failed:"); return -1;} if (m==0) { fprintf(stderr, "write failed? 0 bytes written nbytes %d [%s] lost:", n,p ); return result; } p+= m; n-= m; result+= m; } if (n>0) { perror("Could not write all data:"); return result; } /* should not happen */ if (result!= nbytes) abort(); return result; } gcl/gcl-tk/sheader.h000077500000000000000000000060011242227143400145710ustar00rootroot00000000000000 #define MAGIC1 '' #define MAGIC2 'A' /* SIZE in BYTES 10+N magic1 1 magic2 1 type (id) 1 the TYPE of message. callback, command, etc...[an enum!] flag 1 things like, do acknowledge, etc. size of actual_body 3 N Use PUSH_LONG to store, POP_LONG to read msg_index 3 counter inc'd on each message sent, PUSH_SHORT to write.. actual_body N data */ enum mtype { m_not_used, m_create_command, m_reply, m_call, m_tcl_command, m_tcl_command_wait_response, m_tcl_clear_connection, /* clear tk connection and command buff */ m_tcl_link_text_variable, m_set_lisp_loc, m_tcl_set_text_variable, m_tcl_unlink_text_variable }; struct message_header { char magic1; char magic2; char type; unsigned char flag; unsigned char size[3]; unsigned char msg_id[3]; char body[1]; }; #ifndef SIGNAL_PARENT_WAITING_RESPONSE #define SIGNAL_PARENT_WAITING_RESPONSE 1 #endif #define BYTE_S 8 #define BYTE_MASK (~(~0 << BYTE_S)) #define GET_3BYTES(p,ans) do{ unsigned char* __p = (unsigned char *) p; \ ans = BYTE_MASK&(*__p++); \ ans += (BYTE_MASK&((*__p++)))<<1*BYTE_S; \ ans += (BYTE_MASK&((*__p++)))<<2*BYTE_S;} while(0) #define GET_2BYTES(p,ans) do{ unsigned char* __p = (unsigned char *) p; \ ans = BYTE_MASK&(*__p++); \ ans += (BYTE_MASK&((*__p++)))<<1*BYTE_S; \ } while(0) /* store an unsigned int n into the character pointer so that low order byte occurs first */ #define STORE_2BYTES(p,n) do{ unsigned char* __p = (unsigned char *) p; \ *__p++ = (n & BYTE_MASK);\ *__p++ = ((n >> BYTE_S) & BYTE_MASK); \ }\ while (0) #define STORE_3BYTES(p,n) do{ unsigned char* __p = (unsigned char *) p; \ *__p++ = (n & BYTE_MASK);\ *__p++ = ((n >> BYTE_S) & BYTE_MASK); \ *__p++ = ((n >> (2*BYTE_S)) & BYTE_MASK);}\ while (0) #define MESSAGE_HEADER_SIZE 10 #define HDR_SIZE 5 struct our_header { unsigned char magic; unsigned char length[2]; /* length of packet including HDR_SIZE */ unsigned char received[2]; /* tell other side about how many bytes received. incrementally */ }; struct connection_state { int fd; int total_bytes_sent; int total_bytes_received; int bytes_sent_not_received; int bytes_received_not_confirmed; int next_packet_offset; /* offset from valid_data for start of next packet*/ char *read_buffer; int read_buffer_size; char *valid_data; int valid_data_size; int max_allowed_in_pipe; int write_timeout; }; #define MAX_ALLOWED_IN_PIPE PAGESIZE #define READ_BUFF_SIZE (PAGESIZE<<1) extern struct connection_state *dsfd; #define fScheck_dsfd_for_input(sf,timeout) \ (sf->valid_data_size > 0 ? make_fixnum1(1) : fScheck_fd_for_input(sf->fd,timeout)) #define OBJ_TO_CONNECTION_STATE(x) \ ((struct connection_state *)(void *)((x)->ust.ust_self)) struct connection_state * setup_connection_state(); gcl/gcl-tk/socketsl.lisp000077500000000000000000000024131242227143400155300ustar00rootroot00000000000000(in-package "SI") ; (clines "#define our_read_with_offset(fd,buffer,offset,nbytes,timeout) our_read(fd,&((buffer)->ust.ust_self[offset]),nbytes,timeout)") ;;(defun our-read-with-offset (fd buffer offset bytes-to-read timeout) ;; (return bytes read) ;(defentry our-read-with-offset (int object int int int) (int "our_read_with_offset")) (clines "#define our_write_object(fd,buffer,nbytes) our_write(fd,buffer->ust.ust_self,nbytes)") ;; (defun our-write (fd buffer nbytes) (return bytes-written)) (defentry our-write (int object int ) (int "our_write_object")) (defentry print-to-string1 (object object object) (object print_to_string1)) (clines "#define reset_string_input_stream1(strm,string,start,end) reset_string_input_stream(strm,string,fix(start),fix(end))") (defentry reset-string-input-stream (object object object object) (object "reset_string_input_stream1")) ;(clines "#define symbol_value_any(x) ((x)->s.s_dbind)") ;(defentry symbol-value-any (object) (object symbol_value_any)) ;(clines "#define get_signals_allowed() signals_allowed") ;(defentry signals-allowed () (int "get_signals_allowed")) ;(defentry install_default_signals ()(int "install_default_signals")) ;(defentry unblock-signal (int) (int "unblock_signal")) (defentry getpid () (int "getpid")) gcl/gcl-tk/socks.h000077500000000000000000000015521242227143400143060ustar00rootroot00000000000000#ifndef _H_SOCKS #define _H_SOCKS #include "obj.h" obj sock_open_named_socket( obj name, bool async ); void sock_close_named_socket( obj named_socket ); obj sock_connect_to_name( obj host_id, obj name, bool async ); obj sock_accept_connection( obj named_socket, bool async ); obj sock_hostname_to_hostid( obj hostname, obj *aliases ); obj sock_hostid_to_hostname( obj hostid, obj *aliases ); bool sock_hostid_eq( obj hostid1, obj hostid2 ); /* items is a list of objects returned from sock_open_named_socket, sock_connect_to_name, or sock_accept_connection with async = YES */ obj sock_collect_data( obj items ); void sock_write( obj connection, const char *text, UINT_32 length ); /* sock_read should return 0 on EOF */ UINT_32 sock_read( obj connection, char *buffer, UINT_32 max_len ); void sock_close_connection( obj connection ); #endif /* _H_SOCKS */ gcl/gcl-tk/sysdep-sunos.h000077500000000000000000000002311242227143400156310ustar00rootroot00000000000000#ifndef _SYSDEP_SUNOS_H_ #define _SYSDEP_SUNOS_H_ #include #define memmove(d,s,c) bcopy(s,d,c) #define strerror(err) (perror(err),0) #endif gcl/gcl-tk/tinfo.lsp000077500000000000000000000450211242227143400146510ustar00rootroot00000000000000;; Copyright (C) 1994 W. Schelter ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; (in-package "TK") (eval-when (compile eval) (defmacro f (op x y) `(the ,(if (get op 'compiler::predicate) 't 'fixnum) (,op (the fixnum ,x) (the fixnum ,y)))) (defmacro while (test &body body) `(sloop while ,test do ,@ body)) (or (boundp '*info-window*) (si::aload "info")) ) (defun simple-listbox (w) (let ((listbox (conc w '.frame.list)) (scrollbar(conc w '.frame.scroll))) (frame (conc w '.frame)) (scrollbar scrollbar :relief "sunken" :command (tk-conc w ".frame.list yview")) (listbox listbox :yscroll (tk-conc w ".frame.scroll set") :relief "sunken" :setgrid 1) (pack scrollbar :side "right" :fill "y") (pack listbox :side "left" :expand "yes" :fill "both")) (conc w '.frame)) (defun insert-standard-listbox (w lis &aux print-entry) (funcall w :delete 0 'end) (setf (get w 'list) lis) (setq print-entry (get w 'print-entry)) (dolist (v lis) (funcall w :insert 'end (if print-entry (funcall print-entry v) v)))) (defun listbox-move (win key |%y|) |%y| (let ((amt (cdr (assoc key '(("Up" . -1) ("Down" . 1) ("Next" . 10) ("Prior" . -10)) :test 'equal)))) (cond (amt (funcall win :yview (+ (funcall win :nearest 0 :return 'number) amt)))))) (defun new-window (name &aux tem) (cond ((not (fboundp name)) name) ((winfo :exists name :return 'boolean) (let ((i 2)) (while (winfo :exists (setq tem (conc name i )) :return 'boolean) (setq i (+ i 1))) tem)) (t name))) (defun insert-info-choices (listbox list &aux file position-pattern prev) (funcall listbox :delete 0 'end) (sloop for i from 0 for name in list do (setq file nil position-pattern nil) (progn ;decode name (cond ((and (consp name) (consp (cdr name))) (setq file (cadr name) name (car name)))) (cond ((consp name) (setq position-pattern (car name) name (cdr name))))) (funcall listbox :insert 'end (format nil "~@[~a :~]~@[(~a)~]~a." position-pattern (if (eq file prev) nil (setq prev file)) name))) (setf (get listbox 'list)list)) (defun offer-choices (list info-dirs &optional (w (new-window '.info)) &aux listbox) (toplevel w) (simple-listbox w) (setq listbox (conc w '.frame.list)) (insert-info-choices listbox list) (bind listbox "" #'(lambda () (show-info (nth (atoi (funcall listbox :curselection :return 'string) 0) (get listbox 'list))))) (button (conc w '.ok) :text "Quit " :command `(destroy ',w)) (frame (conc w '.apro)) (label(conc w '.apro.label) :text "Apropos: ") (entry (conc w '.apro.entry) :relief "sunken") (pack (conc w '.apro.label) (conc w '.apro.entry) :side "left" :expand "yes") (pack (conc w '.frame) (conc w '.ok) (conc w '.apro) :side "top" :fill "both") (bind (conc w '.apro.entry) "" #'(lambda() (insert-info-choices listbox (info-aux (funcall (conc w '.apro.entry) :get :return 'string) info-dirs) ))) (bind w "" `(focus ',(conc w '.apro.entry))) w ) (defun get-info-apropos (win file type) (cond ((and win (winfo :exists win :return 'boolean)) (let ((old (get win 'info-data))) (unless (eq old *current-info-data*) (setf (get win 'info-data) *current-info-data*) (funcall (conc win '.frame.list) :delete 0 'end)) (raise win) (focus win) win)) (t (offer-choices file type nil)))) (defun show-info-key (win key) (let ((node (get win 'node)) name) (or node (info-error "No Node?")) (setq name (if (f >= (string-match (si::string-concatenate key #u":[ \t]+([^\n\t,]+)[\n\t,]") (node string node) (node header node) (node begin node)) 0) (get-match (node string node) 1))) (if name (show-info name nil)))) (defun mkinfo (&optional (w '.info_text) &aux textwin menu ) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (wm :title w "Info Text Window") (wm :iconname w "Info") (frame (setq menu (conc w '.menu )):relief "raised" :borderwidth 1) (setq textwin (conc w '.t)) (pack menu :side "top" :fill "x") (button (conc menu '.quit) :text "Quit" :command `(destroy ',w)) (menubutton (conc menu '.file) :text "File" :relief 'raised :menu (conc menu '.File '.m) :underline 0) (menu (conc menu '.file '.m)) (funcall (conc menu '.file '.m) :add 'command :label "Hotlist" :command '(show-info (tk-conc "("(default-info-hotlist) ")") nil)) (funcall (conc menu '.file '.m) :add 'command :label "Add to Hotlist" :command `(add-to-hotlist ',textwin)) (funcall (conc menu '.file '.m) :add 'command :label "Top Dir" :command `(show-info "(dir)" nil)) (button (conc menu '.next) :text "Next" :relief 'raised :command `(show-info-key ',textwin "Next")) (button (conc menu '.prev) :text "Previous" :relief 'raised :command `(show-info-key ',textwin "Prev")) (button (conc menu '.up) :text "Up" :relief 'raised :command `(show-info-key ',textwin "Up")) (button (conc menu '.info) :text "Info" :relief 'raised :command `(if (winfo :exists ".info") (raise '.info) (offer-choices nil si::*default-info-files*) )) (button (conc menu '.last) :text "Last" :relief 'raised :command `(info-show-history ',textwin 'last)) (button (conc menu '.history) :text "History" :relief 'raised :command `(info-show-history ',textwin 'history)) (pack (conc menu '.file) (conc menu '.quit) (conc menu '.next) (conc menu '.prev) (conc menu '.up) (conc menu '.prev) (conc menu '.last) (conc menu '.history) (conc menu '.info) :side "left") ; (entry (conc menu '.entry) :relief "sunken") ; (pack (conc menu '.entry) :expand "yes" :fill "x") ; (pack (conc menu '.next) ; :side "left") (bind w "" `(focus ',menu)) ; (tk-menu-bar menu (conc menu '.next) ) ; (bind menu "" "tk_traverseToMenu %W %A") (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) (text textwin :relief "raised" :bd 2 :setgrid "true" :state 'disabled) (funcall textwin :configure :yscrollcommand (scroll-set-fix-xref-closure textwin (conc w '.s)) ) (bind menu "" `(show-info-key ',textwin "Next")) (bind menu "" `(show-info-key ',textwin "Up")) (bind menu "" `(show-info-key ',textwin "Prev")) (bind menu "" (nth 4(funcall (conc menu '.last) :configure :command :return 'list-strings))) ;; SEARCHING: this needs to be speeded up and fixed. ; (bind (conc menu '.entry) "" ; `(info-text-search ',textwin ',menu %W %A %K)) ; (bind (conc menu '.entry) "" ; `(info-text-search ',textwin ',menu %W %A %K)) ; (bind menu "" #'(lambda () (focus (menu '.entry)))) (pack (conc w '.s) :side 'right :fill "y") (pack textwin :expand 'yes :fill 'both) (funcall textwin :mark 'set 'insert 0.0) (funcall textwin :tag :configure 'bold :font :Adobe-Courier-Bold-O-Normal-*-120-*) (funcall textwin :tag :configure 'big :font :Adobe-Courier-Bold-R-Normal-*-140-*) (funcall textwin :tag :configure 'verybig :font :Adobe-Helvetica-Bold-R-Normal-*-240-*) (funcall textwin :tag :configure 'xref :font :Adobe-Courier-Bold-O-Normal-*-120-* ) (funcall textwin :tag :configure 'current_xref :underline 1 ) (funcall textwin :tag :bind 'xref "" "eval [concat %W { tag add current_xref } [get_tag_range %W xref @%x,%y]]") (funcall textwin :tag :bind 'xref "" "%W tag remove current_xref 0.0 end") (funcall textwin :tag :bind 'xref "<3>" `(show-this-node ',textwin |%x| |%y|)) (focus menu) ;; (bind w "" (tk-conc "focus " w ".t")) ) (defun info-text-search (textwin menu entry a k &aux again (node (get textwin 'node))) (or node (tk-error "cant find node index")) ; (print (list entry a k )) (cond ((equal k "Delete") (let ((n (funcall entry :index 'insert :return 'number))) (funcall entry :delete (- n 1)))) ((>= (string-match "Control" k) 0)) ((equal a "") (setq again 1)) ((>= (string-match "[^-]" a) 0) (funcall entry :insert 'insert a) (setq again 0)) (t (focus menu) )) (or again (return-from info-text-search nil)) (print (list 'begin-search entry a k )) (let* ( (ind (funcall textwin :index 'current :return 'string)) (pos (index-to-position ind (node string node) (node begin node) (node end node) )) (where (info-search (funcall entry :get :return 'string) (+ again (node-offset node) pos)))) ;; to do mark region in reverse video... (cond ((>= where 0) (let ((node (info-node-from-position where))) (print-node node (- where (node-offset node))))) (t (funcall entry :flash ))))) (defvar *last-history* nil) (defun print-node (node initial-offset &aux last) ; "print text from node possibly positioning window at initial-offset ;from beginning of node" (setq last (list node initial-offset)) (let ((text '.info_text) textwin tem) (or (winfo :exists text :return 'boolean) (mkinfo text)) (setq textwin (conc text '.t)) (funcall textwin :configure :state 'normal) (cond ((get textwin 'no-record-history) (remprop textwin 'no-record-history)) ((setq tem (get textwin 'node)) (setq *last-history* nil) (push (format nil #u"* ~a:\t(~a)~a.\tat:~a" (node name tem) (node file tem) (node name tem) (funcall textwin :index "@0,0" :return 'string) ) (get textwin 'history)))) (setf (get textwin 'node) node) (funcall textwin :delete 0.0 'end) (funcall textwin :mark :set 'insert "1.0") (cond ((> initial-offset 0) ;; insert something to separate the beginning of what ;; we want to show and what goes before. (funcall textwin :insert "0.0" #u"\n") (funcall textwin :mark :set 'display_at 'end) (funcall textwin :mark :set 'insert 'end) (funcall textwin :yview 'display_at) (insert-fontified textwin (node string node) (+ (node begin node) initial-offset) (node end node)) (funcall textwin :mark :set 'insert "0.0") (insert-fontified textwin (node string node) (node begin node) (+ (node begin node) initial-offset)) ) (t (insert-fontified textwin (node string node) (node begin node) (node end node)))) (funcall textwin :configure :state 'disabled) (raise text) textwin )) (defun info-show-history (win type) (let ((his (get win 'history))) (cond ((stringp type) (if (f >= (string-match #u":\t([^\t]+)[.]\tat:([0-9.]+)" type) 0) (let ((pos (get-match type 2)) (w (show-info (get-match type 1) nil))) (setf (get win 'no-record-history) t) (or (equal "1.0" pos) (funcall w :yview pos))))) ((eq type 'last) (info-show-history win (if *last-history* (pop *last-history*) (progn (setq *last-history* (get win 'history)) (pop *last-history*))))) ((eq type 'history) (let* ((w '.info_history) (listbox (conc w '.frame.list))) (cond ((winfo :exists w :return 'boolean)) (t (toplevel w) (simple-listbox w) (button (conc w '.quit) :text "Quit" :command `(destroy ',w)) (pack (conc w '.frame) (conc w '.quit) :expand "yes" :fill 'both) )) (insert-standard-listbox listbox his) (raise w) (bind listbox "" `(info-show-history ',listbox (car (selection :get :return 'list-strings))))))))) (defun show-this-node (textwin x y) (let ((inds (get_tag_range textwin 'xref "@": x :",": y :return 'list-strings))) (cond ((and inds (listp inds) (eql (length inds) 2)) (show-info (nsubstitute #\space #\newline (apply textwin :get :return 'string inds)) nil)) (t (print inds))))) (defun scroll-set-fix-xref-closure (wint wins &aux prev) #'(lambda (&rest l) (or (equal l prev) (progn (setq prev l) (fix-xref wint) (apply wins :set l))))) (defvar *recursive* nil) ;(defun fix-xref-faster (win &aux (all'(" ")) tem) ; (unless ; *recursive* ; (let* ((*recursive* t) s ; (pat #u"\n\\* ([^:\n]+)::|\n\\* [^:\n]+:[ \t]*(\\([^,\n\t]+\\)[^,.\n\t]*)[^\n]?|\n\\* [^:\n]+:[ \t]*([^,(.\n\t]+)[^\n]?") ; (beg (funcall win :index "@0,0 linestart -1 char" :return 'string)) ; (end (funcall win :index "@0,1000 lineend" :return 'string))) ; (cond ((or (f >= (string-match "possible_xref" ; (funcall win :tag :names beg :return 'string)) 0) ; (not (equal "" ; (setq tem (funcall win :tag :nextrange "possible_xref" beg end ; :return 'string))))) ; (if tem (setq beg (car (list-string tem)))) ; (let ((s (funcall win :get beg end :return 'string)) ; (j 0) i) ; (with-tk-command ; (pp "MultipleTagAdd" no_quote) ; (pp win normal) ; (pp "xref" normal) ; (pp beg normal) ; (pp "{" no_quote) ; (while (f >= (string-match pat s j) 0) ; (setq i (if (f >= (match-beginning 1) 0) 1 2)) ; (pp (match-beginning i) no_quote) ; (pp (match-end i) no_quote) ; (setq j (match-end 0)) ; ) ; (pp "}" no_quote) ; (send-tcl-cmd *tk-connection* tk-command nil))) ; (funcall win :tag :remove "possible_xref" beg end) ; ))))) (defun fix-xref (win &aux tem) (unless *recursive* (let* ((*recursive* t) (pat #u"\n\\* ([^:\n]+)::|\n\\* [^:\n]+:[ \t]*(\\([^,\n\t]+\\)[^,.\n\t]*)[^\n]?|\n\\* [^:\n]+:[ \t]*([^,(.\n\t]+)[^\n]?") (beg (funcall win :index "@0,0 linestart -1 char" :return 'string)) (end (funcall win :index "@0,1000 lineend" :return 'string))) (cond ((or (f >= (string-match "possible_xref" (funcall win :tag :names beg :return 'string)) 0) (not (equal "" (setq tem (funcall win :tag :nextrange "possible_xref" beg end :return 'string))))) (if tem (setq beg (car (list-string tem)))) (let ((s (funcall win :get beg end :return 'string)) (j 0) i) (while (f >= (string-match pat s j) 0) (setq i (if (f >= (match-beginning 1) 0) 1 (if (f >= (match-beginning 2) 0) 2 3))) (funcall win :tag :add "xref" beg : "+" : (match-beginning i) : " chars" beg : "+" : (match-end i) : " chars") (setq j (match-end 0)))) (funcall win :tag :remove "possible_xref" beg end) ))))) (defun insert-fontified (window string beg end) "set fonts in WINDOW for string with " ; (waiting window) ; (print (list beg end)) (insert-string-with-regexp window string beg end #u"\n([^\n]+)\n[.=_*-][.=*_-]+\n|\\*Note ([^:]+)::" '((1 section-header) (2 "xref") )) (funcall window :tag :add "possible_xref" "0.0" "end") (fix-xref window) (end-waiting window) ) (defun section-header (win string lis &aux (i (car lis))) (let ((mark 'insert)) (insert-string win string (match-beginning 0) (match-end i)) (funcall win :insert mark #u"\n") (funcall win :tag :add (cdr (assoc (aref string (f + (match-end i) 2)) '((#\= . "verybig") (#\_ . "big") (#\- . "big") (#\. . "bold") (#\* . "bold") ))) "insert - " : (f - (match-end i) (f + (match-beginning i ) -1 )) : " chars" "insert -1 chars") ;;make index count be same.. (let ((n (f - (f - (match-end 0) (match-end i)) 1))) (declare (fixnum n)) (if (>= n 0) (funcall win :insert mark (make-string n ))) ))) (defun insert-string (win string beg end) (and (> end beg) (let ((ar (make-array (- end beg) :element-type 'string-char :displaced-to string :displaced-index-offset beg))) (funcall win :insert 'insert ar)))) (defun insert-string-with-regexp (win string beg end regexp reg-actions &aux (i 0) temi (*window* win) *match-data*) (declare (special *window* *match-data*)) (declare (fixnum beg end i)) (while (f >= (string-match regexp string beg end) 0) (setq i 1) (setq temi nil) (loop (or (< i 10) (return nil)) (cond ((f >= (match-beginning i) 0) (setq temi (assoc i reg-actions)) (return nil))) (setq i (+ i 1))) (cond ;(t nil) ((functionp (second temi)) (insert-string win string beg (match-beginning 0)) (funcall (second temi) win string temi)) ((stringp (second temi)) (insert-string win string beg (match-end 0)) (dolist (v (cdr temi)) (funcall win :tag :add v "insert -" : (f - (match-end 0) (match-beginning i)) : " chars" "insert -" :(f - (match-end 0) (match-end i)): " chars" ) )) (t (info-error "bad regexp prop"))) (setq beg (match-end 0)) (or (<= beg end) (error "hi")) ) (insert-string win string beg end)) (defun count-char (ch string beg end &aux (count 0)) ; "Count the occurrences of CH in STRING from BEG to END" (declare (character ch)) (declare (string string)) (declare (fixnum beg end count)) (while (< beg end) (if (eql (aref string beg) ch) (incf count)) (incf beg)) count) (defun start-of-ith-line (count string beg &optional (end -1)) (declare (string string)) (declare (fixnum beg end count)) (if (< end 0) (setq end (length string))) (cond ((eql count 1) beg) (t (decf count) (while (< beg end) (if (eql (aref string beg) #\newline) (progn (decf count) (incf beg) (if (<= count 0) (return-from start-of-ith-line beg))) (incf beg))) beg))) (defun index-to-position (index string beg &optional (end -1) &aux (count 0)) ; "Find INDEX of form \"line.char\" in STRING with 0.0 at BEG and ; up to END. Result is a fixnum string index" (declare (string string index)) (declare (fixnum beg end count)) (if (< end 0) (setq end (length string))) (let* ((line (atoi index 0)) (charpos (atoi index (+ 1 (position #\. index))))) (declare (fixnum line charpos)) (setq count (start-of-ith-line line string beg end)) (print (list count charpos)) (+ count charpos))) ;;; Local Variables: *** ;;; mode:lisp *** ;;; version-control:t *** ;;; comment-column:0 *** ;;; comment-start: ";;; " *** ;;; End: *** gcl/gcl-tk/tk-package.lsp000077500000000000000000000015361242227143400155440ustar00rootroot00000000000000(in-package "TK" :use '("LISP" "SLOOP")) (in-package "SI") (import '( string begin end header name info-subfile file tags end-waiting si::match-beginning si::idescribe si::setup-info si::autoload si::idescribe si::*default-info-files* si::*info-paths* si::*info-window* si::info si::get-match si::print-node si::offer-choices si::match-end si::string-match si::*case-fold-search* si::*current-info-data* si::info-data si::node si::info-aux si::info-error si::*tk-library* si::*tk-connection* si::show-info si::tkconnect si::*match-data*) "TK") gcl/gcl-tk/tkAppInit.c000077500000000000000000000070351242227143400150640ustar00rootroot00000000000000/* * tkAppInit.c -- * * Provides a default version of the Tcl_AppInit procedure for * use in wish and similar Tk-based applications. * * Copyright (c) 1993 The Regents of the University of California. * All rights reserved. * * Permission is hereby granted, without written agreement and without * license or royalty fees, to use, copy, modify, and distribute this * software and its documentation for any purpose, provided that the * above copyright notice and the following two paragraphs appear in * all copies of this software. * * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. */ /* #ifndef lint */ /* static char rcsid[] = "/usr/home/gah/repository/blt/tkAppInit.c,v 1.3 1994/04/02 04:37:26 gah Exp SPRITE (Berkeley) $Revision"; */ /* #endif */ #include "tk.h" /* * The following variable is a special hack that allows applications * to be linked using the procedure "main" from the Tk library. The * variable generates a reference to "main", which causes main to * be brought in from the library (and all of Tk and Tcl with it). */ extern int main(); int *tclDummyMainPtr = (int *) main; /* *---------------------------------------------------------------------- * * Tcl_AppInit -- * * This procedure performs application-specific initialization. * Most applications, especially those that incorporate additional * packages, will have their own version of this procedure. * * Results: * Returns a standard Tcl completion code, and leaves an error * message in interp->result if an error occurs. * * Side effects: * Depends on the startup script. * *---------------------------------------------------------------------- */ int Tcl_AppInit(interp) Tcl_Interp *interp; /* Interpreter for application. */ { Tk_Window mmain; /* extern int Blt_Init _ANSI_ARGS_((Tcl_Interp *interp)); */ mmain = Tk_MainWindow(interp); /* * Call the init procedures for included packages. Each call should * look like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * where "Mod" is the name of the module. */ /* if (Blt_Init(interp) == TCL_ERROR) { return TCL_ERROR; } */ if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (Tk_Init(interp) == TCL_ERROR) { return TCL_ERROR; } /* * Call Tcl_CreateCommand for application-specific commands, if * they weren't already created by the init procedures called above. */ /* * Specify a user-specific startup file to invoke if the application * is run interactively. Typically the startup file is "~/.apprc" * where "app" is the name of the application. If this line is deleted * then no user-specific startup file will be run under any conditions. */ /* for version tk 3.5: tcl_RcFileName = "~/.wishrc"; */ Tcl_SetVar(interp, "tcl_rcFileName", "~/.wishrc", TCL_GLOBAL_ONLY); return TCL_OK; } gcl/gcl-tk/tkMain.c000077500000000000000000000440621242227143400144050ustar00rootroot00000000000000/* * main.c -- * * This file contains the main program for "wish", a windowing * shell based on Tk and Tcl. It also provides a template that * can be used as the basis for main programs for other Tk * applications. * * Copyright (c) 1990-1993 The Regents of the University of California. * All rights reserved. * * Permission is hereby granted, without written agreement and without * license or royalty fees, to use, copy, modify, and distribute this * software and its documentation for any purpose, provided that the * above copyright notice and the following two paragraphs appear in * all copies of this software. * * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. */ /* #ifndef lint */ /* static char rcsid[] = "$Header$ SPRITE (Berkeley)"; */ /* #endif */ #include #include #include #include #include #if (TK_MINOR_VERSION==0 && TK_MAJOR_VERSION==4) #define TkCreateMainWindow Tk_CreateMainWindow #endif #if TCL_MAJOR_VERSION >= 8 #define INTERP_RESULT(interp) Tcl_GetStringResult(interp) #else #define INTERP_RESULT(interp) (interp)->result #endif /*-------------------------------------------------------------------*/ #include #include #include #include int writable_malloc=0; /*FIXME, don't wrap fopen here, exclude notcomp.h or equivalent */ #include "guis.h" struct connection_state *dsfd; /*-------------------------------------------------------------------*/ /* * Declarations for various library procedures and variables (don't want * to include tkInt.h or tkConfig.h here, because people might copy this * file out of the Tk source directory to make their own modified versions). */ /* extern void exit _ANSI_ARGS_((int status)); */ extern int isatty _ANSI_ARGS_((int fd)); /* extern int read _ANSI_ARGS_((int fd, char *buf, size_t size)); */ extern char * strrchr _ANSI_ARGS_((CONST char *string, int c)); /* * Global variables used by the main program: */ /* static Tk_Window mainWindow; The main window for the application. If * NULL then the application no longer * exists. */ static Tcl_Interp *interp; /* Interpreter for this application. */ char *tcl_RcFileName; /* Name of a user-specific startup script * to source if the application is being run * interactively (e.g. "~/.wishrc"). Set * by Tcl_AppInit. NULL means don't source * anything ever. */ static Tcl_DString command; /* Used to assemble lines of terminal input * into Tcl commands. */ static int tty; /* Non-zero means standard input is a * terminal-like device. Zero means it's * a file. */ static char errorExitCmd[] = "exit 1"; /* * Command-line options: */ static int synchronize = 0; static char *fileName = NULL; static char *name = NULL; static char *display = NULL; static char *geometry = NULL; int debug = 0; static void guiCreateCommand _ANSI_ARGS_((int idLispObject, int iSlot , char *arglist)); void dfprintf(FILE *fp,char *s,...) { va_list args; if (debug) { va_start(args,s); fprintf(fp,"\nguis:"); vfprintf(fp,s,args); fflush(fp); va_end(args); } } #define CMD_SIZE 4000 #define SIGNAL_ERROR TCL_signal_error static void TCL_signal_error(x) char *x; {char buf[300] ; sprintf(buf,"error %s",x); Tcl_Eval(interp,buf); dfprintf(stderr,x); } static Tk_ArgvInfo argTable[] = { {"-file", TK_ARGV_STRING, (char *) NULL, (char *) &fileName, "File from which to read commands"}, {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry, "Initial geometry for window"}, {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display, "Display to use"}, {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name, "Name to use for application"}, {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize, "Use synchronous mode for display server"}, {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL, (char *) NULL} }; /* * Declaration for Tcl command procedure to create demo widget. This * procedure is only invoked if SQUARE_DEMO is defined. */ extern int SquareCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char *argv[])); /* * Forward declarations for procedures defined later in this file: */ static void StdinProc _ANSI_ARGS_((ClientData clientData, int mask)); /* *---------------------------------------------------------------------- * * main -- * * Main program for Wish. * * Results: * None. This procedure never returns (it exits the process when * it's done * * Side effects: * This procedure initializes the wish world and then starts * interpreting commands; almost anything could happen, depending * on the script being interpreted. * *---------------------------------------------------------------------- */ /* int main(argc, argv) */ /* FIXME, should come in from tk header or not be called */ EXTERN Tk_Window TkCreateMainWindow _ANSI_ARGS_((Tcl_Interp * interp, char * screenName, char * baseName)); void TkX_Wish (argc, argv) int argc; /* Number of arguments. */ char **argv; /* Array of argument strings. */ { char *args, *p; const char *msg; char buf[20]; int code; interp = Tcl_CreateInterp(); #ifdef TCL_MEM_DEBUG Tcl_InitMemory(interp); #endif /* * Parse command-line arguments. */ if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, (const char **)argv, argTable, 0) != TCL_OK) { fprintf(stderr, "%s\n", INTERP_RESULT(interp)); exit(1); } if (name == NULL) { if (fileName != NULL) { p = fileName; } else { p = argv[0]; } name = strrchr(p, '/'); if (name != NULL) { name++; } else { name = p; } } /* * If a display was specified, put it into the DISPLAY * environment variable so that it will be available for * any sub-processes created by us. */ if (display != NULL) { Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY); } /* * Initialize the Tk application. */ /* mainWindow = TkCreateMainWindow(interp, display, name/\* , "Tk" *\/); */ /* if (mainWindow == NULL) { */ /* fprintf(stderr, "%s\n", INTERP_RESULT(interp)); */ /* exit(1); */ /* } */ /* #ifndef __MINGW32__ */ /* if (synchronize) { */ /* XSynchronize(Tk_Display(mainWindow), True); */ /* } */ /* #endif */ /* Tk_GeometryRequest(mainWindow, 200, 200); */ /* Tk_UnmapWindow(mainWindow); */ /* * Make command-line arguments available in the Tcl variables "argc" * and "argv". Also set the "geometry" variable from the geometry * specified on the command line. */ args = Tcl_Merge(argc-1, (const char **)argv+1); Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); ckfree(args); sprintf(buf, "%d", argc-1); Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], TCL_GLOBAL_ONLY); if (geometry != NULL) { Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY); } /* * Set the "tcl_interactive" variable. */ tty = isatty(dsfd->fd); Tcl_SetVar(interp, "tcl_interactive", ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); /* * Add a few application-specific commands to the application's * interpreter. */ /* #ifdef SQUARE_DEMO */ /* Tcl_CreateCommand(interp, "square", SquareCmd, (ClientData) mainWindow, */ /* (void (*)()) NULL); */ /* #endif */ /* * Invoke application-specific initialization. */ if (Tcl_AppInit(interp) != TCL_OK) { fprintf(stderr, "Tcl_AppInit failed: %s\n", INTERP_RESULT(interp)); } /* * Set the geometry of the main window, if requested. */ if (geometry != NULL) { code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL); if (code != TCL_OK) { fprintf(stderr, "%s\n", INTERP_RESULT(interp)); } } /* * Invoke the script specified on the command line, if any. */ if (fileName != NULL) { code = Tcl_VarEval(interp, "source ", fileName, (char *) NULL); if (code != TCL_OK) { goto error; } tty = 0; } else { /* * Commands will come from standard input, so set up an event * handler for standard input. If the input device is aEvaluate the * .rc file, if one has been specified, set up an event handler * for standard input, and print a prompt if the input * device is a terminal. */ if (tcl_RcFileName != NULL) { Tcl_DString buffer; char *fullName; FILE *f; fullName = Tcl_TildeSubst(interp, tcl_RcFileName, &buffer); if (fullName == NULL) { fprintf(stderr, "%s\n", INTERP_RESULT(interp)); } else { f = fopen(fullName, "r"); if (f != NULL) { code = Tcl_EvalFile(interp, fullName); if (code != TCL_OK) { fprintf(stderr, "%s\n", INTERP_RESULT(interp)); } fclose(f); } } Tcl_DStringFree(&buffer); } dfprintf(stderr, "guis : Creating file handler for %d\n", dsfd->fd); #ifndef __MINGW32__ Tk_CreateFileHandler(dsfd->fd, TK_READABLE, StdinProc, (ClientData) 0); #endif } fflush(stdout); Tcl_DStringInit(&command); /* * Loop infinitely, waiting for commands to execute. When there * are no windows left, Tk_MainLoop returns and we exit. */ Tk_MainLoop(); /* * Don't exit directly, but rather invoke the Tcl "exit" command. * This gives the application the opportunity to redefine "exit" * to do additional cleanup. */ Tcl_Eval(interp, "exit"); exit(1); error: msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (msg == NULL) { msg = INTERP_RESULT(interp); } dfprintf(stderr, "%s\n", msg); Tcl_Eval(interp, errorExitCmd); return; /* Needed only to prevent compiler warnings. */ } static char *being_set_by_lisp; static char * tell_lisp_var_changed( clientData, interp, name1, name2, flags) ClientData clientData; Tcl_Interp *interp; char *name1; char *name2; int flags; { if (being_set_by_lisp == 0) { const char *val = Tcl_GetVar2(interp,name1,name2, TCL_GLOBAL_ONLY); char buf[3]; STORE_3BYTES(buf,(long) clientData); if(sock_write_str2(dsfd, m_set_lisp_loc, buf, 3 , val, strlen(val)) < 0) { /* what do we want to do if the write failed */} #ifndef __MINGW32__ if (parent > 0) kill(parent, SIGUSR1); #endif } else /* avoid going back to lisp if it is lisp that is doing the setting! */ if (strcmp(being_set_by_lisp,name1)) { fprintf(stderr,"recursive setting of vars %s??",name1);} /* normal */ return 0; } /* *---------------------------------------------------------------------- * * StdinProc -- * * This procedure is invoked by the event dispatcher whenever * standard input becomes readable. It grabs the next line of * input characters, adds them to a command being assembled, and * executes the command if it's complete. * * Results: * None. * * Side effects: * Could be almost arbitrary, depending on the command that's * typed. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void StdinProc(clientData, mask) ClientData clientData; /* Not used. */ int mask; /* Not used. */ { int fNotDone; char *cmd; int code, count; struct message_header *msg; char buf[0x4000]; msg = (struct message_header *) buf; /* * Disable the stdin file handler while evaluating the command; * otherwise if the command re-enters the event loop we might * process commands from stdin before the current command is * finished. Among other things, this will trash the text of the * command being evaluated. */ dfprintf(stderr, "\nguis : Disabling file handler for %d\n", dsfd->fd); /* Tk_CreateFileHandler(dsfd->fd, 0, StdinProc, (ClientData) 0); */ do { msg = guiParseMsg1(dsfd,buf,sizeof(buf)); if (msg == NULL) { /*dfprintf(stderr, "Yoo !!! Empty command\n"); */ if (debug)perror("zero message"); #ifndef __MINGW32__ Tk_CreateFileHandler(dsfd->fd, TK_READABLE, StdinProc, (ClientData) 0); #endif return; } /* Need to switch to table lookup */ switch (msg->type){ case m_create_command: { int iSlot; GET_3BYTES(msg->body,iSlot); guiCreateCommand(0, iSlot, &(msg->body[3])); } break; case m_tcl_command : case m_tcl_command_wait_response: count = strlen(msg->body); cmd = Tcl_DStringAppend(&command, msg->body, count); code = Tcl_RecordAndEval(interp, cmd, 0); if (msg->type == m_tcl_command_wait_response || code) { char buf[4]; char *p = buf, *string; /*header */ *p++ = (code ? '1' : '0'); bcopy(msg->msg_id,p,3); /* end header */ string = (char *)INTERP_RESULT(interp); if(sock_write_str2(dsfd, m_reply, buf, 4, string, strlen(string)) < 0) { /* what do we want to do if the write failed */} if (msg->type == m_tcl_command_wait_response) { /* parent is waiting so dong signal */ ;} #ifndef __MINGW32__ else if (parent> 0)kill(parent, SIGUSR1); #endif } Tcl_DStringFree(&command); break; case m_tcl_clear_connection: /* we are stuck... */ { Tcl_DStringInit(&command); Tcl_DStringFree(&command); fSclear_connection(dsfd->fd); } break; case m_tcl_set_text_variable: { int n = strlen(msg->body); if(being_set_by_lisp) fprintf(stderr,"recursive set?"); /* avoid a trace on this set!! */ being_set_by_lisp = msg->body; Tcl_SetVar2(interp,msg->body,0,msg->body+n+1, TCL_GLOBAL_ONLY); being_set_by_lisp = 0; } break; case m_tcl_link_text_variable: {long i; GET_3BYTES(msg->body,i); Tcl_TraceVar2(interp,msg->body+3 ,0, TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_GLOBAL_ONLY , tell_lisp_var_changed, (ClientData) i); } break; case m_tcl_unlink_text_variable: {long i; GET_3BYTES(msg->body,i); Tcl_UntraceVar2(interp,msg->body+3 ,0, TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_GLOBAL_ONLY , tell_lisp_var_changed, (ClientData) i); } break; default : dfprintf(stderr, "Error !!! Unknown command %d\n" , msg->type); } fNotDone = fix(fScheck_dsfd_for_input(dsfd,0)); if (fNotDone > 0) { dfprintf(stderr, "\nguis : in StdinProc, not done, executed %s" , msg->body); } } while (fNotDone > 0); /* Tk_CreateFileHandler(dsfd->fd, TK_READABLE, StdinProc, (ClientData) 0); */ if ((void *)msg != (void *) buf) free ((void *) msg); } /* ----------------------------------------------------------------- */ typedef struct _ClientDataLispObject { int id; int iSlot; char *arglist; } ClientDataLispObject; static int TclGenericCommandProcedure( clientData, pinterp, argc, argv) ClientData clientData; Tcl_Interp *pinterp; int argc; char *argv[]; { char szCmd[CMD_SIZE]; ClientDataLispObject *pcdlo = (ClientDataLispObject *)clientData; int cb=0; char *q = szCmd; char *p = pcdlo->arglist; STORE_3BYTES(q,(pcdlo->iSlot)); q += 3; if (p == 0) { char *arg = (argc > 1 ? argv[1] : ""); int m = strlen(arg); if (m > CMD_SIZE -50) SIGNAL_ERROR("too big command"); bcopy(arg,q,m); q += m ;} else { int i,n; *q++ = '('; n = strlen(p); for (i=1; i< argc; i++) { if (i < n && p[i]=='s') { *q++ = '"';} strcpy(q,argv[i]); q+= strlen(argv[i]); if (i < n && p[i]=='s') { *q++ = '"';} } *q++ = ')'; } *q = 0; dfprintf(stderr, "TclGenericCommandProcedure : %s\n" , szCmd ); if (sock_write_str2(dsfd,m_call, "",0, szCmd, q-szCmd) == -1) { dfprintf(stderr, "Error\t(TclGenericCommandProcedure) !!!\n\tFailed to write [%s] to socket %d (%d) cb=%d\n" , szCmd, dsfd->fd, errno, cb); } #ifndef __MINGW32__ if (parent > 0)kill(parent, SIGUSR1); #endif return TCL_OK; } static void guiCreateCommand( idLispObject, iSlot , arglist) int idLispObject; int iSlot ; char *arglist; { char szNameCmdProc[2000],*c; ClientDataLispObject *pcdlo; sprintf(szNameCmdProc, "callback_%d",iSlot); pcdlo = (ClientDataLispObject *)malloc(sizeof(ClientDataLispObject)); pcdlo->id = idLispObject; pcdlo->iSlot = iSlot; if (arglist[0] == 0) { pcdlo->arglist = 0;} else {c= malloc(strlen(arglist)+1); strcpy(c,arglist); pcdlo->arglist = c;} Tcl_CreateCommand(interp , szNameCmdProc, TclGenericCommandProcedure , (ClientData *)pcdlo, free); dfprintf(stderr, "TCL creating callback : %s\n", szNameCmdProc); /* guiBindCallback(szNameCmdProc, szTclObject, szModifier,arglist); */ } /* int guiBindCallback(char *szNameCmdProc, char *szTclObject, char *szModifier,char* arglist) { int code; char szCmd[2000]; sprintf(szCmd, "bind %s %s {%s %s}" , szTclObject , szModifier , szNameCmdProc , (arglist ? arglist : "") ); dfprintf(stderr, "TCL BIND : %s\n", szCmd); code = Tcl_Eval(interp, szCmd); if (code != TCL_OK) { dfprintf(stderr, "TCL Error int bind : %s\n", INTERP_RESULT(interp)); } return code; } */ /* static void */ /* guiDeleteCallback(szCallback) */ /* char *szCallback; */ /* { */ /* dfprintf(stderr, "Tcl Deleting command : %s\n", szCallback); */ /* Tcl_DeleteCommand(interp, szCallback); */ /* } */ /* */ gcl/gcl-tk/tkXAppInit.c000077500000000000000000000106301242227143400152070ustar00rootroot00000000000000/* * tkXAppInit.c -- * * Provides a default version of the Tcl_AppInit procedure for use with * applications built with Extended Tcl and Tk. This is based on the * the UCB Tk file tkAppInit.c * *----------------------------------------------------------------------------- * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id$ *----------------------------------------------------------------------------- * Copyright (c) 1993 The Regents of the University of California. * All rights reserved. * * Permission is hereby granted, without written agreement and without * license or royalty fees, to use, copy, modify, and distribute this * software and its documentation for any purpose, provided that the * above copyright notice and the following two paragraphs appear in * all copies of this software. * * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. */ #ifndef lint static char rcsid[] = "$Header$ SPRITE (Berkeley)"; #endif /* not lint */ #include "tclExtend.h" #include "tk.h" #include /* * The following variable is a special hack that allows applications * to be linked using the procedure "main" from the Tk library. The * variable generates a reference to "main", which causes main to * be brought in from the library (and all of Tk and Tcl with it). */ EXTERN int main _ANSI_ARGS_((int argc, char **argv)); int *tclDummyMainPtr = (int *) main; /* * The following variable is a special hack that insures the tcl * version of matherr() is used when linking against shared libraries * Only define if matherr is used on this system. */ #if defined(DOMAIN) && defined(SING) EXTERN int matherr _ANSI_ARGS_((struct exception *)); int *tclDummyMathPtr = (int *) matherr; #endif /* *---------------------------------------------------------------------- * * Tcl_AppInit -- * * This procedure performs application-specific initialization. * Most applications, especially those that incorporate additional * packages, will have their own version of this procedure. * * Results: * Returns a standard Tcl completion code, and leaves an error * message in interp->result if an error occurs. * * Side effects: * Depends on the startup script. * *---------------------------------------------------------------------- */ int Tcl_AppInit(interp) Tcl_Interp *interp; /* Interpreter for application. */ { Tk_Window main; main = Tk_MainWindow(interp); /* * Call the init procedures for included packages. Each call should * look like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * where "Mod" is the name of the module. */ if (TclX_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (TkX_Init(interp) == TCL_ERROR) { return TCL_ERROR; } /* * Call Tcl_CreateCommand for application-specific commands, if * they weren't already created by the init procedures called above. */ /* * Specify a user-specific startup file to invoke if the application * is run interactively. Typically the startup file is "~/.apprc" * where "app" is the name of the application. If this line is deleted * then no user-specific startup file will be run under any conditions. */ tcl_RcFileName = "~/.tclrc"; return TCL_OK; } gcl/gcl-tk/tkXshell.c000077500000000000000000000274021242227143400147570ustar00rootroot00000000000000/* * tkXshell.c * * Version of Tk main that is modified to build a wish shell with the Extended * Tcl command set and libraries. This makes it easier to use a different * main. *----------------------------------------------------------------------------- * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id$ *----------------------------------------------------------------------------- */ /* * main.c -- * * This file contains the main program for "wish", a windowing * shell based on Tk and Tcl. It also provides a template that * can be used as the basis for main programs for other Tk * applications. * * Copyright (c) 1990-1993 The Regents of the University of California. * All rights reserved. * * Permission is hereby granted, without written agreement and without * license or royalty fees, to use, copy, modify, and distribute this * software and its documentation for any purpose, provided that the * above copyright notice and the following two paragraphs appear in * all copies of this software. * * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. */ #ifdef __cplusplus # include "tcl++.h" # include #else # include "tclExtend.h" #endif #include "tk.h" /*-------------------------------------------------------------------*/ #include #include #include int sock_write( int connection, const char *text, int length ); int sock_read( int connection, char *buffer, int max_len ); extern int hdl; extern pid_t parent; /*-------------------------------------------------------------------*/ /* * Declarations for various library procedures and variables (don't want * to include tkInt.h or tkConfig.h here, because people might copy this * file out of the Tk source directory to make their own modified versions). */ extern void exit _ANSI_ARGS_((int status)); extern int isatty _ANSI_ARGS_((int fd)); /* extern int read _ANSI_ARGS_((int fd, char *buf, size_t size)); */ extern char * strrchr _ANSI_ARGS_((CONST char *string, int c)); /* * Global variables used by the main program: */ static Tk_Window mainWindow; /* The main window for the application. If * NULL then the application no longer * exists. */ static Tcl_Interp *interp; /* Interpreter for this application. */ char *tcl_RcFileName ; /* Name of a user-specific startup script * to source if the application is being run * interactively (e.g. "~/.wishrc"). Set * by Tcl_AppInit. NULL means don't source * anything ever. */ static Tcl_DString command; /* Used to assemble lines of terminal input * into Tcl commands. */ static int gotPartial = 0; /* Partial command in buffer. */ static int tty; /* Non-zero means standard input is a * terminal-like device. Zero means it's * a file. */ static char exitCmd[] = "exit"; static char errorExitCmd[] = "exit 1"; /* * Command-line options: */ static int synchronize = 0; static char *fileName = NULL; static char *name = NULL; static char *display = NULL; static char *geometry = NULL; static Tk_ArgvInfo argTable[] = { {"-file", TK_ARGV_STRING, (char *) NULL, (char *) &fileName, "File from which to read commands"}, {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry, "Initial geometry for window"}, {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display, "Display to use"}, {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name, "Name to use for application"}, {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize, "Use synchronous mode for display server"}, {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL, (char *) NULL} }; /* * Forward declarations for procedures defined later in this file: */ static void StdinProc _ANSI_ARGS_((ClientData clientData, int mask)); static void SignalProc _ANSI_ARGS_((int signalNum)); /* *---------------------------------------------------------------------- * * TkX_Wish -- * * Main program for Wish. * * Results: * None. This procedure never returns (it exits the process when * it's done * * Side effects: * This procedure initializes the wish world and then starts * interpreting commands; almost anything could happen, depending * on the script being interpreted. * *---------------------------------------------------------------------- */ void TkX_Wish (argc, argv) int argc; /* Number of arguments. */ char **argv; /* Array of argument strings. */ { char *args, *p, *msg; char buf[20]; int code; interp = Tcl_CreateInterp(); #ifdef TCL_MEM_DEBUG Tcl_InitMemory(interp); #endif /* * Parse command-line arguments. */ if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, argv, argTable, 0) != TCL_OK) { fprintf(stderr, "%s\n", interp->result); exit(1); } if (name == NULL) { if (fileName != NULL) { p = fileName; } else { p = argv[0]; } name = strrchr(p, '/'); if (name != NULL) { name++; } else { name = p; } } /* * If a display was specified, put it into the DISPLAY * environment variable so that it will be available for * any sub-processes created by us. */ if (display != NULL) { Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY); } /* * Set the "tcl_interactive" variable. */ tty = isatty(hdl); Tcl_SetVar(interp, "tcl_interactive", ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); tty = isatty(hdl); /* * Initialize the Tk application. */ mainWindow = Tk_CreateMainWindow(interp, display, name, "Tk"); if (mainWindow == NULL) { fprintf(stderr, "%s\n", interp->result); exit(1); } Tk_SetClass(mainWindow, "Tk"); if (synchronize) { XSynchronize(Tk_Display(mainWindow), True); } Tk_GeometryRequest(mainWindow, 200, 200); /* * Make command-line arguments available in the Tcl variables "argc" * and "argv". Also set the "geometry" variable from the geometry * specified on the command line. */ args = Tcl_Merge(argc-1, argv+1); Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); ckfree(args); sprintf(buf, "%d", argc-1); Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], TCL_GLOBAL_ONLY); if (geometry != NULL) { Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY); } /* * Invoke application-specific initialization. */ if (Tcl_AppInit(interp) != TCL_OK) { TclX_ErrorExit (interp, 255); } /* * Set the geometry of the main window, if requested. */ if (geometry != NULL) { code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL); if (code != TCL_OK) { fprintf(stderr, "%s\n", interp->result); } } /* * Invoke the script specified on the command line, if any. */ if (fileName != NULL) { code = Tcl_VarEval(interp, "source ", fileName, (char *) NULL); if (code != TCL_OK) { goto error; } tty = 0; } else { TclX_EvalRCFile (interp); /* * Commands will come from standard input. Set up a handler * to receive those characters and print a prompt if the input * device is a terminal. */ tclErrorSignalProc = SignalProc; Tk_CreateFileHandler(hdl, TK_READABLE, StdinProc, (ClientData) 0); if (tty) { TclX_OutputPrompt (interp, 1); } } tclSignalBackgroundError = Tk_BackgroundError; fflush(stdout); Tcl_DStringInit(&command); /* * Loop infinitely, waiting for commands to execute. When there * are no windows left, Tk_MainLoop returns and we exit. */ Tk_MainLoop(); /* * Don't exit directly, but rather invoke the Tcl "exit" command. * This gives the application the opportunity to redefine "exit" * to do additional cleanup. */ Tcl_GlobalEval(interp, exitCmd); exit(1); error: msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (msg == NULL) { msg = interp->result; } fprintf(stderr, "%s\n", msg); Tcl_GlobalEval(interp, errorExitCmd); exit (1); } /* *---------------------------------------------------------------------- * * SignalProc -- * * Function called on a signal generating an error to clear the stdin * buffer. *---------------------------------------------------------------------- */ static void SignalProc (signalNum) int signalNum; { tclGotErrorSignal = 0; Tcl_DStringFree (&command); gotPartial = 0; if (tty) { fputc ('\n', stdout); TclX_OutputPrompt (interp, !gotPartial); } } /* *---------------------------------------------------------------------- * * StdinProc -- * * This procedure is invoked by the event dispatcher whenever * standard input becomes readable. It grabs the next line of * input characters, adds them to a command being assembled, and * executes the command if it's complete. * * Results: * None. * * Side effects: * Could be almost arbitrary, depending on the command that's * typed. * *---------------------------------------------------------------------- */ #define BUFFER_SIZE 4000 static void StdinProc(clientData, mask) ClientData clientData; /* Not used. */ int mask; /* Not used. */ { char input[BUFFER_SIZE+1]; char *cmd; int code, count; count = read(hdl, input, BUFFER_SIZE); if (count <= 0) { if (!gotPartial) { if (tty) { Tcl_VarEval(interp, "exit", (char *) NULL); exit(1); } else { Tk_DeleteFileHandler(hdl); } return; } else { count = 0; } } cmd = Tcl_DStringAppend(&command, input, count); fprintf(stderr, "TK command : %s\n", cmd); fflush(stderr); if (count != 0) { if ((input[count-1] != '\n') && (input[count-1] != ';')) { gotPartial = 1; goto exitPoint; } if (!Tcl_CommandComplete(cmd)) { fprintf(stderr, "Partial command\n", cmd); fflush(stderr); gotPartial = 1; goto exitPoint; } } gotPartial = 0; /* * Disable the stdin file handler; otherwise if the command * re-enters the event loop we might process commands from * stdin before the current command is finished. Among other * things, this will trash the text of the command being evaluated. */ Tk_CreateFileHandler(hdl, 0, StdinProc, (ClientData) 0); code = Tcl_RecordAndEval(interp, cmd, 0); Tk_CreateFileHandler(hdl, TK_READABLE, StdinProc, (ClientData) 0); if (tty) TclX_PrintResult (interp, code, cmd); else { char buf[1024]; sprintf(buf, "%d %s", code, interp->result); sock_write(hdl, buf, strlen(buf)); kill(parent, SIGUSR1); } Tcl_DStringFree(&command); exitPoint: if (tty) { TclX_OutputPrompt (interp, !gotPartial); } } gcl/gcl-tk/tkl.lisp000077500000000000000000001375171242227143400145110ustar00rootroot00000000000000;; Copyright (C) 1994 W. Schelter ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL 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 Library General Public ;; License for more details. ;; (eval-when (load eval compile) (in-package "TK") ) (eval-when (compile) (proclaim '(ftype (function (t fixnum fixnum) fixnum) set-message-header get-number-string)) (proclaim '(ftype (function (t t fixnum) t) store-circle)) (proclaim '(ftype (function (t fixnum) t) get-circle)) (proclaim '(ftype (function (t fixnum fixnum fixnum) fixnum) push-number-string)) ) (defvar *tk-package* (find-package "TK")) (eval-when (compile eval load) (defconstant *header* '(magic1 magic2 type flag body-length nil nil msg-index nil nil)) ;;enum print_arglist_codes {..}; (defvar *print-arglist-codes* '( normal no_leading_space join_follows end_join begin_join begin_join_no_leading_space no_quote no_quote_no_leading_space no_quote_downcase no_quotes_and_no_leading_space )) (defconstant *mtypes* '( m_not_used m_create_command m_reply m_call m_tcl_command m_tcl_command_wait_response m_tcl_clear_connection m_tcl_link_text_variable m_set_lisp_loc m_tcl_set_text_variable m_tcl_unlink_text_variable m_lisp_eval m_lisp_eval_wait_response )) (defconstant *magic1* #\) (defconstant *magic2* #\A) (defvar *some-fixnums* (make-array 3 :element-type 'fixnum)) (defmacro msg-index () `(the fixnum (aref (the (array fixnum) *some-fixnums*) 0))) ;;; (defmacro safe-car (x) ;;; (cond ((symbolp x) `(if (consp ,x) (car ,x) (if (null ,x) nil ;;; (not-a-cons ,x)))) ;;; (t (let ((sym (gensym))) ;;; `(let ((,sym ,x)) ;;; (safe-car ,sym)))))) ;;; (defmacro safe-cdr (x) ;;; (cond ((symbolp x) `(if (consp ,x) (cdr ,x) (if (null ,x) nil ;;; (not-a-cons ,x)))) ;;; (t (let ((sym (gensym))) ;;; `(let ((,sym ,x)) ;;; (safe-cdr ,sym)))))) (defun desetq-consp-check (val) (or (consp val) (error "~a is not a cons" val))) (defun desetq1 (form val) (cond ((symbolp form) (cond (form ;(push form *desetq-binds*) `(setf ,form ,val)))) ((consp form) `(progn (desetq-consp-check ,val) ,(desetq1 (car form) `(car ,val)) ,@ (if (consp (cdr form)) (list(desetq1 (cdr form) `(cdr ,val))) (and (cdr form) `((setf ,(cdr form) (cdr ,val))))))) (t (error "")))) (defmacro desetq (form val) (cond ((atom val) (desetq1 form val)) (t (let ((value (gensym))) `(let ((,value ,val)) , (desetq1 form value)))))) (defmacro while (test &body body) `(sloop while ,test do ,@ body)) ) (defmacro nth-value (n form) `(multiple-value-bind ,(make-list (+ n 1) :initial-element 'a) ,form a)) (defvar *tk-command* nil) (defvar *debugging* nil) (defvar *break-on-errors* nil) (defvar *tk-connection* nil ) ;; array of functions to be invoked from lisp. (defvar *call-backs* (make-array 20 :fill-pointer 0 :adjustable t )) ;;array of message half read. Ie read header but not body. (defvar *pending* nil) ;;circular array for replies,requests esp for debugging ;; replies is used for getting replies. (defvar *replies* (make-array (expt 2 7)) "circle of replies to requests in *requests*") ;; these are strings (defvar *requests* (make-array (expt 2 7))) ;; these are lisp forms (defvar *request-forms* (make-array 40)) (defvar *read-buffer* (make-array 400 :element-type 'standard-char :fill-pointer 0 :static t)) (defvar *text-variable-locations* (make-array 10 :fill-pointer 0 :adjustable t)) (defmacro pos (flag lis) (or (member flag (symbol-value lis)) (error "~a is not in ~a" flag lis)) (position flag (symbol-value lis))) ;;; (defun p1 (a &aux tem) ;;; ;;Used for putting A into a string for sending a command to TK ;;; (cond ;;; ((and (symbolp a) (setq tem (get a 'tk-print))) ;;; (format *tk-command* tem)) ;;; ((keywordp a) ;;; (format *tk-command* "-~(~a~)" a)) ;;; ((numberp a) ;;; (format *tk-command* "~a" a)) ;;; ((stringp a) ;;; (format *tk-command* "\"~a\"" a)) ;;; ((and (consp a)(eq (car a) 'a)) ;;; (format *tk-command* "~a" (cdr a))) ;;; ((and (consp a)(eq (car a) 'd)) ;;; (format *tk-command* "~(~a~)" (cdr a))) ;;; ((and (symbolp a) ;;; (eql (aref (symbol-name a) 0) ;;; #\.)) ;;; (format *tk-command* "~(~a~)" a)) ;;; (t (error "unrecognized term ~s" a)))) (defvar *command-strings* (sloop for i below 2 collect (make-array 200 :element-type 'standard-char :fill-pointer 0 :adjustable t))) (defvar *string-streams* (list (make-string-input-stream "") (make-string-input-stream ""))) (defmacro with-tk-command (&body body) `(let (tk-command (*command-strings* *command-strings*)) (declare (type string tk-command)) (setq tk-command (grab-tk-command)) ,@ body)) (defun grab-tk-command( &aux x) ;; keep a list of available *command-strings* and grab one (cond ((cdr *command-strings*)) (t (setq x (list (make-array 70 :element-type 'standard-char :fill-pointer 0 :adjustable t)) ) (or *command-strings* (error "how??")) (setq *command-strings* (nconc *command-strings* x)))) (let ((x (car *command-strings*))) (setq *command-strings* (cdr *command-strings*)) (setf (fill-pointer x ) #.(length *header*)) x )) (defun print-to-string (str x code) (cond ((consp x) (cond ((eq (car x) 'a) (setq x (cdr x) code (pos no_quote *print-arglist-codes*))) ((eq (car x) 'd) (setq x (cdr x) code (pos no_quote_downcase *print-arglist-codes*))) (t (error "bad arg ~a" x))))) (while (null (si::print-to-string1 str x code)) (cond ((typep x 'bignum) (setq x (format nil "~a" x))) (t (setq str (adjust-array str (the fixnum (+ (the fixnum (array-total-size str)) (the fixnum (+ (if (stringp x) (length (the string x)) 0) 70)))) :fill-pointer (fill-pointer str) :element-type 'string-char))))) str) (defmacro pp (x code) (let ((u `(pos ,code *print-arglist-codes*))) `(print-to-string tk-command ,x ,u))) (defun print-arglist (to-string l &aux v in-join x) ;; (sloop for v in l do (p :| | v)) (while l (setq v (cdr l)) (setq x (car l)) (cond ((eql (car v) ': ) (print-to-string to-string x (if in-join (pos join_follows *print-arglist-codes*) (pos begin_join *print-arglist-codes*))) (setq in-join t) (setq v (cdr v))) (in-join (print-to-string to-string x (pos end_join *print-arglist-codes*)) (setq in-join nil)) (t;; code == (pos normal *print-arglist-codes*) (print-to-string to-string x (pos normal *print-arglist-codes*)))) (setq l v) )) (defmacro p (&rest l) `(progn ,@ (sloop for v in l collect `(p1 ,v)))) (defvar *send-and-wait* nil "If not nil, then wait for answer and check result") (defun tk-call (fun &rest l &aux result-type) (with-tk-command (pp fun no_leading_space) (setq result-type (prescan-arglist l nil nil)) (print-arglist tk-command l) (cond (result-type (call-with-result-type tk-command result-type)) (t (send-tcl-cmd *tk-connection* tk-command nil) (values))))) (defun tk-do (str &rest l &aux ) (with-tk-command (pp str no_quotes_and_no_leading_space) ;; leading keyword printed without '-' at beginning. (while l (pp (car l) no_quotes_and_no_leading_space) (setq l (cdr l))) (call-with-result-type tk-command 'string))) (defun tk-do-no-wait (str &aux (n (length str))) (with-tk-command (si::copy-array-portion str tk-command 0 #.(length *header*) n) (setf (fill-pointer tk-command) (the fixnum (+ n #.(length *header*)))) (let () (send-tcl-cmd *tk-connection* tk-command nil)))) (defun send-tcl-cmd (c str send-and-wait ) ;(notice-text-variables) (or send-and-wait (setq send-and-wait *send-and-wait*)) ; (setq send-and-wait t) (vector-push-extend (code-char 0) str) (let ((msg-id (set-message-header str (if send-and-wait (pos m_tcl_command_wait_response *mtypes*) (pos m_tcl_command *mtypes*)) (the fixnum (- (length str) #.(length *header*)))))) (cond (send-and-wait (if *debugging* (store-circle *requests* (subseq str #.(length *header*)) msg-id)) (store-circle *replies* nil msg-id) (execute-tcl-cmd c str)) (t (store-circle *requests* nil msg-id) (write-to-connection c str))))) (defun send-tcl-create-command (c str) (vector-push-extend (code-char 0) str) (set-message-header str (pos m_create_command *mtypes*) (- (length str) #.(length *header*))) (write-to-connection c str)) (defun write-to-connection (con string &aux tem) (let* ((*sigusr1* t) ;; dont let us get interrupted while writing!! (n (length string)) (fd (caar con)) (m 0)) (declare (Fixnum n m)) (or con (error "Trying to write to non open connection ")) (if *debugging* (describe-message string)) (or (typep fd 'string) (error "~a is not a connection" con)) (setq m (si::our-write fd string n)) (or (eql m n) (error "Failed to write ~a bytes to file descriptor ~a" n fd)) (setq tem *sigusr1*) ;; a signal at this instruction would not be noticed...since it ;; would set *sigusr1* to :received but that would be too late for tem ;; since the old value will be popped off the binding stack at the next 'paren' ) (cond ((eq tem :received) (read-and-act nil))) t) (defun coerce-string (a) (cond ((stringp a) a) ((fixnump a) (format nil "~a" a)) ((numberp a) (format nil "~,2f" (float a))) ((keywordp a) (format nil "-~(~a~)" a)) ((symbolp a) (format nil "~(~a~)" a)) (t (error "bad type")))) ;;2 decimals (defun my-conc (a b) (setq a (coerce-string a)) (setq b (coerce-string b)) (concatenate 'string a b )) ;; In an arglist 'a : b' <==> (tk-conc a b) ;; eg: 1 : "b" <==> "1b" ; "c" : "b" <==> "cb" ; 'a : "b" <==> "ab" ; '.a : '.b <==> ".a.b" ; ':ab : "b" <==> "abb" ;;Convenience for concatenating symbols, strings, numbers ;; (tk-conc '.joe.bill ".frame.list yview " 3) ==> ".joe.bill.frame.list yview 3" (defun tk-conc (&rest l) (declare (:dynamic-extent l)) (let ((tk-command (make-array 30 :element-type 'standard-char :fill-pointer 0 :adjustable t))) (cond ((null l)) (t (pp (car l) no_quote_no_leading_space))) (setq l (cdr l)) (while (cdr l) (pp (car l) join_follows) (setq l (cdr l))) (and l (pp (car l) no_quote_no_leading_space)) tk-command )) ;;; (defun verify-list (l) ;;; (loop ;;; (cond ((null l)(return t)) ;;; ((consp l) (setq l (cdr l))) ;;; (t (error "not a true list ~s"l))))) ;;; (defun prescan-arglist (l pathname name-caller &aux result-type) ;;; (let ((v l) tem prev a b c) ;;; (verify-list l) ;;; (sloop while v ;;; do ;;; (cond ;;; ((keywordp (car v)) ;;; (setq a (car v)) ;;; (setq c (cdr v)) ;;; (setq b (car c) c (cadr c)) ;;; (cond ((eq a :bind) ;;; (cond ((setq tem (cdddr v)) ;;; (or (eq (cadr tem) ': ) ;;; (setf (car tem) ;;; (tcl-create-command (car tem) ;;; nil ;;; t)))))) ;;; ((eq c ': )) ;;; ((member a'(:yscroll :command ;;; :xscroll ;;; :yscrollcommand ;;; :xscrollcommand ;;; :scrollcommand ;;; )) ;;; (cond ((setq tem (cdr v)) ;;; (setf (car tem) ;;; (tcl-create-command (car tem) ;;; (or (get a 'command-arg) ;;; (get name-caller ;;; 'command-arg)) ;;; nil))))) ;;; ((eq (car v) :return) ;;; (setf result-type (cadr v)) ;;; (cond (prev ;;; (setf (cdr prev) (cddr v))) ;;; (t (setf (car v) '(a . "")) ;;; (setf (cdr v) (cddr v))))) ;;; ((eq (car v) :textvariable) ;;; (setf (second v) (link-variable b 'string))) ;;; ((member (car v) '(:value :onvalue :offvalue)) ;;; (let* ((va (get pathname 'variable)) ;;; (type (get va 'linked-variable-type)) ;;; (fun (cdr (get type ;;; 'coercion-functions)))) ;;; (or va ;;; (error ;;; "Must specify :variable before :value so that we know the type")) ;;; (or fun (error "No coercion-functions for type ~s" type)) ;;; (setf (cadr v) (funcall fun b)))) ;;; ((eq (car v) :variable) ;;; (let ((va (second v)) ;;; (type (cond ((eql name-caller 'checkbutton) 'boolean) ;;; (t 'string)))) ;;; (cond ((consp va) ;;; (desetq (type va) va) ;;; (or (symbolp va) ;;; (error "should be :variable (type symbol)")))) ;;; (setf (get pathname 'variable) va) ;;; (setf (second v) ;;; (link-variable va type)))) ;;; ))) ;;; (setq prev v) ;;; (setq v (cdr v)) ;;; )) ;;; result-type ;;; ) (defun prescan-arglist (l pathname name-caller &aux result-type) (let ((v l) tem prev a ) ; (verify-list l) ; unnecessary all are from &rest args. ; If pathname supplied, then this should be an alternating list ;; of keywords and values..... (sloop while v do (setq a (car v)) (cond ((keywordp a) (cond ((eq (car v) :return) (setf result-type (cadr v)) (cond (prev (setf (cdr prev) (cddr v))) (t (setf (car v) '(a . "")) (setf (cdr v) (cddr v))))) ((setq tem (get a 'prescan-function)) (funcall tem a v pathname name-caller))))) (setq prev v) (setq v (cdr v))) result-type)) (eval-when (compile eval load) (defun set-prescan-function (fun &rest l) (dolist (v l) (setf (get v 'prescan-function) fun))) ) (set-prescan-function 'prescan-bind :bind) (defun prescan-bind (x v pathname name-caller &aux tem) name-caller pathname x (cond ((setq tem (cdddr v)) (or (keywordp (car tem)) (eq (cadr tem) ': ) (setf (car tem) (tcl-create-command (car tem) nil t)))))) (set-prescan-function 'prescan-command :yscroll :command :postcommand :xscroll :yscrollcommand :xscrollcommand :scrollcommand) (defun prescan-command (x v pathname name-caller &aux tem arg) x pathname (setq arg (cond (( member v '(:xscroll :yscrollcommand :xscrollcommand :scrollcommand)) 'aaaa) ((get name-caller 'command-arg)))) (cond ((setq tem (cdr v)) (cond ((eq (car tem) :return ) :return) (t (setf (car tem) (tcl-create-command (car tem) arg nil))))))) (defun prescan-value (a v pathname name-caller) a name-caller (let* ((va (get pathname ':variable)) (type (get va 'linked-variable-type)) (fun (cdr (get type 'coercion-functions)))) (or va (error "Must specify :variable before :value so that we know the type")) (or fun (error "No coercion-functions for type ~s" type)) (setq v (cdr v)) (if v (setf (car v) (funcall fun (car v)))))) (set-prescan-function 'prescan-value :value :onvalue :offvalue) (set-prescan-function #'(lambda (a v pathname name-caller) a (let ((va (second v)) (type (cond ((eql name-caller 'checkbutton) 'boolean) (t 'string)))) (cond ((consp va) (desetq (type va) va) (or (symbolp va) (error "should be :variable (type symbol)")))) (cond (va (setf (get pathname a) va) (setf (second v) (link-variable va type)))))) :variable :textvariable) (defun make-widget-instance (pathname widget) ;; ??make these not wait for response unless user is doing debugging.. (or (symbolp pathname) (error "must give a symbol")) #'(lambda ( &rest l &aux result-type (option (car l))) (declare (:dynamic-extent l)) (setq result-type (prescan-arglist l pathname widget)) (if (and *break-on-errors* (not result-type)) (store-circle *request-forms* (cons pathname (copy-list l)) (msg-index))) (with-tk-command (pp pathname no_leading_space) ;; the leading keyword gets printed with no leading - (or (keywordp option) (error "First arg to ~s must be an option keyword not ~s" pathname option )) (pp option no_quote) (setq l (cdr l)) ;(print (car l)) (cond ((and (keywordp (car l)) (not (eq option :configure)) (not (eq option :config)) (not (eq option :itemconfig)) (not (eq option :cget)) (not (eq option :postscript)) ) (pp (car l) no_quote) (setq l (cdr l)))) (print-arglist tk-command l) (cond (result-type (call-with-result-type tk-command result-type)) (t (send-tcl-cmd *tk-connection* tk-command nil) (values)))))) (defmacro def-widget (widget &key (command-arg 'sssss)) `(eval-when (compile eval load) (setf (get ',widget 'command-arg) ',command-arg) (defun ,widget (pathname &rest l)(declare (:dynamic-extent l)) (widget-function ',widget pathname l)))) ;; comand-arg "asaa" means pass second arg back as string, and others not quoted ;; ??make these always wait for response ;; since creating a window failure is likely to cause many failures. (defun widget-function (widget pathname l ) (or (symbolp pathname) (error "First arg to ~s must be a symbol not ~s" widget pathname)) (if *break-on-errors* (store-circle *request-forms* (cons pathname (copy-list l)) (msg-index))) (prescan-arglist l pathname widget) (with-tk-command (pp widget no_leading_space) (pp pathname normal) (print-arglist tk-command l ) (multiple-value-bind (res success) (send-tcl-cmd *tk-connection* tk-command t) (if success (setf (symbol-function pathname) (make-widget-instance pathname widget)) (error "Cant define ~(~a~) pathnamed ~(~a~): ~a" widget pathname res))) pathname)) (def-widget button) (def-widget listbox) (def-widget scale :command-arg a) (def-widget canvas) (def-widget menu) (def-widget scrollbar) (def-widget checkbutton) (def-widget menubutton) (def-widget text) (def-widget entry) (def-widget message) (def-widget frame) (def-widget label) (def-widget |image create photo|) (def-widget |image create bitmap|) (def-widget radiobutton) (def-widget toplevel) (defmacro def-control (name &key print-name before) (cond ((null print-name )(setq print-name name)) (t (setq print-name (cons 'a print-name)))) `(defun ,name (&rest l) ,@ (if before `((,before ',print-name l))) (control-function ',print-name l))) (defun call-with-result-type (tk-command result-type) (multiple-value-bind (res suc) (send-tcl-cmd *tk-connection* tk-command t) (values (if result-type (coerce-result res result-type) res) suc))) (defun control-function (name l &aux result-type) ;(store-circle *request-forms* (cons name l) (msg-index)) (setq result-type (prescan-arglist l nil name)) (with-tk-command (pp name normal) ;; leading keyword printed without '-' at beginning. (cond ((keywordp (car l)) (pp (car l) no_quote) (setq l (cdr l)))) (print-arglist tk-command l) (call-with-result-type tk-command result-type))) (dolist (v '( |%%| |%#| |%a| |%b| |%c| |%d| |%f| |%h| |%k| |%m| |%o| |%p| |%s| |%t| |%v| |%w| |%x| |%y| |%A| |%B| |%D| |%E| |%K| |%N| |%R| |%S| |%T| |%W| |%X| |%Y|)) (progn (setf (get v 'event-symbol) (symbol-name v)) (or (member v '(|%d| |%m| |%p| |%K| ;|%W| |%A|)) (setf (get v 'event-symbol) (cons (get v 'event-symbol) 'fixnum ))))) (defvar *percent-symbols-used* nil) (defun get-per-cent-symbols (expr) (cond ((atom expr) (and (symbolp expr) (get expr 'event-symbol) (pushnew expr *percent-symbols-used*))) (t (get-per-cent-symbols (car expr)) (setq expr (cdr expr)) (get-per-cent-symbols expr)))) (defun reserve-call-back ( &aux ind) (setq ind (fill-pointer *call-backs*)) (vector-push-extend nil *call-backs* ) ind) ;; The command arg: ;; For bind windowSpec SEQUENCE COMMAND ;; COMMAND is called when the event SEQUENCE occurs to windowSpec. ;; If COMMAND is a symbol or satisfies (functionp COMMAND), then ;; it will be funcalled. The number of args supplied in this ;; case is determined by the widget... for example a COMMAND for the ;; scale widget will be supplied exactly 1 argument. ;; If COMMAND is a string then this will be passed to the graphics ;; interpreter with no change, ;; This allows invoking of builtin functionality, without bothering the lisp process. ;; If COMMAND is a lisp expression to eval, and it may reference ;; details of the event via the % constructs eg: %K refers to the keysym ;; of the key pressed (case of BIND only). A function whose body is the ;; form, will actually be constructed which takes as args all the % variables ;; actually appearing in the form. The body of the function will be the form. ;; Thus (print (list |%w| %W) would turn into #'(lambda(|%w| %W) (print (list |%w| %W))) ;; and when invoked it would be supplied with the correct args. (defvar *arglist* nil) (defun tcl-create-command (command arg-data allow-percent-data) (with-tk-command (cond ((or (null command) (equal command "")) (return-from tcl-create-command "")) ((stringp command) (return-from tcl-create-command command))) (let (*percent-symbols-used* tem ans name ind) (setq ind (reserve-call-back)) (setq name (format nil "callback_~d" ind)) ;; install in tk the knowledge that callback_ind will call back to here. ;; and tell it arg types expected. ;; the percent commands are handled differently (push-number-string tk-command ind #.(length *header*) 3) (setf (fill-pointer tk-command) #.(+ (length *header*) 3)) (if arg-data (pp arg-data no_leading_space)) (send-tcl-create-command *tk-connection* tk-command) (if (and arg-data allow-percent-data) (error "arg data and percent data not allowed")) (cond ((or (symbolp command) (functionp command))) (allow-percent-data (get-per-cent-symbols command) (and *percent-symbols-used* (setq ans "")) (sloop for v in *percent-symbols-used* do (setq tem (get v 'event-symbol)) (cond ((stringp tem) (setq ans (format nil "~a \"~a\"" ans tem))) ((eql (cdr tem) 'fixnum) (setq ans (format nil "~a ~a" ans (car tem)))) (t (error "bad arg")))) (if ans (setq ans (concatenate 'string "{(" ans ")}"))) (setq command `(lambda ,*percent-symbols-used* ,command)) (if ans (setq name (concatenate 'string "{"name " " ans"}")))) (t (setq command `(lambda (&rest *arglist*) ,command)))) (setf (aref *call-backs* ind) command) ;; the command must NOT appear as "{[...]}" or it will be eval'd. (cons 'a name) ))) (defun bind (window-spec &optional sequence command type) "command may be a function name, or an expression which may involve occurrences of elements of *percent-symbols* The expression will be evaluated in an enviroment in which each of the % symbols is bound to the value of the corresponding event value obtained from TK." (cond ((equal sequence :return) (setq sequence nil) (setq command nil))) (cond ((equal command :return) (or (eq type 'string) (tkerror "bind only returns type string")) (setq command nil)) (command (setq command (tcl-create-command command nil t)))) (with-tk-command (pp 'bind no_leading_space) (pp window-spec normal) (and sequence (pp sequence normal)) (and command (pp command normal)) (send-tcl-cmd *tk-connection* tk-command (or (null sequence)(null command))))) (defmacro tk-connection-fd (x) `(caar ,x)) (def-control after) (def-control exit) (def-control lower) (def-control place) (def-control send) (def-control tkvars) (def-control winfo) (def-control focus) (def-control option) (def-control raise) (def-control tk) ;; problem on waiting. Waiting for dialog to kill self ;; wont work because the wait blocks even messages which go ;; to say to kill... ;; must use ;; (grab :set :global .fo) ;; and sometimes the gcltkaux gets blocked and cant accept input when ;; in grabbed state... (def-control tkwait) (def-control wm) (def-control destroy :before destroy-aux) (def-control grab) (def-control pack) (def-control selection) (def-control tkerror) (def-control update) (def-control tk-listbox-single-select :print-name "tk_listboxSingleSelect") (def-control tk-menu-bar :print-name "tk_menuBar") (def-control tk-dialog :print-name "tk_dialog") (def-control get_tag_range) (def-control lsearch) (def-control lindex) (defun tk-wait-til-exists (win) (tk-do (tk-conc "if ([winfo exists " win " ]) { } else {tkwait visibility " win "}"))) (defun destroy-aux (name l) name (dolist (v l) (cond ((stringp v)) ((symbolp v) (dolist (prop '(:variable :textvariable)) (remprop v prop)) (fmakunbound v) ) (t (error "not a pathname : ~s" v)))) ) (defvar *default-timeout* (* 100 internal-time-units-per-second)) (defun execute-tcl-cmd (connection cmd) (let (id tem (time *default-timeout*)) (declare (fixnum time)) (setq id (get-number-string cmd (pos msg-index *header*) 3)) (store-circle *replies* nil id) (write-to-connection connection cmd) (loop (cond ((setq tem (get-circle *replies* id)) (cond ((or (car tem) (null *break-on-errors*)) (return-from execute-tcl-cmd (values (cdr tem) (car tem)))) (t (cerror "Type :r to continue" "Cmd failed: ~a : ~a " (subseq cmd (length *header*) (- (length cmd) 1) ) (cdr tem)) (return (cdr tem)) )))) (cond ((> (si::check-state-input (tk-connection-fd connection) 10) 0) (read-and-act id) )) (setq time (- time 10)) (cond ((< time 0) (cerror ":r resumes waiting for *default-timeout*" "Did not get a reply for cmd ~a" cmd) (setq time *default-timeout*) ))))) (defun push-number-string (string number ind bytes ) (declare (fixnum ind number bytes)) ;; a number #xabcdef is stored "" where is (code-char #xef) (declare (string string)) (declare (fixnum number bytes )) (sloop while (>= bytes 1) do (setf (aref string ind) (the character (code-char (the fixnum(logand number 255))))) (setq ind (+ ind 1)) (setq bytes (- bytes 1)) ; (setq number (* number 256)) (setq number (ash number -8)) nil)) (defun get-number-string (string start bytes &aux (number 0)) ;; a number #xabcdef is stored "" where is (code-char #xef) (declare (string string)) (declare (fixnum number bytes start)) (setq start (+ start (the fixnum (- bytes 1)))) (sloop while (>= bytes 1) do (setq number (+ number (char-code (aref string start)))) (setq start (- start 1) bytes (- bytes 1)) (cond ((> bytes 0) (setq number (ash number 8))) (t (return number))))) (defun quit () (tkdisconnect) (bye)) (defun debugging (x) (setq *debugging* x)) (defmacro dformat (&rest l) `(if *debugging* (dformat1 ,@l))) (defun dformat1 (&rest l) (declare (:dynamic-extent l)) (format *debug-io* "~%Lisp:") (apply 'format *debug-io* l)) (defvar *sigusr1* nil) ;;??NOTE NOTE we need to make it so that if doing code inside an interrupt, ;;then we do NOT do a gc for relocatable. This will kill US. ;;One hack would be that if relocatable is low or cant be grown.. then ;;we just set a flag which says run our sigusr1 code at the next cons... ;;and dont do anything here. Actually we can always grow relocatable via sbrk, ;;so i think it is ok.....??...... (defun system::sigusr1-interrupt (x) x (cond (*sigusr1* (setq *sigusr1* :received)) (*tk-connection* (let ((*sigusr1* t)) (dformat "Received SIGUSR1. ~a" (if (> (si::check-state-input (tk-connection-fd *tk-connection*) 0) 0) "" "No Data left there.")) ;; we put 4 here to wait for a bit just in case ;; data comes (si::check-state-input (tk-connection-fd *tk-connection*) 4 ) (read-and-act nil))))) (setf (symbol-function 'si::SIGIO-INTERRUPT) (symbol-function 'si::sigusr1-interrupt)) (defun store-circle (ar reply id) (declare (type (array t) ar) (fixnum id)) (setf (aref ar (the fixnum (mod id (length ar)))) reply)) (defun get-circle (ar id) (declare (type (array t) ar) (fixnum id)) (aref ar (the fixnum (mod id (length ar))))) (defun decode-response (str &aux reply-from ) (setq reply-from (get-number-string str #.(+ 1 (length *header*)) 3)) (values (subseq str #.(+ 4 (length *header*))) (eql (aref str #.(+ 1 (length *header*))) #\0) reply-from (get-circle *requests* reply-from))) (defun describe-message (vec) (let ((body-length (get-number-string vec (pos body-length *header*) 3)) (msg-index (get-number-string vec (pos msg-index *header*) 3)) (mtype (nth (char-code (aref vec (pos type *header*))) *mtypes*)) success from-id requ ) (format t "~%Msg-id=~a, type=~a, leng=~a, " msg-index mtype body-length) (case mtype (m_reply (setq from-id (get-number-string vec #.(+ 1 (length *header*)) 3)) (setq success (eql (aref vec #.(+ 0 (length *header*))) #\0)) (setq requ (get-circle *requests* from-id)) (format t "result-code=~a[bod:~s](form msg ~a)[hdr:~s]" success (subseq vec #.(+ 4 (length *header*))) from-id (subseq vec 0 (length *header*)) ) ) ((m_create_command m_call m_lisp_eval m_lisp_eval_wait_response) (let ((islot (get-number-string vec #.(+ 0 (length *header*)) 3))) (format t "islot=~a(callback_~a), arglist=~s" islot islot (subseq vec #.(+ 3 (length *header*)))))) ((m_tcl_command m_tcl_command_wait_response M_TCL_CLEAR_CONNECTION ) (format t "body=[~a]" (subseq vec (length *header*)) )) ((m_tcl_set_text_variable) (let* ((bod (subseq vec (length *header*))) (end (position (code-char 0) bod)) (var (subseq bod 0 end))) (format t "name=~s,val=[~a],body=" var (subseq bod (+ 1 end) (- (length bod) 1)) bod))) ((m_tcl_link_text_variable m_tcl_unlink_text_variable m_set_lisp_loc) (let (var (islot (get-number-string vec #.(+ 0 (length *header*)) 3))) (format t "array_slot=~a,name=~s,type=~s body=[~a]" islot (setq var (aref *text-variable-locations* islot)) (get var 'linked-variable-type) (subseq vec #.(+ 3 (length *header*)))))) (otherwise (error "unknown message type ~a [~s]" mtype vec ))))) (defun clear-tk-connection () ;; flush both sides of connection and discard any partial command. (cond (*tk-connection* (si::clear-connection-state (car (car *tk-connection*))) (setq *pending* nil) (with-tk-command (set-message-header tk-command (pos m_tcl_clear_connection *mtypes*) 0) (write-to-connection *tk-connection* tk-command)) ))) (defun read-tk-message (ar connection timeout &aux (n-read 0)) (declare (fixnum timeout n-read) (string ar)) (cond (*pending* (read-message-body *pending* connection timeout))) (setq n-read(si::our-read-with-offset (tk-connection-fd connection) ar 0 #.(length *header*) timeout)) (setq *pending* ar) (cond ((not (eql n-read #.(length *header*))) (cond ((< n-read 0) (tkdisconnect) (cerror ":r to resume " "Read got an error, have closed connection")) (t (error "Bad tk message")))) (t (or (and (eql (aref ar (pos magic1 *header*)) *magic1*) (eql (aref ar (pos magic2 *header*)) *magic2*)) (error "Bad magic")) (read-message-body ar connection timeout)))) (defun read-message-body (ar connection timeout &aux (m 0) (n-read 0)) (declare (fixnum m n-read)) (setq m (get-number-string ar (pos body-length *header*) 3)) (or (>= (array-total-size ar) (the fixnum (+ m #.(length *header*)))) (setq ar (adjust-array ar (the fixnum (+ m 40))))) (cond (*pending* (setq n-read (si::our-read-with-offset (tk-connection-fd connection) ar #.(length *header*) m timeout)) (setq *pending* nil) (or (eql n-read m) (error "Failed to read ~a bytes" m)) (setf (fill-pointer ar) (the fixnum (+ m #.(length *header*)))))) (if *debugging* (describe-message ar)) ar) (defun tkdisconnect () (cond (*tk-connection* (si::close-sd (caar *tk-connection*)) (si::close-fd (cadr *tk-connection*)))) (setq *sigusr1* t);; disable it... (setq *pending* nil) (setf *tk-connection* nil) ) (defun read-and-act (id) id (when *tk-connection* (let* ((*sigusr1* t) tem fun string) (with-tk-command (tagbody TOP (or (> (si::check-state-input (tk-connection-fd *tk-connection*) 0) 0) (return-from read-and-act)) (setq string (read-tk-message tk-command *tk-connection* *default-timeout*)) (let ((type (char-code (aref string (pos type *header*)))) from-id success) (case type (#.(pos m_reply *mtypes*) (setq from-id (get-number-string tk-command #.(+ 1 (length *header*)) 3)) (setq success (eql (aref tk-command #.(+ 0 (length *header*))) #\0)) (cond ((and (not success) *break-on-errors* (not (get-circle *requests* from-id))) (cerror ":r to resume ignoring" "request ~s failed: ~s" (or (get-circle *request-forms* from-id) "") (subseq tk-command #.(+ 4 (length *header*)))))) (store-circle *replies* (cons success (if (eql (length tk-command) #.(+ 4 (length *header*))) "" (subseq tk-command #.(+ 4 (length *header*))))) from-id)) (#.(pos m_call *mtypes*) ;; Can play a game of if read-and-act called with request-id: ;; When we send a request which waits for an m_reply, we note ;; at SEND time, the last message id received from tk. We ;; dont process any funcall's with lower id than this id, ;; until after we get the m_reply back from tk. (let ((islot (get-number-string tk-command #.(+ 0 (length *header*))3)) (n (length tk-command))) (declare (fixnum islot n)) (setq tem (our-read-from-string tk-command #.(+ 0 (length *header*)3))) (or (< islot (length *call-backs*)) (error "out of bounds call back??")) (setq fun (aref (the (array t) *call-backs*) islot)) (cond ((equal n #.(+ 3 (length *header*))) (funcall fun)) (t (setq tem (our-read-from-string tk-command #.(+ 3(length *header*)))) (cond ((null tem) (funcall fun)) ((consp tem) (apply fun tem)) (t (error "bad m_call message "))))))) (#.(pos m_set_lisp_loc *mtypes*) (let* ((lisp-var-id (get-number-string tk-command #.(+ 0 (length *header*)) 3)) (var (aref *text-variable-locations* lisp-var-id)) (type (get var 'linked-variable-type)) val) (setq val (coerce-result (subseq tk-command #.(+ 3 (length *header*))) type)) (setf (aref *text-variable-locations* (the fixnum ( + lisp-var-id 1))) val) (set var val))) (otherwise (format t "Unknown response back ~a" tk-command))) (if (eql *sigusr1* :received) (dformat "<>")) (go TOP) )))))) (defun our-read-from-string (string start) (let* ((s (car *string-streams*)) (*string-streams* (cdr *string-streams*))) (or s (setq s (make-string-input-stream ""))) (si::reset-string-input-stream s string start (length string)) (read s nil nil))) (defun atoi (string) (if (numberp string) string (our-read-from-string string 0))) (defun conc (a b &rest l &aux tem) (declare (:dynamic-extent l)) (sloop do (or (symbolp a) (error "not a symbol ~s" a)) ; (or (symbolp b) (error "not a symbol ~s" b)) (cond ((setq tem (get a b))) (t (setf (get a b) (setq tem (intern (format nil "~a~a" a b) *tk-package* ))))) while l do (setq a tem b (car l) l (cdr l))) tem) (defun dpos (x) (wm :geometry x "+60+25")) (defun string-list (x) (let ((tk-command (make-array 30 :element-type 'standard-char :fill-pointer 0 :adjustable t))) (string-list1 tk-command x) tk-command)) (defun string-list1 (tk-command l &aux x) ;; turn a list into a tk list (desetq (x . l) l) (pp x no_leading_space) (while l (desetq (x . l) l) (cond ((atom x) (pp x normal)) ((consp x) (pp "{" no_quote) (string-list1 tk-command x) (pp '} no_leading_space))))) (defun list-string (x &aux (brace-level 0) skipping (ch #\space) (n (length x)) ) (declare (Fixnum brace-level n) (string x) (character ch)) (if (eql n 0) (return-from list-string nil)) (sloop for i below n with beg = 0 and ans do (setq ch (aref x i)) (cond ((eql ch #\space) (cond (skipping nil) ((eql brace-level 0) (if (> i beg) (setq ans (cons (subseq x beg i) ans))) (setq beg (+ i 1)) ))) (t (cond (skipping (setq skipping nil) (setq beg i))) (case ch (#\{ (cond ((eql brace-level 0) (setq beg (+ i 1)))) (incf brace-level)) (#\} (cond ((eql brace-level 1) (setq ans (cons (subseq x beg i) ans)) (setq skipping t))) (incf brace-level -1))))) finally (unless skipping (setq ans (cons (subseq x beg i) ans))) (return (nreverse ans)) )) ;; unless keyword :integer-value, :string-value, :list-strings, :list-forms ;; (foo :return 'list) "ab 2 3" --> (ab 2 3) ;; (foo :return 'list-strings) "ab 2 3" --> ("ab" "2" "3") ;;ie ;; (foo :return 'string) "ab 2 3" --> "ab 2 3" ;; (foo :return 't) "ab 2 3" --> AB ;; (foo :return 'boolean) "1" --> t (defun coerce-result (string key) (case key (list (our-read-from-string (tk-conc "("string ")") 0)) (string string) (number (our-read-from-string string 0)) ((t) (our-read-from-string string 0)) (t (let ((funs (get key 'coercion-functions))) (cond ((null funs) (error "Undefined coercion for type ~s" key))) (funcall (car funs) string))))) ;;convert "2c" into screen units or points or something... )) ;; If loc is suitable for handing to setf, then ;; (setf loc (coerce-result val type) ;; (radio-button (defvar *unbound-var* "") (defun link-variable (var type) (let* ((i 0) (ar *text-variable-locations*) (n (length ar)) tem ) (declare (fixnum i n) (type (array (t)) ar)) (cond ((stringp var) (return-from link-variable var)) ((symbolp var)) ((and (consp var) (consp (cdr var))) (setq type (car var)) (setq var (cadr var)))) (or (and (symbolp type) (get type 'coercion-functions)) (error "Need coercion functions for type ~s" type)) (or (symbolp var) (error "illegal text variable ~s" var)) (setq tem (get var 'linked-variable-type)) (unless (if (and tem (not (eq tem type))) (format t "~%;;Warning: ~s had type ~s, is being changed to type ~s" var tem type ))) (setf (get var 'linked-variable-type) type) (while (< i n) (cond ((eq (aref ar i) var) (return-from link-variable var)) ((null (aref ar i)) (return nil)) (t (setq i (+ i 2))))) ;; i is positioned at the write place (cond ((= i n) (vector-push-extend nil ar) (vector-push-extend nil ar))) (setf (aref ar i) var) (setf (aref ar (the fixnum (+ i 1))) (if (boundp var) (symbol-value var) *unbound-var*)) (with-tk-command (push-number-string tk-command i #.(length *header*) 3) (setf (fill-pointer tk-command) #. (+ 3 (length *header*))) (pp var no_quotes_and_no_leading_space) (vector-push-extend (code-char 0) tk-command) (set-message-header tk-command (pos m_tcl_link_text_variable *mtypes*) (- (length tk-command) #.(length *header*))) (write-to-connection *tk-connection* tk-command))) (notice-text-variables) var) (defun unlink-variable (var ) (let* ((i 0) (ar *text-variable-locations*) (n (length ar)) ) (declare (fixnum i n) (type (array (t)) ar)) (while (< i n) (cond ((eq (aref ar i) var) (setf (aref ar i) nil) (setf (aref ar (+ i 1)) nil) (return nil) ) (t (setq i (+ i 2))))) (cond ((< i n) (with-tk-command (push-number-string tk-command i #.(length *header*) 3) (setf (fill-pointer tk-command) #. (+ 3 (length *header*))) (pp var no_quotes_and_no_leading_space) (vector-push-extend (code-char 0) tk-command) (set-message-header tk-command (pos m_tcl_unlink_text_variable *mtypes*) (- (length tk-command) #.(length *header*))) (write-to-connection *tk-connection* tk-command)) var)))) (defun notice-text-variables () (let* ((i 0) (ar *text-variable-locations*) (n (length ar)) tem var type ) (declare (fixnum i n) (type (array (t)) ar)) (tagbody (while (< i n) (unless (or (not (boundp (setq var (aref ar i)))) (eq (setq tem (symbol-value var)) (aref ar (the fixnum (+ i 1))))) (setf (aref ar (the fixnum (+ i 1))) tem) (setq type (get var 'linked-variable-type)) (with-tk-command ;(push-number-string tk-command i #.(length *header*) 3) ;(setf (fill-pointer tk-command) #. (+ 3 (length *header*))) (pp var no_quote_no_leading_space) (vector-push (code-char 0) tk-command ) (case type (string (or (stringp tem) (go error))) (number (or (numberp tem) (go error))) ((t) (setq tem (format nil "~s" tem ))) (t (let ((funs (get type 'coercion-functions))) (or funs (error "no writer for type ~a" type)) (setq tem (funcall (cdr funs) tem))))) (pp tem no_quotes_and_no_leading_space) (vector-push (code-char 0) tk-command ) (set-message-header tk-command (pos m_tcl_set_text_variable *mtypes*) (- (length tk-command) #.(length *header*))) (write-to-connection *tk-connection* tk-command))) (setq i (+ i 2))) (return-from notice-text-variables) error (error "~s has value ~s which is not of type ~s" (aref ar i) tem type) ))) (defmacro setk (&rest l) `(prog1 (setf ,@ l) (notice-text-variables))) (setf (get 'boolean 'coercion-functions) (cons #'(lambda (x &aux (ch (aref x 0))) (cond ((eql ch #\0) nil) ((eql ch #\1) t) (t (error "non boolean value ~s" x)))) #'(lambda (x) (if x "1" "0")))) (setf (get 't 'coercion-functions) (cons #'(lambda (x) (our-read-from-string x 0)) #'(lambda (x) (format nil "~s" x)))) (setf (get 'string 'coercion-functions) (cons #'(lambda (x) (cond ((stringp x) x) (t (format nil "~s" x)))) 'identity)) (setf (get 'list-strings 'coercion-functions) (cons 'list-string 'list-to-string)) (defun list-to-string (l &aux (x l) v (start t)) (with-tk-command (while x (cond ((consp x) (setq v (car x))) (t (error "Not a true list ~s" l))) (cond (start (pp v no_leading_space) (setq start nil)) (t (pp v normal))) (setf x (cdr x))) (subseq tk-command #.(length *header*)))) (defvar *tk-library* nil) (defun tkconnect (&key host can-rsh gcltksrv (display (si::getenv "DISPLAY")) (args "") &aux hostid (loopback "127.0.0.1")) (if *tk-connection* (tkdisconnect)) (or display (error "DISPLAY not set")) (or *tk-library* (setq *tk-library* (si::getenv "TK_LIBRARY"))) (or gcltksrv (setq gcltksrv (cond (host "gcltksrv") ((si::getenv "GCL_TK_SERVER")) ((probe-file (tk-conc si::*lib-directory* "/gcl-tk/gcltksrv"))) ((probe-file (tk-conc si::*lib-directory* "gcl-tk/gcltksrv"))) (t (error "Must setenv GCL_TK_SERVER "))))) (let ((pid (if host -1 (si::getpid))) (tk-socket (si::open-named-socket 0)) ) (cond ((not host) (setq hostid loopback)) (host (setq hostid (si::hostname-to-hostid (si::gethostname))))) (or hostid (error "Can't find my address")) (setq tk-socket (si::open-named-socket 0)) (if (pathnamep gcltksrv) (setq gcltksrv (namestring gcltksrv))) (let ((command (tk-conc gcltksrv " " hostid " " (cdr tk-socket) " " pid " " display " " args ))) (print command) (cond ((not host) (system command)) (can-rsh (system (tk-conc "rsh " host " " command " < /dev/null &"))) (t (format t "Waiting for you to invoke GCL_TK_SERVER, on ~a as in: ~s~%" host command ))) (let ((ar *text-variable-locations*)) (declare (type (array (t)) ar)) (sloop for i below (length ar) by 2 do (remprop (aref ar i) 'linked-variable-type))) (setf (fill-pointer *text-variable-locations*) 0) (setf (fill-pointer *call-backs*) 0) (setq *tk-connection* (si::accept-socket-connection tk-socket )) (if (eql pid -1) (si::SET-SIGIO-FOR-FD (car (car *tk-connection*)))) (setf *sigusr1* nil) (tk-do (tk-conc "source " si::*lib-directory* "gcl-tk/gcl.tcl")) ))) (defun children (win) (let ((ans (list-string (winfo :children win)))) (cond ((null ans) win) (t (cons win (mapcar 'children ans)))))) ;; read nth item from a string in (defun nth-a (n string &optional (separator #\space) &aux (j 0) (i 0) (lim (length string)) ans) (declare (fixnum j n i lim)) (while (< i lim) (cond ((eql j n) (setq ans (our-read-from-string string i)) (setq i lim)) ((eql (aref string i) separator) (setq j (+ j 1)))) (setq i (+ i 1))) ans) (defun set-message-header(vec mtype body-length &aux (m (msg-index)) ) (declare (fixnum mtype body-length m) (string vec) ) (setf (aref vec (pos magic1 *header*)) *magic1*) (setf (aref vec (pos magic2 *header*)) *magic2*) ; (setf (aref vec (pos flag *header*)) (code-char (make-flag flags))) (setf (aref vec (pos type *header*)) (code-char mtype)) (push-number-string vec body-length (pos body-length *header*) 3) (push-number-string vec m (pos msg-index *header*) 3) (setf (msg-index) (the fixnum (+ m 1))) m) (defun get-autoloads (&optional (lis (directory "*.lisp")) ( out "index.lsp") &aux *paths* ) (declare (special *paths*)) (with-open-file (st out :direction :output) (format st "~%(in-package ~s)" (package-name *package*)) (dolist (v lis) (get-file-autoloads v st)) (format st "~%(in-package ~s)" (package-name *package*)) (format st "~2%~s" `(setq si::*load-path* (append ',*paths* si::*load-path*))) )) (defun get-file-autoloads (file &optional (out t) &aux (eof '(nil)) (*package* *package*) saw-package name ) (declare (special *paths*)) (setq name (pathname-name (pathname file))) (with-open-file (st file) (if (boundp '*paths*) (pushnew (namestring (make-pathname :directory (pathname-directory (truename st)))) *paths* :test 'equal)) (sloop for tem = (read st nil eof) while (not (eq tem eof)) do (cond ((and (consp tem) (eq (car tem) 'defun)) (or saw-package (format t "~%;;Warning:(in ~a) a defun not preceded by package declaration" file)) (format out "~%(~s '~s '|~a|)" 'si::autoload (second tem) name)) ((and (consp tem) (eq (car tem) 'in-package)) (setq saw-package t) (or (equal (find-package (second tem)) *package*) (format out "~%~s" tem)) (eval tem)) )))) ;; execute form return values as usual unless error ;; occurs in which case if symbol set-var is supplied, set it ;; to the tag, returning the tag. (defmacro myerrorset (form &optional set-var) `(let ((*break-enable* nil)(*debug-io* si::*null-io*) (*error-output* si::*null-io*)) (multiple-value-call 'error-set-help ',set-var (si::error-set ,form)))) (defun error-set-help (var tag &rest l) (cond (tag (if var (set var tag))) ;; got an error (t (apply 'values l)))) ;;; Local Variables: *** ;;; mode:lisp *** ;;; version-control:t *** ;;; comment-column:0 *** ;;; comment-start: ";;; " *** ;;; End: *** gcl/gcl-tk/tktst.c000077500000000000000000000126221242227143400143300ustar00rootroot00000000000000/*-*-c++-*-*/ #include #include #include #include Tcl_Interp *tcliMain; /* Main and only tcl interpreter instance */ static Tk_Window mainWindow; /* The main window for the application. If * NULL then the application no longer * exists. */ static int tty; /* Non-zero means standard input is a * terminal-like device. Zero means it's * a file. */ static int synchronize = 1; static char *szname = "TCL/TK-Scheme"; static char *szdisplay = NULL; /* "unix:0.0"; */ static Tcl_DString command; /* Used to assemble lines of terminal input * into Tcl commands. */ static int gotPartial = 0; /* Partial command in buffer. */ static char exitCmd[] = "exit"; static char errorExitCmd[] = "destroy ."; extern int isatty _ANSI_ARGS_((int fd)); /* int __TclX_AppInit(Tcl_Interp *interp) { return TCL_OK; } */ /* *---------------------------------------------------------------------- * * StdinProc -- * * This procedure is invoked by the event dispatcher whenever * standard input becomes readable. It grabs the next line of * input characters, adds them to a command being assembled, and * executes the command if it's complete. * * Results: * None. * * Side effects: * Could be almost arbitrary, depending on the command that's * typed. * *---------------------------------------------------------------------- */ static void StdinProc(ClientData clientData, int mask) { #define BUFFER_SIZE 4000 char input[BUFFER_SIZE+1]; char *cmd; int code, count; count = read(fileno(stdin), input, BUFFER_SIZE); if (count <= 0) { if (!gotPartial) { if (tty) { Tcl_VarEval(tcliMain, "exit", (char *) NULL); exit(1); } else { Tk_DeleteFileHandler(0); } return; } else { count = 0; } } cmd = Tcl_DStringAppend(&command, input, count); if (count != 0) { if ((input[count-1] != '\n') && (input[count-1] != ';')) { gotPartial = 1; goto exitPoint; } if (!Tcl_CommandComplete(cmd)) { gotPartial = 1; goto exitPoint; } } gotPartial = 0; /* * Disable the stdin file handler; otherwise if the command * re-enters the event loop we might process commands from * stdin before the current command is finished. Among other * things, this will trash the text of the command being evaluated. */ Tk_CreateFileHandler(0, 0, StdinProc, (ClientData) 0); code = Tcl_RecordAndEval(tcliMain, cmd, 0); Tk_CreateFileHandler(0, TK_READABLE, StdinProc, (ClientData) 0); if (tty) TclX_PrintResult (tcliMain, code, cmd); Tcl_DStringFree(&command); exitPoint: if (tty) { TclX_OutputPrompt (tcliMain, !gotPartial); } } /* *---------------------------------------------------------------------- * * SignalProc -- * * Function called on a signal generating an error to clear the stdin * buffer. *---------------------------------------------------------------------- */ static void SignalProc (int signalNum) { tclGotErrorSignal = 0; Tcl_DStringFree (&command); gotPartial = 0; if (tty) { fputc ('\n', stdout); TclX_OutputPrompt (tcliMain, !gotPartial); } } char *TclTkInit() { tcliMain = Tcl_CreateInterp(); mainWindow = Tk_CreateMainWindow(tcliMain, szdisplay, szname, "Tk"); if (mainWindow == NULL) fprintf(stderr, "Unable to create mainWindow : %s\n", tcliMain->result); Tk_SetClass(mainWindow, "Tk"); if (synchronize) XSynchronize(Tk_Display(mainWindow), True); Tk_GeometryRequest(mainWindow, 200, 200); /* if (__TclX_AppInit(tcliMain) != TCL_OK) TclX_ErrorExit (tcliMain, 255); */ Tcl_AppInit(tcliMain); return "."; } void TclTkMainLoop() { /* * Set the "tcl_interactive" variable. */ tty = isatty(0); Tcl_SetVar(tcliMain, "tcl_interactive", tty ? "1" : "0", TCL_GLOBAL_ONLY); /* TclX_EvalRCFile (tcliMain); */ /* * Commands will come from standard input. Set up a handler * to receive those characters and print a prompt if the input * device is a terminal. */ tclErrorSignalProc = SignalProc; Tk_CreateFileHandler(0, TK_READABLE, StdinProc, (ClientData) 0); if (tty) TclX_OutputPrompt (tcliMain, 1); Tk_MainLoop(); Tcl_GlobalEval(tcliMain, exitCmd); } main() { TclTkInit(); TclTkMainLoop(); } int Tcl_AppInit(interp) Tcl_Interp *interp; /* Interpreter for application. */ { Tk_Window main; main = Tk_MainWindow(interp); /* * Call the init procedures for included packages. Each call should * look like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * where "Mod" is the name of the module. */ if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (Tk_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (TclX_Init(interp) == TCL_ERROR) return TCL_ERROR; if (TkX_Init(interp) == TCL_ERROR) return TCL_ERROR; /* * Call Tcl_CreateCommand for application-specific commands, if * they weren't already created by the init procedures called above. */ /* * Specify a user-specific startup file to invoke if the application * is run interactively. Typically the startup file is "~/.apprc" * where "app" is the name of the application. If this line is deleted * then no user-specific startup file will be run under any conditions. */ tcl_RcFileName = "~/.wishrc"; return TCL_OK; } gcl/gcl.ico000066400000000000000000000557161242227143400131030ustar00rootroot00000000000000 èv00h^ ¨Æ 00¨n h!  ¨~%00 ¨%&6( @€€€€€€€€€€€€ÀÀÀÿÿÿÿÿÿÿÿÿÿÿÿÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌGw||ÌÌÌÌÌÌÌÌÌÌÌÿÿÿÿ‡ÌÌÌÌÌÌÌÌÌÈÿÿÿÿÿÿÿtÌÌÌÌÌÌÌÄxÿÿÿÿÿÿÿ‡ÌÌÌÌÌÌÌÌGÿÿÿÿÿÿ‡ÌÌÌÌÌÌÌGÿÿÿÿÿÿÿ|ÌÌÌÌÌGÿÿÿÿÿÿÿÿÿôÌÌÌÌÌÌDGÿÿÿÿÿÿ÷ÌÌÌÌÌÌÌÇÿÿÿÿÿÿÿ‡wÄDLÌÌÌÈÿÿÿÿÿÿÿÿˆÄtÌÌÌÄwˆÿÿÿÿÿÿÿ‡ÌÌÌÌÌÌxÿÿÿÿÿÿÿ‡ÌÌÌÌÌÌÄÿÿÿÿÿÿÿøLÌÌÌÌÄwÿÿÿÿÿÿÿÿôÌÌÌÄÿÿÿÿøwÿÿÿÿ÷ÌÌÌÇÿÿÿÿøÌÄÿÿÿÿôÌÌÌÌGÿÿŒÌÿÿÿÿŒÌÌÌĈÿÿÿ|ÌxÿÿÿÿŒÌÌÌÇÿÿÿ÷ÌÇÿÿÿÿÿLÌÌÌÌLG|ÌÿÿÿÿøÌÌÌÌÌÌøÌÌÄÿÿÿ÷ÌÌÌÌÌÄø|ÌÌÌÿÿÿŒÌÌÌÌÌÄŒÌÌÌOÿÿÿÿLÌÌÌÌÌÌÌÌÌÌGGÿ÷ÌÌÌÌÌÌÌÌÌÌÌÌÌÿŒÌÌÌÌÌÌÌÌÌÌÌÌOÿ÷ÌÌÌÌÌÌÌÌÌÌÌÌÄÿø|ÌÌÌÌÌÌÌÌÌÌÌÌÇø|ÌÌÌÌÌÌÌÌÌÌÌÌÌÇÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌ(0`€€€€€€€€€€€€€ÀÀÀÿÿÿÿÿÿÿÿÿÿÿÿÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÄGGDÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌGÿÿÿø‡DÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌxÿÿÿÿÿÿÿÿ‡ÌÌÌÌÌÌÌÌÌÌÌÌÌÇÿÿÿÿÿÿÿÿÿÿøtÌÌÌÌÌÌÌÌÌÌÌÌÿÿÿÿÿÿÿÿÿÿÿwLÌÌÌÌÌÌÌÌÌÌÄxÿÿÿÿÿÿÿÿÿÿÿ‡LÌÌÌÌÌÌÌÌÌÌÄGxÿÿÿÿÿÿÿÿÿÿ÷LÌÌÌÌÌÌÌÌÌÌÌ@ÿÿÿÿÿÿÿÿÿÿ„ÌÌÌÌÌÌÌÌÌÄGˆÿÿÿÿÿÿÿÿÿÿÿøLÌÌÌÌÌÌÌÌxÿÿÿÿÿÿÿÿÿÿÿÿÿÿ|ÌÌÌÌÌÌÌÌDwˆÿÿÿÿÿÿÿÿÿÿ„ÌÌÌÌÌÌÌÌÌÄDDÿÿÿÿÿÿÿÿÿÿôÌÌÌÌÌÌÌÌÌÌÌÇÿÿÿÿÿÿÿÿÿÿÿwvLÄDLÌÌÌÌÌÌoÿÿÿÿÿÿÿÿÿÿøÿ‡wLDÌÌÌÌÇOÿÿÿÿÿÿÿÿÿÿˆÿÿøx\DLÌÌÌÌÌÄxÿÿÿÿÿÿÿÿÿÿÿÿÿ‡ÌÄÌÌÌÌÌÌÌE6Xÿÿÿÿÿÿÿÿÿÿ‡LÌÌÌÌÌÌÌÌÌOÿÿÿÿÿÿÿÿÿÿÿ‡LÌÌÌÌÌÌÌÌÌÅÿÿÿÿÿÿÿÿÿÿ÷ ÌÌÌÌÌÌÌÌÌÇHÿÿÿÿÿÿÿÿÿÿÿø‡ÌÌÌÌÌÌÌGwxÿÿÿÿÿÿÿÿÿÿÿÿÿøLÌÌÌÌÌGÿÿÿÿÿÿÿˆwÿÿÿÿÿÿøÌÌÌÌÌÌÿÿÿÿÿÿÿw|ÄÿÿÿÿÿøÌÌÌÌÌÄÿÿÿÿÿÿ‡ÌÌHÿÿÿÿÿÿ÷ÌÌÌÌÌÌDwÿÿÿÿ|ÌÇÿÿÿÿÿÿ÷ÌÌÌÌÌÌÄGÿÿÿø|ÌÇÿÿÿÿÿÿÿôÌÌÌÌÌÌxÿÿÿÿÿ÷ÌÌÄÿÿÿÿÿÿ„ÌÌÌÌÌÄÿÿÿÿÿ|ÌÆxÿÿÿÿÿÿÿ|ÌÌÌÌÌÌGwwÿ÷LÌÈÿÿÿÿÿÿÿøLÌÌÌÌÌÌÌÌÇÿtÌÌHÿÿÿÿÿÿ÷ÌÌÌÌÌÌÌÌÌHÿ÷ÌÌÌÌWÿÿÿÿÿôÌÌÌÌÌÌÌÌÌÿtÌÌÌÌÆÿÿÿÿÿ|ÌÌÌÌÌÌÌÌÅÿ‡ÌÌÌÌÌÿÿÿÿÿø|ÌÌÌÌÌÌÌÌƇLÌÌÌÌÇÿÿÿÿÿÿ÷ÌÌÌÌÌÌÌÌÌÄÌÌÌÌÌÌHøˆÿÿÿ„ÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÄDLOÿÿølÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÄÿÿ÷ÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌXÿÿø\ÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÆÿÿ‡ÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌWÿÿ÷LÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÿøLÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÄÿˆDÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÇeLÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÌÿÿÿÿÿÿÿÿÿÿÿÿ( @mu\20Z[Ys@@m_^{UU› Ž˜œ—›™µ¹¸ ¥ª¨¯¬¤­¹³¶ºº)'!"‘-,™99Ÿ98¡! ©!!¡+*¯..µ""»$$².-®0/µ44¸67´9:¼<;º==ÈÅÂÍ ÑÕÑ Ù Þ ÖËÕÛÜäááåëáé î òõóõúþûùþõ ù þù ý àæêþýÊ##Ï&&Ç('Ú! Õ89ë##ž?@‚EE‰LM•EECC™DE—JJŠYZ‰\\__TU™QQžXX«DD¥QQªQQ­VW‹aaˆgh–ij‹uwœqqšwx§ce¡dd³hi¹ih©}}¸uv´yy×FGÒ__Ã|}Ðvu„€ƒ„„–††žŒ‹“”””¢……¨€¦ŠŠ±‡‡ªª”” œ¦œœª›š¯šš¶œš¢¢¢®¯®º¦¦°°°³´´´µµ¼»»½¾¾ÅŽÇ̲³ÄÄÃÅÅÆÍÅÅÊÊÊÍÌÍÑÏÑÖÕÕßÑÑÙÖÖØ×ØÛÛÛÝÙÙßßÞãããããäåååèæçæçèéèèïïðñññö÷öùùùûüüþþþKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK5.yzz{~]3>KKKKKKKKKKKKKKKKKKKKZ›­µµµµµµµµŠ}FKKKKKKKKKKKKKKKQ>¦µµµµµµµµµµµµµ¨|$>KKKKKKKKKKKKKK:ˆ µµµµµµµµµµµµµµ™k1KKKKKKKKKKKKKK0 p²µµµµµµµµµµµµ¨iDKKKKKKKKKKKK>#w³µµµµµµµµµµµµµµqFKKKKKKKKKK1‚³µµµµµµµµµµµµµµµµµ²#KKKKKKKKKKK0 `‚µµµµµµµµµµµµµµmKKKRKKKKKKKKKKFr²µµµµµµµµµµµµµ­†„"5 7KKKKKK^“µµµµµµµµµµµµµ¯µµµ––= KKKKKQWh’–™µµµµµµµµµµµµµµ¦aKK9KKKKKKKWK"®¨µµµµµµµµµµµµµ¢bKKKKKKKKKKKQ ®µµµµµµµµµµµµµµ“UKKKKKKKKF#_j†«µµµµµµµµµµµµµµµµµ+KKKKKKKŽ²µµµµµµµµµ¤€¯µµµµµµµµ-KKKKKKKsµµµµµµµµµœ\WFe°µµµµµµµµKKKKKKK; µµµµµ­[KP‡µµµµµµµµµ¦7KKKKKKKZŒ¦µµµµµµwKQF¦µµµµµµµµ‘KKKKKKKKg®µµµµµµ‰VK=ˆ¯µµµµµµµµµ*KKKKKKKKFµµ‹7KK.¯µµµµµµµµµŸBKKKKKKKKKKQh²µŽCKKKQµµµµµµµµoKKKKKKKKKKK­¯tDKKKKQ+¦µµµµµµµUKKKKKKKKKKKš'KKKKKK*­µµµµµµµµdKKKKKKKKKKKKKKKKKKKKK(od.uµµµµ‰PKKKKKKKKKKKKKKKKKKKKKKKK%­µµµ”3KKKKKKKKKKKKKKKKKKKKKKKK­µµµŽ9KKKKKKKKKKKKKKKKKKKKKKKK µµ¥lHKKKKKKKKKKKKKKKKKKKKKKKKQƒµ x;KKKKKKKKKKKKKKKKKKKKKKKKKKQ+>KKKKKKKKKKKKKKKKÿÿÿÿÿÿÿÿ(0` "' R_U]a |qzmifvyum+*w$$x""q))|..l>>r11y66A@?KJL[[XoGIlKLqBAuEGjOPOPlTTm\]tYYdedmcclkklmkmnnueavbdtefthgvhjvrsysr{{z†… ‹ “œ’ ‘™•ƒ‹Ž’¦¤ ¬ ·´ ± ¤£¤³¹±ºŽ .,‰))Ž*)%'%$‘-+Ž12‹7:??•3369¢!"¦,,¥96ÆÈÇ ÆÌ ÓÕÒÑÝÕ ÆËÄÃÂÌÚÜâæåìîá æ ãë òöñúþùøþñ ö ô ó öý ïûíéçãæëöûþúþøÄ%%Ï++Ø"$Ñ')Ú))È02þ##þ..þ33ÿ??…AB…FEƒLM˜DB—KK†SS†YZ“^^˜\_¥CCƒaaoo†us{|‹}{¦xx¦«´}~×ZYÊ~}}€€€ƒ€€‡Šˆ‹‹‘ŒŒ˜‰‹Ž‘”‘‘‘“”•••™–—˜—™—šššš ¹‡‡¡³œœ  Ÿ¡Ÿ ¢¢£¯¢¡©©§®­­³««°®«¶­­°¯±²²±³³µµ¶µ»±³¼³³·¸¸¹¹¹½»¼½½½Â««ÁÁ¿ÃÃÃÄÁÁÃÄÄÆÆÆÈÄÂÉÊÊËÌÊÌÌÊÍÏÎÑÎÏÑÐÑÕÕÖØÖ××Ù×ÙÙ×ÚÛÚÝÚÝÝÝÝßàßâââçæèéééìêëëìëíííññðõõõø÷øùùùûûüþþþhEU[£]LdvvL³çûÿÿÿÿÿÿÿòÔ³Z6h†¬âÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿúݵ}—ªÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿûÚ§;voÏÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿöÄ!:}v±áÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿë.;w};#Ãïÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿö1C†C+ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿà†l-ÇëÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿáAØÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ3y} 2ÇÔàçôöÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿò;zo:88òÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿöCŠ˜Šh.öÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÇ4&dvAG—ŠŠÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿóÐÿÿÿÌ¥©+Nk¢ôÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿëØÿÿÿÿÿûÃЙ›K m†—¡j®áûÿûûÿÿÿÿÿÿÿÿÿÿÿÿÿÿûÿÿÿÿÿÿÿç!H’e((Ýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿá2jŠ Š?ôÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿò#9}Š7áÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ¿m„_ÌÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÝÝÂy†J!&1,ÐûÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿéaN%ØüÿÿÿÿÿÿÿÿÿÿÿÿÿÿûÚÉËÿÿÿÿÿÿÿÿÿÿÿÿÿälhÃÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿß·¶— ^ÐÿÿÿÿÿÿÿÿÿÿÿÿØr9Êûÿÿÿÿÿÿÿÿÿÿÿÿû«†ŠG½ÿÿÿÿÿÿÿÿÿÿÿÿÿ¿z—K#4çÿÿÿÿÿÿÿÿÿÇ‘—£çÿÿÿÿÿÿÿÿÿÿÿÿÿÿ­ŠŠ™T+ÐÿÿÿÿÿÿÿÿöX—yºöÿÿÿÿÿÿÿÿÿÿÿÿÿÿW˜RÔÿÿÿÿÿÿÿÿÿÿÿ­†ŠŠCÿÿÿÿÿÿÿÿÿÿÿÿÿÝqQÌÿÿÿÿÿÿÿÿÿÿÿ¼œŸP­ëÿÿÿÿÿÿÿÿÿÿÿÿÿÿ­@&°¿¿¿¸ÿÿÿÿÄHwÌÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿöGŠwz`»ÿÿÿÃNŠqÇöÿÿÿÿÿÿÿÿÿÿÿÿÿÿÈ}Š\ÊÿÿÿÇQžT¨ØÿÿÿÿÿÿÿÿÿÿÿûV¸ÿÿÿ¯™Š}!îÿÿÿÿÿÿÿÿÿÿÿÃûÿô'sŠ—k©ûÿÿÿÿÿÿÿÿÿÿÿö\Sö´R}’1ÿÿÿÿÿÿÿÿÿÿÿÿÿ°{NJKéüòçíëÿÿÿÿÿÿÿéW‘55>Faôÿÿÿÿÿö?åÿÿÿÿÿû%w@åÿÿÿÿÿûwŠŠÜÿÿÿÿÿë$—J½ÿÿÿÿÿ½Ch)ÿÿÿÿÛ¦}Š— ôÿöÍ]aš$\PjŠÿÿÿÿÿÿÿÿÿÿÿÿ(  @©­¬­­­®­¬­«­®­©­§­§­§­§­§­§­§­§­ÿÿç]]ÿß¾¾ÿÎØØÿæÊÊÿí–˜ÿÍEEÿüÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿØ44ÿÒÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿùÿÿÿÄ´µÿ¸..ÿôÿÿÿÿÿÿÿÿÿÿÿÿÿþýkÿÆÖ×ýÿÿÿÿýýýýÿÿÿÿþÿÿýÿÿÿÿÿÿÿýÊøøÿÎýÿÿýýÿÿýýÿÿ«&&ÿƼ»ÿ¼˜˜ÿÕÜÜÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ»­­ÿÿÿÿÿÿÿÿÿÿÿÿýÿÿ²==ýÿÿÿÿÿÿÿýÿÿÿÿýýýýÿÿÿÿþþþýÿýýÿÀÎÎýÉÒÐÿ—rtýt ÿ ýÿÿÿÿÿÿÿÿkkÿÀÈÆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿüüüÿÿÿÿÿÜâäÿ±NMÿÿÿûÿÿÿâýºÿ¦NNýÿÿÿÿÿÿÿýÿÿÿÿÿÿÿýÿÿÿÿýýýýÿÿÿÿèø÷ý£<:ÿÿýÿÿÿýÁÿíÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿôÿÿÿéxxÿ²ÿ÷ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿͬ­ÿÿÿÿÿÿÿ÷ÿvdcýÿÿÿÿÿÿÿýÿÿÿÿ»HGýÿÿ—²²ýÿÿÿÿýýýýÿÿÿÿÿÿÿýËYWÿÿýÿÿýýÚ ÿמŸÿ£vvÿÿÿÿÿ«ÿÿÿ®ˆˆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿôÿÿÿÜÿÿÿÿÿÿÿÿÿïý×ÿÿÿ°‘‘ýÿÿÿýÚÿÄÜÜýÿÿÿÿýýýýÿÿÿÿ¿’“ýÿÿýýÿÿýýÿÿãÿÑ((ÿÿÿÿÿÿÿ¡††ÿÙ¥¥ÿÛ××ÿÿÿÿÿäÿÿÿÛÿÿÿÿÿÿÿÿÿÿÿÿýÿÿýýÿÿýýÿÿªýÿÿÿÿèÿÿýÂÿÿýÿÿýýÿÿýýÿÿÿÿÿÿÿÿÿÿÿÿÂÿþÿÿÿÔ¢¢ÿëÿÿÿÿÿÿÿÿÿÿÿÿÿ§­§­§­§­§­ª­— ­‰­²­«­§­§­§­§­§­§­( @ €P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿËý¡'%ÿ¤edÿ‰ÿ‹ýžsuÿÇWVÿÉ!#ÿ¶ýäÿÿÿÿÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿý¿ý­˜—ýéÿÿþÿÿÿýÿÿÿýÿÿÿýÿÿÿþÿÿÿýÿÿÿýÿÿÿýÿÿÿþ²ÝßýŠ‰ýË35ýöþÿýÿýÿýþþýýýýýýþþýýýýýýþþýýýýýýþ þÙÿÐÿÿÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿþþþýÿÿÿÿÿÿÿÿÿÿÿÿÕÿÿý–uuÿÿèÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿ½ÿ††ÿ¾ååýÿÿÿÿÿÿÿÿÿÿÿÿþþÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿ¤ÓÓÿrGGý´ÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿÁýÿnGHÿ„‡†ÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýßÿÿÿP;=ÿÿÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿýýýýýýÿýÿþŠý”LLý‹‡‡ýÿÿÿþþþÿýýýýýýýýýþþþþýýýýýýýýýýýýþþþþýýýýýýýýýýýýþþþþÿÿÿýÿÿÿý@VXýÿþÿýýýýýþþýýýýýýþþÿÿÿÿ®ÿI¨ªýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿuýÿÿÿÿÿÿþýÿÿÿÿÿÿýýÿÿÿÿÿÿØýtÿd ÿq ÿgýFRRÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿŠ>>ýÿÿÿÿÿÿÿýÿÿÿÿÿÿÿýÿÿÿÿÿÿÿýÿÿÿÿÿÿu]^ýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿòòòÿpýœ›ÿvÿëÿ@ýxÿ;ÿ¹ÿßýýýýýýýþþýýÿýíý™áßþÿÿÿýÿÿÿýÿÿÿýÿÿÿþýýýýýýýýýýýýþþþþýýýýýýýýýýýýþþþþÿÿÿýèççý¤¤¢ýÿÿÿþÿÿÿýÿÿÿý›¿¿ý¿ûûþôý‚ýŒýþÿÿÿÿÿÿýýÿÿÿÿÿÿ¤ýnNNÿˆÿ›››ÿŸ¡¡ýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿöööÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿæÿÿÿO<=ýÿÿÿÿËÿÿýÿÿÿÿÿÿýýÿÿÿÿÿ ÿÿýpÿþÿÿÿÛÛÚÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýßðôÿf! ÿ¢ÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿÿýÿÿÿÿÿÿ[ý÷ÿÿÿÿÿÿÿÿÿÿÿþþþýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿ•œšýÿÿÿÿÿþýÿÿÿÿÿÿýýýýÿýÿý{þ},-ýw:9ýaýôÿÿþÿÿÿýýýýýýýýýþþþþþþþýÿÿÿýÿÿÿýÿÿÿþÿÿÿýýýýýýýýýþþþþýýýýýýýýýýýýÿÿÿþÿÿÿý˜!ýÿýþþýýýýýýþþÿÿ§ÿ}­­ÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýÿÿÿÿÓððÿÂb`ÿ¸]_ýåññÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿ›')ÿÿÿýýÿÿÿÿÿÿýýÿÿQ‘•ÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿ¹ÇÉýËÿÿÿÿÿaýùÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿþþþýÿÿÿÿ‰ÿÿÿýýÿÿÿÿÿÿýýÿÿåÿ†ÿ,+)ý·¹¹ÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿèÿÿÿ¯ýÿÿÿÿ§§ÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýËññÿÖÿÿÿýýÿÿÿÿÿÿýýÿýÏý•¢¢ýåééþÿÿÿýþþþýýýýýþþþþýýýýÿÿÿýtQTýÿþÿ ýÿý0 ýÖÝÞþÿÿÿýýýýýýýýýþþþþýýýýýýýýýýýýÿÿÿþš®«ýÿýýýþþýýýýýýþþÿÿHllÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿuÿùÿÿýßÿ|†ƒÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿý‡ ÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿžÿŒý«ÿÿÿÿÿÿÿÿÿý|––ÿäÿÿÿÿý“-/ÿÿÿÿÿÿÿÿÿþþþýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿ¼ååýóÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿÿýP?@ÿÿÿÿÿÿÿÿÿz©§ýéÿÿÿÿÿþýÿÿ³ÿ5ÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿÿÿÿÿ„ABýÿÿÿÿÿÿýýÿÿÿÿÿÿýýýýýýÿý’þÿÿÿýÿÿÿý`ghýûþÿýýýýýþþÿý”ýßúúýÿÿÿþýýýýýýýýýýýýþþþþýýýýÿÿÿý¶èèýâþÿýýýýýþþýýýýýýþþÿÿÿÿÿÿ‹ ý½¼½ÿÿÿÿÿýÿÿÿÿÿÿÿý‰ÿÿÿÿÿÿÿÿÿÿÿÿýÿÿÿÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿÿÿÿÿ`$&ÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿÿý©&&ÿOOÿu--ÿ½ýfABÿÿÿÿÿÿÿÿÿýýýýÿÿÿÿtŒŒÿÿÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿþýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿvýöÿÿÿÿÿÿÿÿÿÿÿÿÿÿý›»»ÿÉÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýýýýýýýþþýýýýýýþþýýýýýýþþýýÿýSýôÿÿþÿÿÿýÿÿÿýÿÿÿý„¨¨þËýÿýýýþþýýýýýýþþýýýýýýþþÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿ“ÿÍø÷ÿÿÿÿýÿÿÿÿÖÿÿÿ|""ÿþýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿþýÿÿj¨§ÿÿÿÿÿ½íïý^_ÿËÿÿÿÿýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ¸::ÿ¶ÿùÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿP\P\P\P\P\P\P\P\P\P\P\P\P\\\[\U\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\(0` €%ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýýþþþþþþýýÿÿÿýÿþÿþÿýÿÿÿýÿþÿþÿþýýÿÿýýþþþþþþþþýýÿÿýýþþþþþþýýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýþþÿþÿþÿýËÿ†ýfþV..þIý\01ÿk#ýþ´þáþÿýÿÿÿýÿþÿþÿþþþýýÿÿýýþþþþþþýýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿÿýÿþæþ{þ‚‚ƒýÀéçÿÿÿÿýÿÿÿþÿÿÿþÿÿÿýÿÿÿÿÿÿÿýÿÿÿþÿÿÿþ×þþþš½½ýŠwwÿa ýPþÖþÿþÿþÿýÿÿýýþþþþþþýýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿÿýv""ý²áàýÿÿÿýÿÿÿýÿÿÿÿÿÿÿýýýýýýýýýýýýýÿÿÿÿýýýýýýýýþþþýÿÿÿýÿÿÿýÿÿÿÿÿÿÿýÿÿÿý§ÐÑý’€‚ýçýøýÿÿÿýÿýýýýýýýÿÿýýýýýýýýýýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿXkkÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ¢ÇÊÿo33ÿaÿóÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿºý‰¶´ýÿÿÿýÿÿÿýÿÿÿýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿýÿÿÿýÿÿÿÿÿÿÿýuŸý3)'ý|ýÿýÿÿÿýýýýýýýýýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿÿýúþ=þ`}yþÁÜÜýÿÿÿÿÿÿÿýÿÿÿþÿÿÿþýþþýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿÿÿÿýÿÿÿþÿÿÿþÛ÷÷þ6SVýcÿÿýÿþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýÿþÿþÿþrýÿ59;ý€™™þöû÷þÿÿÿýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþÿÿÿþÿÿÿýÿÿÿÿ0WUýjþÿþÿþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýýýýýÿýÿýÿÿÿýŽýý152ýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿÿÿÿý½ÝÝý'ýÿýþýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿÿÿÿÿÿÿÿÿÃÿ?ÿA\Uÿ‰žŸÿïòõÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÈååÿKÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýýþýÿý?RTý¹çëýÿÿÿÿÿÿÿýÿÿÿýÿÿÿýÿÿÿýÿÿÿÿÿÿÿýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýÿÿÿý@kiýõýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿýýÿþÿþ=þG54ýHqsÿ†¢ ý§¼¸þ¿ØÕþÉãàýùÿÿÿÿÿÿýÿÿÿþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþÿÿÿþíÿÿþhýÿÿýýþþþþÿýÿÿýýþþþþþþþþþþÿÿýýþþÿþÿþÿýùÿ¾ýƒþ{þ‡ý2ÿýïïïþÿÿÿþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþÿÿÿþÿÿÿþrýÿÿÿýÿþÿþõýÿ ÿÿýÿþÿþþþþþþþÿÿýýþþþþþþýýÿÿÿýÿþÿþùý>SUÿÿÿÿýÿÿÿþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþÿÿÿþ}}þ[rqý=WWÿ/ýÉþÿþþýaÿKý¦ þO&&þÿþÿþÿþÿÿýýýýýýýýýýÿÿýýýýÿý: ýÿÿÿÿÿÿÿýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýÿÿÿýäæåý††‚ýÿÿÿýÿÿÿÿÿÿÿý†­­ýU+-ýz[ZýM~ÿ¼ýÿýý_ý&$ýK87ýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ[[ÿ@ÿýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÁÿ’ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿr~ÿÈèëÿÁÿÞ.1ÿ¤ ÿO ÿá ÿÿ ÿÿÿýýýýýýýýýýÿÿýýý ýÿHHýóý@ÿUiiýÖÙÙýÿÿÿýÿÿÿýÿÿÿýýÿÿÿÿÿÿýýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿÿÿÿýîîïýÿÿÿýýýýýýýýýÿÿÿÿýýýýÿÿÿýÿÿÿýõÿÿý#'(ÿÿýÿýÿý¢ýò$'ýÿýÿÿýýþþþþþþýýÿÿýýþþþþÿýÿÿóýþ7;<þ!!þ''&ý¥§§ÿÿÿÿýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýÿÿÿþþþþþþþþþýýýýÿÿÿÿÿÿÿýÄÚÚþ?jkþ0 ý÷ÿÿýþþþþÿþÿþþþÿÿýýþþþþþþýýÿÿýýþ þþ;;þþýÿÿBýÿÿÿþÿÿÿþÿÿÿþÿÿÿýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþÿÿÿýÿÿÿÿ-'(ýyþÿþÿýÿÿýýþþþþþþþþþþÿÿýýþþþþþþýýÿÿýýÿþÿþÿýUÿÊññýÿÿÿþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþÿÿÿþtyvýÿõýÿþÿþýýÿÿýýþþþþþþþþþþÿÿýýþþþþÿþÿýÿÿÿýÿþ•%%þý•·¹ÿÿÿÿýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþÿÿÿþªªªýÌÐÐÿgª©ýêþÿþýýÿÿýýþþþþþþþþþþÿÿýýÿýÿý¤ý5++ý5QRÿMafý2\[ý¡´´ýÿÿÿýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýÿÿÿýÿÿÿýÿÿÿýÿÿÿýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿýÿÿÿÿÐõõýºýÿýýýÿÿýýýýýýýýýýýýÿÿÿÿ§ÿ&BCÿ£ÆÃÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ½½ÿ¢wwÿœ““ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ¾ÜÛÿµÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÔýq«©ýÿÿÿýÿÿÿýþþþýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿýÿÿÿÿ¤±±ý·|}ýÇRQýÿýÿ++ýýˆžŸÿÿÿÿýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿ£ÂÂýÚýÿýýýÿÿýýýýýýýýýýýýÿÿtý’¿ÀþÿÿÿþÿÿÿþÿÿÿýÿÿÿÿýýýýþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþÿÿÿþÿÿÿýZ?Cÿÿýÿþÿþÿþ•þc‹‰ýÿÿÿÿþþþýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿa‹Šýÿþÿþýýÿÿýýþþþþþþþþþþÿÿÿý–þ7þJ66þ`ecýÈÌÌÿÿÿÿýþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþÿÿÿþk› ýÿÿÿýþþÿ þR:8þÊðóþÿÿÿýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿV]\ýÿþþþýýÿÿýýþþþþþþþþþþÿÿÿýÿþÖþvþASOý™•–ÿÿÿÿýþþþþþþþþýýýýÿÿÿÿýýýýþþþþÿÿÿþÿÿÿþ]ýÿÿýýÿþëþ_þÿÿÿþÿÿÿýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþþþþþþþÿýÿÿÿÿxýÿþþþýýÿÿýýþþþþþþþþþþÿÿÿ!ýbý½½ýÿÿÿýÿÿÿýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿÿýýýýþþþýÿÿÿý8GKýÿýÿÿýýÿ ýÿýýýÿÿÿýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýÿÿÿý¯ÑÑÿÇýÿýýýýýÿÿýýýýýýýýýýýýÿÿžÿ’ÔÔÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿW†…ÿÚÿÿÿÿÿÿ..ÿ¡ÿIQNÿÙòòÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿJVVÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýgý6WWýWyzýo–”ýi‘ÿxŠŠýQRSýÿÿÿýþþþýÿÿÿÿÿÿÿýt£¡ý¥ýÿýýýÿÿúýÁ¿ýÿÿÿýÿÿÿýýýýýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýýýýýýýýýÿÿÿýÿÿÿý†ÿÿýýýýýýýÿÿýýýýýýýýýýýýÿÿþýÿþÿþÿþûýÿÿ¢ý[roþÿÿÿþýýýýÿÿÿÿg–•ý§þÿþþþýýÿÿÁý}³²þÿÿÿþÿÿÿþÿÿÿþýýýýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþþþþþÿÿÿþx––ýÿÿÿýþþþþýýÿÿýýþþþþþþþþþþÿÿýýþþþþÿþÿýzÿ†¡¡ýÿÿÿþþþþþÿÿÿýj ¢ÿ°ýÿþþþþþýýÿÿÿýÇ/3þeþk:?þ §¦þÿÿÿýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþÿÿÿþÿÿÿþ\ýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýþþþþÿþî)(ý?nsÿÿÿÿýÿÿÿþÿÿÿþFc`ýÀÿÿýþþþþþþýýÿÿýýÿþÿþ( þáìéþÿÿÿýÿÿÿÿýýýýþþþþþþþþþþþþýýýýÿÿÿÿýýýýþþþþÿÿÿþd’þôýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýýýýýÿý6ýÿÿÿÿÿÿÿý÷ÿÿý$@@ýð ýÿ ÿýýýýýýýýýýÿÿÿ ýäý@DDýÿÿÿýÿÿÿýýýýýÿÿÿÿýýýýýýýýýýýýýýýýýýýýÿÿÿÿýýýýÿÿÿýÿÿÿýfýÿýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿÿÿÿÿÿÿÿÿSÿÿÿÿÿ‰}}ÿWÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ,\^ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿFtwÿ÷ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýýýýýýÿý­ý…ÿÿýÿýÿýýýÿÿýýýýýýýýýýÿÿsýêÿÿýÿÿÿýáøøýÅÞÛýØôöýÐÞßÿÿÿÿýýýýýýýýýýýýýýýýýÿÿÿÿÿÿÿýÓõôýzýÿýýýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿýýþþþþþþÿýÿÿýýþþþþýýÿÿýýþþþþþþýýÿÿù00ýUþ^þwþŽþáýÿìùùýÿÿÿþþþþþþþþþýýýýÿÿÿÿÿÿÿý#þÿþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþýýÿÿÿýÿþÿþÿþÿþQýÑêçÿÿÿÿýþþþþþþþþþþþþÿÿÿýÿÿÿÿ:8ýÿþÿþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýýýýýýýýýÿÿýýýýýýýýÿÿýýýýýýýýýýÿÿýýýýýýÿýVýÈððýÿÿÿÿýýýýýýýýýýýýÿÿÿýÿÿÿý!$ÿÿýÿýýýýýýýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ´ÙÙÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿâýÿÿ745ÿÿ ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿýýýýýýýýýýÿÿýýýýýýýýÿÿýýýýýýýýýýÿÿýýÿý©ýp”“ýÿÿÿýýýýýÿÿÿÿÿÿÿýÿÿÿýhŠŽýbýÿýÿÿýýýýýýýýýýÿÿýýýýýýýýÿÿýýýýýýýýýýýýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþýýÿÿÿýäþ%SSþÿÿÿþÿÿÿþÿÿÿýÿÿÿÿ£ÓÔýb(%þÿþÿþþýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþýýÿÿÿý9þÿÿÿþÿÿÿþúÿÿþ}®¯ý_ÿÀýÿþÿþþþýýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþýýÿÿÿýÙ99þUUUþdþšþæýÿÿÿýþþþþþþýýÿÿýýþþþþþþýýÿÿýýþþþþýýÿÿýýþþþþþþþþþþÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿgcl/gcl.jpg000077500000000000000000000601001242227143400130730ustar00rootroot00000000000000ÿØÿàJFIFHHÿí ðPhotoshop 3.08BIMíHH8BIMó8BIM 8BIM' 8BIMõH/fflff/ff¡™š2Z5-8BIMøpÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿè8BIM@@8BIM €4€N cÿØÿàJFIFHHÿþ'File written by Adobe Photoshop¨ 4.0ÿîAdobed€ÿÛ„            ÿÀ4€"ÿÝÿÄ?   3!1AQa"q2‘¡±B#$RÁb34r‚ÑC%’Sðáñcs5¢²ƒ&D“TdE£t6ÒUâeò³„ÃÓuãóF'”¤…´•ÄÔäô¥µÅÕåõVfv†–¦¶ÆÖæö7GWgw‡—§·Ç×ç÷5!1AQaq"2‘¡±B#ÁRÑð3$bár‚’CScs4ñ%¢²ƒ&5ÂÒD“T£dEU6teâò³„ÃÓuãóF”¤…´•ÄÔäô¥µÅÕåõVfv†–¦¶ÆÖæö'7GWgw‡—§·ÇÿÚ ?õT’^õ÷묹ý¥ÚXY¦vC 8'ìµYù®Ûý"ÆÄÿ¥Sò¼®Ng(Ç9Hü°ïJ@ .×]úÿÑ:Eƨ»?1„µôÑXá¦Ëòú:Ý»é1ž­ÌÿD¹|ñ¥×òq°ñigaa²Ó÷°â®BŒ{.{h¡£qàpÐÒs¿u«gêÛml±îñ` oËp{–ܹo†r`G7ë2~®)KûÞÜ=÷˜¸§-´t›þ4>±ƒ/ÇÂx𠵇üï^ßú•Óý[úû‰Öl8™}44¹µîÞË>™¦Èc·³é>«ÿn/;Îè=K(ÐÊ-ÈnÐöØÆ ϵî£kÛµK¦ôþ¥F~>G¤jôl$¸Lj×{Z]ù®K™å¾>\Î9qâ"\&¸£n_½ýÅDÎõ²ûS,kÄ‚©õ~¹Òú.8¿¨Þ)k¤VÍ\÷‘ùµTÍÖYô¿±ùëϬlèýùù-6ÕñOÓÃýoÖq¯„‰úuiõŸñ•‘…Õrð±0«¾œ[ >«ìsKœÀÞÖÖÿ¡vúÿ°¬ýZú÷Özƒñ¯Ã«Š«6YklsŒÈeL sôÝÿP¼Ìo:½Åïq%î:’âw=ßÚr辫Wc{t7¸’Ïk?éoW9þK”å¹BF0rúqÆw?TÿJ7îqÍle#-ô}f››hŠ¨ô¶9´7r¼¹æWÿÐô?¬]Tt~‰—Ôcsè¯ôM:ƒcˆª†Ÿäºç±x‘/q/±æËK¬±ÆKœã¹ïq?¾ó¹zoøÓ±íèÌi!¶fVðk.µ ÿn¶/1<.—àx„yydý,“:ÿV/ýÛS­vw¾¯á°:=×™'ù#FûúÖêŸY]Ð3ÿgâbS’êêc¯}®x-{Ç©é·ÓýÚ}'×>©W]­¥í÷7kGÌsÎVþ±}N蜞±Ÿ›“Sïs®³}µ4}*êw»NªÖv<¸rs¹eÍFSâ2Œq)K‹†ôÿ›‡¡yDp¸ÖÿŒ>£cv»§bGõíW¾¬uWõœ«ÆN-ôÐÆõ—’^óì¯ôžß Ëÿì.¤ N±á亯ªTØÑ[[§¬ñc¾pÖàmW~)Êòœ¿-)Cc’DBå§éHüß¹°”‰Ôµþ¼ç·#­}†£ú¿Mo¦àÜðÛ2_ýŸÑQÿZX¸4 ò˜Ç `÷¼x†þoöœ£•cíÌɵÿNËís§Ä½ê÷@ v[Ø~›šÝ£ÄwÇýs(<¯Ãä1ïÞŸ¦y?ÆŸº´z§¯Rö¥zÎÖãPÁ«ß¤ŸÝc~–;ók¯Þ¸\¯ñ‡õýRÜÌ+E8Žpa\ƽ¡ú¦Ý¶¶×ý;};ÿàÿÁ®{”äss\GF0ý)i/Üõ™e!Þß'êë-³q ˜úþkéØ*­—a¾èÿGDzm?ñ—Ø×ÖWEõWëVWYÄõ³1™Žòí•Ü\-§ck{wTÆ¿ôÎY½p\zŸí?¬¹—4Í4‹Oõi–ÙþvK¯rµð¾RC1Èôk”€Xz£ýo_øœ½:uqƒ\âߤâ߉Ð.ïêÖÞÆ´{XGÀh¸î˜Æ;-®{ƒ[XÝ. {µ¼¯Eú»wM¢°ërñØ•kÿ«S|o$¥’¢ R¡úy?ïaÿ¥â[ÖPÍ•€ˆªSÕ:eÖ6šrè²ÇèÊÙcãwµ­vç{Z­ Ä1#pG›+ÿÑï>¶t?ÛÜ&–²ð[n3Ý;E¬Õ›£ó,÷RÿøÅã™xùYÅÍ©ØÙ 0ê¬~-?FÆ~í•û½‘!fu>Fk6ØƼvk€pÿ¤´y‰Ë•‰Æaîc'Š¯†P—õO«üU“‡»>-NNF;‹ñﲇMOs'ã±ÍLç[•v÷ºÌ«øqu¯ë;{פ[õ3:YEcàÆÿr%_U¶èÖøðW¥ñÜbÌ0#ÖRÿ£¾Ñîð8Ý*ïç¿BÓù£Üóÿ|bî~®ôǵíyn؈ò…¯‰õršÈ. cº@ ²ù¾{/2AÈEFøaQëãŸ)úéõs'¤õ;ók­Îé¹o72Ñ«k{Î먺?šý!ßSìÙýEÎ5ÐA5ïy XZ{ˆ\ÆwÔü+^^1ê$÷ØßîZ·Ç 1Æq™˜Ž8Ëæ÷£ûßá-8¬Ø/–9ÛÞ ÜlxÑ¥î/pònòç+ø]"ûÜ{Mu~çwþ“gý5Ý×õIµŸÑ±¬þ«@ü‹GêÝu\%cã“”LpÃÚ½8ÉâŸø¸¡ˆuÕÁ­Ïé''©¾ÜJ¢Þóú,jÛÿ]sŸ²ÊàP8ŽL‚Iîïí/y¯–W°±®4ø¬®¥Ñ’í+`Mhþ CâQåc0q’É+2ãáôÇåÉ?ë¦pâ­v|t¹‡’Ü¢[Aä0ü@^§ÿ4Ùûû‚_óMŸº>à®ÿÊÿ˜?øgþ»[íx¼WÔÏGª?=¬nêXk¨€4}º=ßÙ§Ûÿ^^­Ó/}Õ9aãýXmo4†‹£ÄÇV;,ž{š<Öc”ŽcâጭýïRøÇ„SÿÒõT—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ÿÙ8BIMÿþ'File written by Adobe Photoshop¨ 4.0ÿîAdobed@ÿÛ„      ÿÀ¶ºÿÝ8ÿÄ¢  s!1AQa"q2‘¡±B#ÁRÑá3bð$r‚ñ%C4S’¢²csÂ5D'“£³6TdtÃÒâ&ƒ „”EF¤´VÓU(òãóÄÔäôeu…•¥µÅÕåõfv†–¦¶ÆÖæö7GWgw‡—§·Ç×ç÷8HXhxˆ˜¨¸ÈØèø)9IYiy‰™©¹ÉÙéù*:JZjzŠšªºÊÚêúm!1AQa"q‘2¡±ðÁÑá#BRbrñ3$4C‚’S%¢c²ÂsÒ5âDƒT“ &6E'dtU7ò£³Ã()Óã󄔤´ÄÔäôeu…•¥µÅÕåõFVfv†–¦¶ÆÖæöGWgw‡—§·Ç×ç÷8HXhxˆ˜¨¸ÈØèø9IYiy‰™©¹ÉÙéù*:JZjzŠšªºÊÚêúÿÚ ?ûùŠ»v*ìUØ«±Wb®Å]Š»j b­Xd8ªÃ0ñU¦uñÅVúë㊻×_UÞºøâ•âa㊉Ž*¼88ªàAÅ[Å]Š»v*ìUØ«±Vª1U¥ÀÅVGŽ*°ÌùËô‡ÿ¡Úÿœˆÿ©¶Ïþáv?õGåýgó‡È3ÿ“EìïúŒ¿ådÿZ>×þs—óúÜGëjÚEÿ«ô؇1Zѽ#ß*d£í¬uàÑ—þ¾ÏÎê#î™ý6Í´Ÿùø?楻 Ö|©å­R%§#n—v’°ïV7-~IôfD=¦Î>¨ÄüÇé.ŸUÿîÊŸ÷9ó@ùðȹ‰û^ãåùø?’õŠ8ùGSòÿÂ×–R¦¥n§ùŸá‚P?ÕF?¯68=¦Å-²DÇݸýã{Wþý¡„i3Ã/”Ç/‡Õœ¢û#É¿šžMóîœ5_(yŽÏ^²µ³þò"z,±7#ogPs}ƒS‹÷oÙ]ƒ¯íIpé0Ï!þˆ4=òä>%ñÿ›ÿçá”z;É•´}oÎR¥x]$K§Ú7Éî¬>˜sK›ÚM<6€2ûÛ¿ØúofÀOµõDñá×Ç/”}?ìߨ䗾gýèŠRç6ÿç"ý5¶÷ ±ÿª9åýgó‡È9?òh½ÿQ—ü¬ŸëLìç:?- }cQÑuN5¨ºÓQyWÇêíOlœ}¢ÕŽd‡ê§7üýŸÉôÇ$=Ó?ï„ž ÏÄ<ã óOåþ‘ª!4‘ô«™ì!gúÝiáQ_™x½§È>¸î$}öóšïøhä?ÁµS‡õãÿ¹ðßPy þsWòƒÎrÁc}¨Üù/S˜„K}m(òÝÆÏòÍΛ·´ÙÂ|ÿ_/>oÛŸð&í¾Í‰œ 3ÀuÆn_éÿJ$ú¦Û]·¸Ž9¡%†e¨Á••…C6 Ž™¹ß4” IQ ´:’µ>,,i3ŽéZ›â„jH|U\â­â¯?:ÿç3|Ÿù3ç«Ÿ!Ýù_Qó¡aimq¨ÜÚO I —+ê¬$=I>™G¯ùY£×öæ=&_ Ä’Þú—²Ÿð,Övþ„k#–8ã)$ˆìNßÒ±ðyÏÇü–z~[ëô—mý3ýcþaù‡¤ÿ“­ÿ”¬éd¢ßóñ¿'Ÿ—:Ðÿ£»éú(ÇüÃó ÿ&+[ÿ)XÿÒÉHÿÏÆ<¡ÿ–ïZÿ¤»éú'ÇüÃó ÿ&+[ÿ)XÿÒɯú(¿”òÝë_ô•oý1ÿDøÿ˜~aäÅkå+úY>²üœüäƒówɱyÎÛBºòõ•ÕäöÖ6×r$2[0)°§$§ŠœÝè5ƒW‹Ä _WËý¬ön^Ï뎎Yc’B “@[ˆïÖ¨ü^½¢­ûYšóI„W!»â¨ôzâ…`kŠ·Š»v*ìUÿÑûùŠ»v*ìUØ«±Wb©^±¬éZ›y¬kz•¶‘¤éÑ™¯õ;ÉR!Œui$rG¹9Î0R4RߦÓeÔäŽ,13œÄIòrüàüåÿŸé:k\蟓Zbk·hLry¿TÒÉOsmmT–_f“€¨û,3˜×{Iúp =ç—À>éì·üsf7jÏÃúœ3ÿ:[Æ>èñ8—æ·Ÿ?40?3µ©yëÍwþa˜9x-ç“´×û‹høÅ_ØQœ¶£W—Po$‰û¾\Ÿyìog»?±ñøz<1Æ:=GúÒ7)|I`9Œî]Š»v*ìUØ«±Wb¬—Ê~qó/‘µ›}ÊšÅƪ[ì'¨+S¨j®†›«2쌘'ÇŒÑu½­ØúNÕÀtú¬c$CÐ÷ƒÎ'ÌnýjüŒÿœ‡´üÐЋ^¬Zoš4°©­é‘“ÀòÙgƒ‘'Ór:J‰;ßö_iÇY ö˜æ?Hò~DöóØŒ¾Íꀉ3Á’ø&yùÂU·ø ÇP=9§y$ãûÊæÕàˆg:¢ÈÅ…2X' øª=Z¸¡~*êÓyæ¿çåÏäÖ–º‡õÔµ¹¸BúfƒlÚå*?sn4¨¡v*€ìXf³_‡KÈ}éø~Ò{9ìŸhöþ^ &;ê™Úþ´¿Þ‹‘è•?›_óÿ™Þu’ëMò/å×—¤åOnÂmVT¯Ú{¢) 4­!PËÓ›g!¬ö‡6]±ú#öüú|>oÑ~ÍÀw³;< šÏðŒ½ÇlcÝâÿ<šjŽ¡«^O¨j—וýÓs¹¾º•æšF?´ò9,ÇÜœÐÊFFɲúÎð@CDb9ÜÈ<‹k±Wb®Å]Š»v*÷ßÉŸùÈ?9~Rß[Ú%ÜÚÇ“d~òÜÏÉcV?–ŒÇ÷N:Ð|-ûB´aµìîÖˤáÔ~®çöÏþÚhqÐÇ©Ó~Y+êŸÕ‡˜?[ü›ù›£y·FÓõíýo4ÝF1%¼£b;2ºÕ”‚=wø3Ã4àläNÕì­Gfjg¦ÔLJ$ ÷ÞÜ¡êšv¼’qøúåκ™•¥úÉMð±O"”0â…·×öºm•Þ£}:ÛYXA%ÍåÃý˜â‰K»·²¨$à”„A'lÅŠYg@\¤@¼€5?™>rºüÂó÷›üíwÉeó.«s{MÖ(]Ï£}£Œ*až[ªÎså–CüFß¼û²ãÙz :HòÅyÔ~2³ña9ŽíŠ»V··šîâ [hÌ×2,PD½YÜ…U2pÆ&D̵åËP”æj1“Üä¿n?.$³òG“<±åIÓЬ!¶‘Óa$ÀršJÅ’o§=CI€`Åc þ×á?h;R]«Úµrÿ)2G”„›¬éþcYJüy’éˆgºv¤$òß,ºÚn`{áBh†¸¡Sv*ìUØ«ÿÒûùŠ»v*ìUØ«±W‡þvþ}ùò7A—™®¾·¬^£þ€òµ³/Öï]v¨¾œ`ý©PväÔS¯íZ8\ùžC©üw½g²~Çk½£ÏáéÅB?^CôÃõ˺#sä7~"~sÿÎ@~a~wêÆë͇Õ4+iKèþS³fKQ¸V*Me’‡y§¯+ðç®í,º¹\ÎÝä?ïÖžÊûÙþÎâáÓÆòêÉ/®_ñ1þˆÛ¾ÎïÌ­v*ìUØ«±Wb®Å]Š»v*ìUœþ[ùÆëȾpÒuûyZ8#A©¢“I-e J¤w¦Ì󙽫:lñŸNGÜyþ·˜öÇ°#Û}——JEθ¡å’;ÇçôŸè’ýWò÷œÄž&¨4 ×=,âFžé yˆJãëï’k§­é—âUSË%–Á' 0±EòÛøâ¯ÏïùÉùÍ=3òúMCÈÿ•ò[ë¾v‹¾«¯°Ylt©*È«¸žu ÕOÀ‡ír<“9ÎÕíØà¼x·—SÐ~³ö>Ñìü rö Ž¯´/¼aÊyô`{þ©T*OÈ/0ù^óf±{¯ù—Wº×5­EÌ—º•ä­,®{LvlØ €8¼¹e–FS6O{ôÞ‹CƒE†8tðÇQˆ ?O3Õ&Êܧb®Å]Š»v*ìUØ«±Wb¯¥?ç¿2nü¯¯Ëå{›†ý®’ö¨ÇáŠñµ¢Ž'ą΋ÙíiÇ—Â?L¹{ÿoê|gþ ^ÌGY¡¡Œ~÷Òþ–2Þ~Q2~‘y{ÍâBŸ½üs·~^!íÚº²„øúá`CÓ,/DŠ»ábù›þsKóù'ò+^³µŸÑÕ<ï4~_±¡<½+ŠÉvh7¡·ÐžÅ‡Ë4Ý»©ðt¤rÛõý¥À£±”{w¤.È}ñÚìÈ?ü(Ï=~Âv*ìUØ«Ñ*ìãŸÎš]äê ¾ŒÆýê6ç=/¤HTý·ì=?©‰<£¿Ë—Úùßü»cù;°òÆ&§š±t¾¿öCâyé¾ri{øç Ûò ×ü¹æ&”ÇñÖ´ï…~òíù”'Å× õ½6Bʧ IlP­Š»v*ìUÿÓûùŠ»v*ìUØ«æŸùÉùÈÍòËHá#Õüï®G ò¿—‹?Ân®¸V'عøWö™u}©ÚqÑC¾gý'Ëï{Ïa=‡Ïí.¦·†žx“ÿyù”Fç ?üççO3þ`ùQóg›õiµ­wT~WW’ÐËh *" •TAž}Ÿ<óÌÎfÉ~Áì®ÊÓv^š:m,1Çy<É=Iܱ|¥Ø;v*ìUr#»E.Ç¢¨©û†J124–¼Ù¡†&y$#Ôš2Ž]'RqQe0å)_×LÌfêe˾U÷¼Þm»©jñ_”„¿ÜÚœºuô ™-%U[‰#ï š F1r„€÷7èý¬ì\„qj±HžCŒò$b= ±Wb®Å]Š»}­ùwæÉdÑôfyIqkÈkÕ‘B“÷Œô¾ÏÉâiá/è‡âkôCIÛ¬C`2νĒ>ÂúËÉþb2z_‡|Íy’LùoSõ?‹Ã$ÖCÕìg䫾ÍÏùËïùˉ,Uü¥ü®ÔLwËÎÓÎ~m·jOÙ’ÊÍ×£ö–Aö~ÊüU+Éö×lðÞ'â? ~’ýÿø ¢¥Ú1ôóÇŒõîœÇwXǯÔv ~Ug ýìUØ«±Wb®Å]Š»v*ìUØ«±TUäÚ}í¥ý»p¸²™'…¼6 ?–bÈqÌHsþN.»G fŸ& ›Ç$LOºB‹ôÊoõÒÚd–©*«©¯fê0˜”D‡"üªÓËYbŸÕA÷ƒEõ”|Åê¾? ±Å!ôF…©zˆŸpµ—åÇüç×æøƒó@ò=¥Ç©eä;Õ¾[a¨ñ‘Ãü°$DW§#ôñÒjxó c”GÚe?QÀO±-Ù™5’¬ò¡ýLvÎf ø39ÇÚŠ»v*ô%Mú> îÒ]°PÈJÿs´ösOÁ„ä<ä~Áûmù›þ ݳùžÐÇ£‰ôàŸëä£öDGæ^á j²;§ÄzçDøÉ¥<™pîbßÃ$äú¿Ê|ŠG_…¨½ËK‚á`YD]*Ø«±Wb®Å_ÿÔûùŠ»v*ìUä›þ^ü•ò&¥çt‹‰ÓýAÑ•‚Ë|à˜¡CØlYÚŸ ‚hMÃ×ka¤Äg/€ï/I짳:h5ÑÒáØsœºBœÜY6æþ|<ùç¯2~dù¯Wó—›/ÛPÖµ‰yÌý#‰ÑÃtXãZ*zœó}F¢zŒ†s6Kö·cv>›²t°Òé£Ã‰=dORNä± ¡Ù»v*à $“@Rp{JBÊF€æYvå±ÅgÔØ ;­¢š1ÿXöù ó¦ìÿgÌ€ž}‡ózü{½Üýφû]ÿè`”´ý–ä69NñÔÅýcé#†ôí HÁ ùž§éΣŸPˆÉðŽÓíoiäñ5Ye’_Ò;på€ „6’ÌFÇ.u‰Ä$¯O€á[I|Åäg¸²žöÒ—–èd*£ûТ¤ãN‡4]¯ÙPÍ’¦7þ·í}Wþ^ßj;3UI©™–šdGÔº'`bzFþ¨òq¿>3œ3õC±Wb®ÅW¤RÊio!ðPOêË1ážO¦$û…¸z¾ÒÒéçË cúRûÈ{÷‘åžÚÆÆ'V‘(v#|ôNÍ„¡¦„d(€ükí¶§«¶u9pÈN™ ƒ`Š‹êÿ$_IXªOlÏ%'×^P»b‘Tødš‹Æ¿ç,ç#%üµòÚùÊÞ—ž|ÍnMÝôMñévU2†fi·Xû¨«ìxWAÛ©ùxxp>¹}ƒõžŸØúßü =„±¨üîª?àøŽÀòÉ1Óú±ç.óQßÕ_‰$’MIÜ“œ+õk±Wb®ÅWÇ“:Ç$sEE''²HF"Éqõz¼:LRÍšBˆ²I *³òôHßÉÍÿåž3@?ÖnÿGßV‹ÙÐ=YÏÀ~“ú¾o‚{MÿIÈœ]— ê“ŸêÀì=ó¿8„ú Kxö‚Ö8ýŠýýs‹G‡ô@‡é|‡´=¥í=|‰Ôj2Nú„ED|i„“Š2r¨"£2 D…Ý><ÓÅ.(Þ 5ç’Òò6kxŽÅ*Œ¢ŠOƒúÆiõ݉‡qB`J'¼Æ㢎Vå;v*ìUô—õi†˜ îÆ„ÿªþé].-63ý÷?{g€aí­d@¡ãLÿ¦‘—éÛÉõ×’5f>ˆåá™Áå$ShÚõ®›¦]j—óˆ,tëy.¯'n‰(]Øûã)ˆDÈò Á§ž|±ÅŒ\¦D@ï$Ð7á¯üÑyço7ù—Í×ü…Ϙµ‹ç}5šBÉ>´Qì3ËuŽl’™þ"K÷cvl;7E‡KX¡ûèn~'sïbùK²v*ìUÀ@“°ÉF&D̵æÍ 0–IšŒA$÷¹gšePEý”g¦é°Œ8ãÐSðßmv”ûK[›U>y&eîì>‡Áì¾U…ãùŒ½ÔÖÞE²cèíá’ R}såKR*ŽÃ$Ô^ͧGÅW @ƒlP©Š»v*ìUÿÕûùŠ»v*†¼»¶±µ¸¼¼ž;[KHž{«©X$qÇ,îìhP $ôÀHÏ&xñË$„ ‘4æIäùûÿœœüó¼üðüúÔm¦‘<›åö’ÇÉ– UCÔºe4¤—Cî*þÎyÏjöÖf±ô‡ëø¿hÀÿÙ{;ÙâÇÉRÈ|úCÝ ¯3rêùË5otìUØ«±Vg£ééf‹w:ÖíÅcSþëøœí;²†2ä³È7öýÏÌ¿ðKÿ‚»G$´9Vž&§!þVC¥ÿ0tþqßqL‚%yØu9о:Ë´½ç+ðÖ¸X’ôýÊO'ÝõöÂÆÞ•§y°_Ý~±%‘/‘>î 4Ž'ÉòÿÎ7yÑ®®¥šãOÓìÌÒtç$’ù? ƧùYÅÿ¡Ìò‘7/Ïõ?Mø4öf0ˆÇ—$ÄEšŒcu¾æWÏú*rþD=€­æ¯-Éia„Eø³?ê̼~ÌÀ}s'Ü+õ¼î³þ:‰_åô°œägöDCïø¤w?—Vd ³ûR9ÿxŒÎÇØ:Xs‰>òE<®³þ =¿¨úrÇþ„#÷ÏŒý©wø^(Õøï÷æv= L">åužÕv¶³ûíVYî9WúPkìL­tû³( tR‘‘³Íè:‰(tø¾Šò~›"4_†I¬—ºk~tÓ,ü“¬yÇW£A¤ÛÖÚÓ—¹¹†®îä ÓaVècêõQÓb–ItûO@í½ì<Ý·¯Ç£ÅÎgsüØå#î3C™~:y³Í:Ï|Ç«ù§ÌFóWÖ®âîSÐWeD²ˆ *ŽÀžiŸ4³LÎfÉ~Ýì®ÌÁÙš\z\áÇŒPý$÷’w'©,{*vÅ]Š®Ž7•Ö8Ô³¹¢¨îNO9dŒE’ãë5x´˜g›4„aL‰è7°³‹OŽ‹G¹qûÙãUöÎÿ³;2HwÌó? y}ïÈÞÛûo¨ö‡P@&xŸD;ÿ§>ù”Fé'6Öï3 «\Ù¼#5Òô˜¯ÀMp±%éZ_“Ú@¿ºü0±%›[yŠÜþÒ8Ÿ/þxyq|¿æ{XÌcR±YdÚž7d&¿ê…Î#Ú½=GÍîšE°kÑ“ãº4ð1)Cþ°Í?oj|1œ¶ýgÞú?ü ûùC·!’BဇúÃh|xˆ—ù¥ùuœõÛ±Wb®ÅQvQóOdøðÍÇaéü]H'”wý_kçðSíŸäþÅœ"}yφ=Çyÿ±œî“ynùÞ¿%Ð~LÓË<_†²ûȺe_†H5Iõ7—-8F›xdš‹Óm#⣠ÍFØ¡v*ìUØ«±WÿÖûùŠ»v*üøÿœøüå>RòU§åv‹uéëÞ|ÖÖÙÅŽŒU—Ûë/uYëœç´Zï Ãrçý_Ûúßiÿ€×²ßžÖË´r‹Ç€Ô|ò‘þò&ÿ¬b_™Ã¿R;v*ìU7Ò-D³zò Ũ¡nÃèë›ÞÂÐxù|IL~ÓøßäùWü}«=•¡L2¬ÙÁsŽ?â>F_Hÿ8Ã0…ZgÜ?,3ÝGi™>× ^óå*™=2cðí…/ <½äÑÅ+á…¬—­i¾P@«XÇÝ…‰,„yV0¿Ý»[Ô¼«VýØû±M¼£^ò’žtðÀÈj¾N«7î¿ ÁbäÏ‹û¯ÃÚ6×É{Ý~­³'ɼYO¥øabKÙ<½åŸH§îéÓ¶¾ ÿœºüÃý/æ‹?ËÍ2ඓå%Õ‚]JUèi±ô#Ôö—eaž&cŽ37.²FßUq &ÿò×GÒ"x´ÓMŒ pµ"ÿ`Y<{B {…8:ÎÕÕëO£,òéHËï%ãž`òéá–8€¼ÂóÊOÌþëðÀÊÔmü¢ü‡îÝŠÛ=Ñ<©"²~ëðÂÄ—½ùWËïàéNØXùþrÏÌÿ¤|ó¦ùR 9ZùBÅDéØ]Þ…šNŸñPˆ{çí£8Æ9@}§ºŸ¨ÿà1Øß•ì©êä=Z‰íýLwþËì|­œóì.Å]Š»NôȾ}ÜíòÚû;§àÂrr?`ý¶üÇÿNØüÏiÃIéÁÿ¯’¤Øð}¯Nòõ§9nã:Ç‹ê/#i•h¾ !ªEöG’ôÞ)Ãá’ R/¢4[`‘¦Ý°µ–i Ð ,Qx«±Wb®Å]Š¿ÿ×ûùŠ»CÝ\Ck×72¤öñ´³Ï! ˆˆ*ÌÄì§ ,¡ NB1NÀy¿œoÏÌ«¯Í¯Í5ùÚi¬oîÚ ¨ôtëÝÚ SN$  Û}¢Ç¾yhjŽ§<²t'owGîd{=‡Ùxt€z£™ïÉ-æ~{ ɳ 銻w\ Z%!g`}”>”QÂ:Üÿ”zç£ö~”i°FzûÏ7â¿l;z]µÚ™µ7é'†PŽÑùýGÌ–s¢éægO‡3ž\¾ƒò—½Cáá…¬—¬y¿ÌŸ•žI¹ó\ö+SsœŒ‰ï$Ùz/—ô³+§Ã]òǾò‡—9úDÇáÛ Y/¨ü«åp:ÇáÛ$ÔKÝ´.¢*|†²Y¤:2(µ­ Ÿƒ·Ÿk^\Wû¿Ã@¼{Zò€·îºû`f Ïî|ŒÏî{ø`emÛùâ¹ü1¤q33É! þëðÆdοFXù{JÔ5­E…¾£ÚM{=6Hmã2HßB©8'1™@[v—O“Ušq‹œä#Þdh}¥ø‡æ¯0]y¯Ìº÷™ovþ{Ù#­BzÎX öPBaž]Ÿ1Í’S<äI~ðìžÎ‡ghñiaôâ„b<øE_Ç™H2—`ìUØ«€$€:“A’„ ä"9šu:ˆiñK.CQ€2'¸DYûŽ=4ì€3Ó°aqÆü5ÚÝ£>ÑÕåÕdú²HËÝgað²ùRÛǷq—:Â_]yKþçáðÉ4’úïÊvR/‡Ã$Ô^Õ§CÅl, ŒP P«Š»v*ìUØ«ÿÐûùŠ»|™ÿ9¡ù„ÞCüŠó6³ú:·]<¹§ÐŽ\.Ã5Ù§Z}Y$Zö,3OÛšŸK*ç/OÏŸÙo£ÿÀ¯±?”ûw¸a¼§ß£ý™‰÷üÏ<~Æv*ìUت*Ê?Rá**â?GOÇ6½§ñµ1¾QÜü9}´ð_ðJíäÞÄÊbjywóþ¯ö_o§ÂduÏ@~@{O•4¯Qãø|0°%õ’´H¾Ù Õ"ùÓþs ÌÃô·•¼‡k'ît›Sªê‘¯CqsXáV÷HÔ‘ìùÇûK©¹Çè,ûÏ/³ï~ÿ€bøzlúù òK‚?ÕŽò¯#"ù‹ó—}ÕØ«±Wb®Å]Š»~­~LéÐù7òÿËZ(ŽóêâëSQ¾±r}Y½Ó—’ç¥vfŸòúx@ó«>ó¿ì~&ö綕ûgQ¨áÅÃêCÒþµq|_@izœnV„f{Èù+þsoϦ-ùSÈ6sRMfáõm]ïõ{_ÝÀ¬<FfùÇœ¿´Úš„q»Ÿ‡/Ç“îßðìOSŸ_1¶0!ëKyxˆÝ7æÖqÏÒNÅ]Š»LôÈë#ÈGÙ_™Î—ÙÍ?Ie?Â({ÏìûßÿƒGlø:<:òËŠ_Õ‡ }ò7þc:ÒmL’.Ýs°~o/|ò~ê4_†I¬—ÖÞJÐ"<<0†©Óþ\ÑÕ?ƒÃ$ÔKÕ,l•vÂÅ:H1U)mö*ÞiË%~Vؕ怒V¨02´ü¯úCîÅ6«•ãSýØû±E§Vþ^)û±ŠÛåÏùÍ4ÇäŸÉ‹½"ÚA§ç›È´ˆ}±l¿¿ºqìR1ÿ_4žÐj<-1ˆç3_gõ|_Qÿc~¶ã–Cѧ‰™þ·Óó&²ûÈÚe?†Õ'Ô¾\³à‰·A’j/LµŠŒ,S%¡v*ìUØ«±Wb¯ÿÑûùŠ´zb¯È/ùøÇœšûÎÞGò4VßËúTº­ìjvúÆ¡)ŽÜìþùÅûOžòCp¿Ÿö?LÿÀ7²ü=£XFù& ?«gægþÅùÇœÃîŽÅ]Š»N4¸ëÍéöˆQôg]ìÖ„òwšùoú_¿àÙÚ|z>Œ¡3ï‘áÈDÿ¦z>ƒkêH›wÎð²ú_É:W&‹áðÉ5—×¾PÓc‚–R±Eó’F *¨$“Ð <šèÈÐÜ—ä?æw›[Ï^ó_š‹3A«j5€jÕm"¤VÊkü±"Œón£ó哼ý>Çîeû vGf`Òu„õϪgã"X&b»çb®Å]Š»v*ɼa£æ]" Ô5´s¬÷JEAŽ”û58ý9ŸÙšQô»>á¿ìy?n;cù+±µÁ©pðÇúÓô‚?«|_ÞZo›K²þóñÏH~)§®ùw_iJ|~Xüúÿœ‰óKù«ó[Ìú…í´1f ¯h)(ÿ‘Í!Ï=í¼þ.ª]ÑÛåÏí·ì_øvWä;V[ÈÏúؼ?5/ ;v*ìU‘é‘R$ñsÈý?Ùÿb`ð´±ï–ÿ>_e?#ÁCµ?=Û¹@7@cæï/öfORòå‘‘ã۸ͻçeõ7‘ôŠ˜~ -D¾Àòv’"ø|2M$¾ÑìÂ"í…f0ÆX¢v¦*¤ì1T#…8¥ Ð#vÅV}QlUUlÓÃD e¦*ü]ÿœöóðó/æ姓­%ç§~_X-¼ª Tß߸¸aÛhý>OÈpžÑê|M@€åöÏè~­ÿ€Çb~O²%ªõj%æBã·Œûˆ|7œûëîÅ]Š»O4¸~TÞCø í½žÓøx Ï9°múß—ÿàÃÛ?›íXéb}8#_çÎ¥/ö<Þ Óü½iÎHöî3 |ˆ¾£ò.™Sãá„5ȾÇò^Å"ø|2A¦EôFmÂ4Û YfP­ÂÅŠ»v*ìUØ«±WÿÒûùŠ¬s¶*þ}ÿç.5÷óüä7æMË?(´ëè´»t¢-…¼Vì|]ŸsžqÛ98õs=ƾBŸ´¿ài¢_g´±ë(™Ÿóäe÷8f­îÝŠ»v*É4”¬qû’OßÿaÇI;?i~Eÿ‚–¤æöƒ8é„"OÚKؼ¯iÎHöðÍ»çeõ§‘4áûŸ‡Ã$¤^Áù“iæ‘ùQæ›/%iZÇ™5‹OѶ6¶c÷Š—DE<•¨ãÂ"äfixŸ—Æ ‘·Ÿ?±é½‰1Û'­œa‡¸É—+†ñw*ø[óHÿÎ7þySùg¬ãÁ?æ¼á’uêeú¯þN³ÿò™æR]qù ùÃh ¹ü¿Õa¯$Où«ä_ú™OüœÀÿ”¼3ú˜íçå—Ÿtõw½ò½í²Æ vp :“ñ`=•ªœeœ=¾ì)‘êàI÷þ¦ š÷®v*ìUØ«4ò{ýR[‹ÎŽÀCöûMü3¬öoOõe>á÷ŸÐüÿÿÎÙ³ƒ³ây^I}±‡ûÿ˜{v…©ÈîŸëSà>†ò½ð†¹™¸Åm,¬{* “¿°ÄÈDYè¸ñK,Ä#ÎDï;?8õÙµ=BûR¸5¸Ô.%¹œÖµy\»oó9å™&g##Ì›~÷Òi£¦Ã 0úaƒÈ9Å]Š»³Éšé°üQ­6PÝž£‹‡àÉøC´5GW©ÉœóÉ9Ký1'ô½»Ê6\ž-»ŒµÀ/°<‰¦Üü> Õ"úßÊÖ!R=¼2M%ì…EÛ /4yŸDòW–õŸ5yŽõ4ýAµ’óQ»oÙŽ1Z(êÌÆŠª7f ÎW›,q@ÎF€s;;³óö†¢lâɈÄyŸ¸dô—á6»ÿ9mùÕwù‡æ<ùwΚ——íu{²ö>X2‹­>ÞÕ(CõYÄr¨äáfäÛW<û'lêNidŒˆ³Ë˜¯qÙûGÿ^ŇgâÑçÁ†ÞuÃ9Hï#Ç•_!dC£èï"ÿÏÄõÛFÓó#É6ú¤b‚MgAÛLîÖ³³£±ö‘¶m4ÞÓÈm–æ?Qýaàûgþ¸'rÐj ór!þž4@ÿ6Eö’ç*¿&<ýèÅ¥ùÊßKÔ¦â¬ÿ¸ûŽMÑÍH¤ohݳ}¦í}6¦t{Žßƒäݳÿ¾Üì«9tæpÅ÷‘÷ú}QÖˆ{ªjñ8 ®X¬ AÃ6OE#á¿Fý¡… ”w ÝñT¿¯éþ\ÐuŸ1j’ˆ4Í ÆãPÔ&Ûá‚Ú6–C½:*œ†LƒL /ääè´™5yჹäˆ÷ÈÐûKù©óg™/üáæ1y¯TnZ‡˜õJðT°W¹•¤*¤ö^T<³6S–r™æI?7ïnÍÐcÐiqi±ý8ãtE}½XþTæ»v*Ú‚Ä(êƃéÉÂrɦV¦l3ÍÔa"|¢,ýŒËOƒxÐ –€g¦àÄ1B0€§áŽÓ×Ï_ªË©Éõd‘‘ÿ8Ý|9=›Ê–Þ?‡Ã.uåõב4¿î~ j‘}wåK)݆I¤—´iñEÂÁ?ŒP P«Š»v*ìUØ«±WÿÓûùŠ©HvÅ_ÍçÔ—¿›_š“%ºónµ,k@^úb@©&‚»ož]­7¨È¤~òýãì¾1²t‘†cý„^u˜®ñØ«±Wb¬³C£‹Ø~üôÅ–’ÒþòüƒÿìÅí£‹ø¸d=Æý6>zò„¼[xfÙóâûÈv¢íá’ R}aå¸@‰(; “QfW H<1bò_4ÂÌ’mÖ¸‡Ã_óz‘òÿ“õ)Cúw:£®ŸiØ“5KÓå±ÍOmj<4«œ¶e¾‡ÿÆþSíÌ"BáŠòKüϧý™ÂßžYçØ®Å]Š»eúR˜Ò$»|Îç=#³´þC­oï;—â¯l»cù[µµn&UêGÓ˜ï/bòÄ,òGóœòÅïÓÅ%Ÿ‘¼ÛxƒãµÐµ “¶ém# þŒÇÖžtOÜ]dz8Æ^ÖÒ@ò–|cç8¿<3Ì_¹Š»v*áÔd h‚Õ¨ž9Ds ±èšBr‘>yêaø&@ƒEô?’­x¶î0µÙ~E´aÛÃ&dúŸË°…Ž?ÂÖ^ $Q‚")gv4 É$øab&ƒñ§þs'þrY?3õsùyä«âþBòõÉmGQ…MZú"@u*~("?c³7ÇÓ†p½¹Ú¿˜—…Œúû#úƒõ_ü =‚=‡óÚ¸ÿ„dyâéå9pôÿ9ð–sÏ°»v*õ"þoþhù[{o'y³Qµ€È«ˆ[ëV®ÌiÅmf -ÓáP}ó7K¯Ô`5ŽGÝÌ|žc·}’ì~Õ‰ž³ ­çôHó8Ñ¡æiû3ä5yŽ_,èMç)m™äµGÖ–É p¬Í¹ERﺂˆ4$(Ñ´ç'‡¸«z~0í˜èƳ(ÑqxDCˆÜŒG^CŸ0*À lîõÝ?ZY@øë—º¢.În~d7–?&eòåœá5/?ÞǦ YCIîÜ{){Iš/hu>›„s™¯‡3ú¾/«À{±?=ÛC<…ÃO?óϦí2Õ~.gýjìUØ«±TeŒ|çôA_§¶nûOâj8(‹øò¯àù‡ü»cò]ŒpÄú³ÈCüÑêŸÜ"¬Ïtˆ9È»wÎéùH¾…òe‡'‹áðÉ5—ؾFÓÀž>CTŸRyvÜ$qíá’j/Jµ¢¨ÂÅ2W¡¨1Wzƒo˜ÅWTb­â®Å_ÿÔûùŠ¨ËÐâ¯æëó·N}'óóSOeey³Xô¹XÄ÷’¼liAº09åúøðê2é½û³Ùã?chæ:áÇóàý¯0ÌG¡v*ìUتw¢_%µÀŽf †¡ÏE>ÿ<è;´£§‘Ç3Q—^ãû_!ÿ‚Ÿ±y{[uºXñfÄ(Äsœ9íß(’HA=h>”òs¯(ˆ ƒJí·åùÄÄÑ؇ؾD•@‡ h“ê¯.̾”{öÉ5–i#+ÇôbÅòæ¿üäåG‘¾³kyæ(µÍj*©Ðôr·s‡ìÈê}(ˆwØæ¯WÚúm>ÆV{†ÿ°=ß³ÿð:ížØ©CÇŒÿODkÈ}Rÿ6$y¿0¿7ÿ8µÍ[Û*éQèš>–Ò=•ŠHÓHÍ'^iU$Ø©ëœwiö¤µ¤ áˆä?[ô—°þÁ`öfÈråÈ”ˆ Ú#r9ïdÝOÍSß;v*¯m«2/jÔü†l;/Oãê#—gÜ?òÝöÏòWcg̬ǂ?ÖŸ¦ÿÍ/ƒ:Òà,ë·|ôWã'½y?Oäñ|>XÑWº$—^@ó•¬KûÛRŠ=«ñ=¬Š6ùœ£Y,|OÜ]·³y†ÖÒd<£›ùN%ùuž`ýÒìUØ«±Wb¬ßË7ð»Ço+„™H܇j{çoØý© ¸Æ9š˜ÛÞ?[òçü}„Ôv~¯&·O->BdkGy æÞñ—!ôžBýEä–PÑ}Ð>D_eyU ã¶H4ÉízŸæ/’ü¤WÎ>d±Ð,–ŒÝJ’•+ B²HÞȤå9õ8°G‹$€Dz»]Ú¹|-&)d—ØXòˆó$æ¿üägüæF³ù™kyä¯Ëô¹òß‘ç婨Hx_j±ô(ÁIôanè&l€JgÚ¹-@8ñza×¼þ¡øò~”öþx{QÕëˆÉ¨Ä áŒ÷ÿJcùÜ£ü;ÔŸ ç<û ±Wb®Å^÷ù'åÛxõh|ÝªÆ Z{×E…ÆÍ8Û֡쟳þVÿ³?`vw¼y‡Óïïø}þçÃ?à¹í˜ÁˆöVš^¹Þ‘ü0þg¾_Åý¿‰÷~‡æövOÞþ9ØÛóq‹Ü<½¯™B|}i…ÍÿùÌÏ>7š¿4-ü¿ÆM?É h¯Ö¸aþÄƇÝ3…ö‹Sâj8( øÏèù?VÿÀs±¿%ØçQ!êÔHËüÈúb>|RR|‹šÖŠ»v*˜YÜC<ÉäÇzÙÑö?hiô˜Ï8P¹Q⑹øD|†—æ*Ñ”ÎÒ:Ñ ÍÇú Ò÷Ÿ“ç'þ=½üÜéÃÙüµù¯ä½,Ænæºzñ€·ñÃþˆ4½çäÀÿÀƒ·¿›ý8ýO¡<¹ÿ9AùO¥¬bæëRi^6LŽôC¥ï?&³ÿîßþn?ôãõ={NÿœÖü‘µU^ëxiîãl?è‡IÞ~Lü= þn?ôãõ2Hÿç;?"Poµ¯û‡?üÕú"ÒwŸ’?äÎ{AüÜéÇêWóž‘þ?õ¯û†¿üÕú"ÒwŸ’ÿÉ›öƒù¸ÿÓÔ©üçoädÒ$Q]ë’K+Ž4Ó$ffc@ RIÂ=¡Òž§äÆ_ðíè‚Lq€?¦]Eª+ª6èXUºŠö9»|¸ŠFÇx­ß Ñ̾(E+W_Š¿ÿÕûùŠ¨ËÐâ¯ÂùÍÿ'ÉåÏgSH½;9ØÚk¥GÃÌGõYŘÉsþ°ñÏ?öƒ‡ª'¤€? ýÏ×ßð!íA¬ìc'Õ‚R÷_~2{Ÿ!f‘ô÷b®Å]Š»d:7šµÍ”é×¥cSQ€HŸ@jÓè¦gé»OQ§ mÜwsÉöç°ý‘Û23Ôagøãp—ÄƸ¿ÎìÚü䟜ôUUN‘tRœY’u&ž4›õfÎ>Òê8Äüÿ[Ãfÿ€—dÈÜ3fˆ÷Àÿ¼¥–Íÿ9™ù´"0é–º’BM¤²Ê:R¦yäCOõr3ö“S.B#àIr4ßðìLFç,Ù<Œ¢ûÄý¯óçoæ¿Ÿc’ßÍ>yÔïìe¯©¦E µ´jíF·¶FÔ*sY¨íF}§2Gw!òoÙÆö?e-6šþ"8§þš|RòÌÂzgb®Å]Š»N´˜9s”Ž§Šþ³o³zzÊzì>óúžÿà×ÛY0h"~rKÞn0ù?ôÁé™ylê_/¥ü‘¥òh !®Eõו4”hrFxºPA á«kâ1 Žaøïç¯,\ù/Î>fò­Ð"M QžÑ¿n$séH=ž2¬=Žyv«Á–XÏBC÷‡av¤{SA‡WY!{‰¡ð•ƒÊ«±Wb®Å]Š² ;Í~dÒB?Zº¶Uû*° Õ3qöŽ£¨ÎUïy­o±½¬‘ž].3#Ìðˆ“ï1«dù·ù–ñ´Iç]RÕ•ú¬ÆØì)³CÀ äçÚº©sÈ~}Î6ŸØ.ÁÀAŽ“¯ç?÷|LöþûS¹’óR½ŸP»—yn®dido›¹$ýùƒ)ÊFäl½N ><ÅŽB ò!2-®Å]Š»NôM'ôÀyª–P°õß¡oòWÜþ¶ì®Í–®vv€æ@ülðÞûo‹Ùí7 *ZœƒÑæÿN^C þ#·!";¶—©úK 0€‘F»Q°g}ˆŠùQŸ&£$²å‘”äI$ó$ó/dòÆ¡+´í“q‹è}7_ƒAÑu-výŠÙhös^Ýþœd`=È]²9r p3<€¿“~ƒE“[©Ç§Çõdˆ÷ÈÐ~KëšÅç˜u­[^Ô_Ô¿Öo'½¼~ÆIÜÈÔö©Û<».C’fræMüß»ô,z->=>1PÇ•ån[±Wb®Å]Š»v*ìUØ«±Wb¯lÿœxòÔ^eüÚòª]F$Óô9ÿLêî8Yñ‚;†›ÓRc›NÆÓøú¨ƒÈn~¶žþ =³ü™ØYçSÈ<8ûç±ùCˆü³öÞjG#÷•úsÑŸŒi–éúà–Ÿ\PC5²½æõÂĆA œ€Å¿éŠ¿ÿÖûùŠ¨ËÐ⯇?ç5¿(n?1ÿ.ã×ô[cqæo!4×Ö° «ÜXÈ£ë¨îÀ"È£¿ U³GÛÚ¨ÃŪü:þ·Õ?àOíL{´ü Æ°ê*$ôŒÇÑ/væ'úÖvÄìà®]Š»v*ìUØ«±Wb®Å]Š»v*ìU4¶Òn§£:˜#?´Ãsò¹Ñv&}FòôǼóøͽ¦ÿ‚fvEãÄ||Ãø`} ÿJ{îï–éÚxŒ$H Üõ9ÚitÑÓããÈ?2vÿmçínM^zl9 ¾ƒç»Ö¼±¤³IÃÜfK¥%õg‘ôcû¯ƒÃ$¤_WygMá|=†¢_ÿÎp~SÜYj:_涕l^ËPH´¿5_îî#mgz’ ô‰;¨:¶rÒhˆÏGcúèù?FÀWÚxÏ û+)õD™ãó‰úâ=ÇÕ]x¤z?>3•}ñØ«±Wb®Å]Š»v*ìUØ«±TßLÒe½a,•ŠÑOÅ'vö_ë›~Ìì™êÏÚýþïÖùç¶ÿð@Óv3‹dÔ‘´zBùK'pê#õKÈz™Ì¬h@"eAÖ0à ùO´{GQÚ:‰j53É3dŸÆÀrlÁ™è¶2Hé±Ë\_@ùGH˜¾ , _ÿ9®Ÿ,þXÇ¢Äþï›n’Ô/Fúµ½&‡ÒO³fÚG‡§àækà7?¡õOøö?ç{cóCÚ|¹®´Ü>>´ÂÀ‡¹h—†EC^¸ZËÐí²Œ(LÿæŒPÿÿ×ûùŠ©È6ÅXö£%lRüŽÿœžÿœY¼Óu=OÏ¿–ºq¸Ó.Ý®5Ï)Ú¡2[Èw’{DäŒwhÔUOÙvN;¶;‚rá:Ç»Ì~¯ÀúCþ?ðPÇÉÁ¦Ü —yülø_´ðAí^Û¸dŸ‡ˆÿ.1?Ö?T¾&»€MbÓ¤•‡Âsdñ ÇHòó»¯Àp±%îÞTòÃrŠ±øvÂÀ—ÔÞOÐ=1ÁáÛ$ÔKèNôãO‡¶²U<Ùå]#Í>_Õ<»®Ø¦¡¤jöïmi'FFPTЩ‚Œ¯.(å„…‚åö~¿>ƒQ F 丑ßúºÈ‹ðÿóÃò#ÌŸ“ºäâH¥Ôü¡y3 ÌJµ^'u†çŽÑÊÛìÔª÷Ï{K²òhåßÈþƒç÷¿bûíÖ“Ú<!¨ˆõãÿ}çGí)t'ƒæ­îŠ»v*ìUØ«±Wb«âŠIœGm#·EQS–cÅ<’á€$ù8ºÝvŸEˆæÔN8à9™Û׸s,¦Ã@T+-ñ ÝVÙNßìˆëòÔh=Ÿªžô¿¬þ§Á½®ÿ‚ùÈ%ƒ²‘ÊFÿòN'—õ¥¿tG6S 'Eâª(ªÃ:ˆÄDPØ>—,òÌÎdÊDÙ$Ù$õ$ó,§KÑ^W_‚µÉ5ö,ù]™£>™íÛ Y/¥<§årž‘ôü;ak%ð×üå?™†±ù—&m/;'ZÇ`ª§áúÌ€MpÃÜXÏú™ÁûA©ñu<#”|yŸÕð~±ÿc~G±Fy ž¢F~|#ÓîØÈYóVhßTv*ìUØ«±Wb®Å]Š»v*ìUÀ@¤ì/dJB Èšô–aeaQmã iüÇv?KsÓ4x< 1ÇÜ>Þ¿kðï´ª{W´³êÏ,“$TmðˆíYÔå‘ãølÊtD>¡òdîþ—^ØZ‹éÿ-Ô¤!’j/U²û+…‚mÿ4b¯ÿÐûùŠ­aQŠ¥·QòR)Š^w¯iþ¢?ÃZŒ ƒâÍßùÇï$ùÆâçR—M:Nµ!-&¯§Ò)$o’…$÷$rÿ+5ZÞÇÓêw"¥Þ?O{ß{5ÿnÖì01㟉ˆî@Tß}Àðù>óGüã×™´I$:f¡m«Û©³ò첪»[;Ò¼ îV±uöÂÄ—­h>J5Cé~Ó'»yoÊ"?O÷}=²Md½ã@ЄA> a`KÔll‚*í…‚.æÚ¨E1W“ùÇËÖZ½ÞŸ¨ÙC¨XÝ¡ŽæÎâ5–)þË#ùä'ÌT…‚äiµ9tùLR0œM‰DAò#püçüÊÿœTòÜ“Ü^ùJîo.Jì\éî Å¥zÑ0t©ÿ(Øg;ªösMñžÝÌ~·Ù;þ ý¡¤¶ã8Äü¤AKšÒé m*‘Ôaü2“§Ê9Äü‹²lhd.9ñ‘ýxþµ¿Wž´ô$©íÄÿLFŸ!þò+.ØÑDYÏŒëÇõª­…ëý›IO¿ÞF]ÏÔK–9|‹®Ô{]ØØ>½^åÇ~@’‹CÔd¥bÝØ~¡S™¸»U>`GÞU¼Æ¿þ ƒ¦ƒ$²‘Ò?|ø#ò)Í·–Tn$i?ÈAÄ}ûœÛéý›„wË"|†ß±ó¾ØÿƒV«(1ÐàŽ1üéž9|"*#ãÆÉmtÅ…x[Â"^üFçæzœßàÓcÀ+@’v¯më{S'‰«Ë,’ó;êÇéÀîÛG–B>¾^ê­ši^Y’F_Ýý±A/`ò÷“É)X¿ , }å'…Ö/ØZÉ{¾åç‚h`̨LQ1à€Ø¡¥Oza,cD‹4œ:×üáWçÆ»«jºî£{å¹oµ‹¹ï¯dúüÿ·ïmâÇ8ŒžÏêòHȘÙ7Ìõø?Qh¿à¿ìö“0cŽa qˆòˆ¡ü]ÁŠÞÿÎ~oØ‚ÓÜùzƒ¯Ùý‹Œ‡úÕwÇçû¯ù==…üÜßéüSÔ¿ç0t®_Y›I\Ô‡ì§üþ˜?Ðî§ú??Ø¿òy;»/úAÿ×øsRþXÿàôÇýê£óý‹ÿ'“±;²ÿ¤ñNÿj_ÊŸðGúcþ‡u?ÑùþÄÿÉäìNì¿éüSá½Kùcÿ‚?Óô;©þÏö#þO'bweÿJ?â›ÿ êËüþ˜ÿ¡ÝOô~±äòv'v_ôƒþ)ßá­OÂ?ø#ý1ÿCºžøüÿbäñö'órÿ¥ñNÿ j~ÿÁéúÔÿGçûþObweÿJ?â‘–>[¾Žê'Tô£nG‰$Ôn;xæ^‡°scÍä®ocÝ˧{ÏûQÿŽÎÖöf}>drG„qDRÚ[‰áºózn—c)uøO\럞 ܼ¥§IÎ*¯†¾µòNžÀDiÒ™ Ó'Ó¾^¶+m…¬½*Ñ(£ Ëúb‡ÿÑûùŠ»CÈ•c÷ö‚E;b——kÚ•^©^¸ð_2ùKÔõ¥Ö½°S`“Áõï%_÷_†E°•ê^Kp[÷_†,bW>Oû¯Ãm,)È÷†)µ£ÊÒÿ¾ÏÝŠÚ!<­/ûìýØ­¦0yNRGîÏÝŠ-=´òtŒGîÝ…Ëôÿ$9+ûŸÃGÐ4¯"š¯î 4ÄÉéú?‘ÀãûŸÃbdõM#Ê œuO£ ^›¥ùyb ðtöÂÄ–yc§,a~acl†8@lPéb¨;b¬[S±+ uÀÈù‹ËâPÿŽ,|ûæ_'ó2R/ÙÀ^­ù)¹?î¿ Áy½ÿ“û¯Ã;c“yF@OîÝŠm|© ?ÝŸ»¶×ʲ×û³÷b¶‡Êr?v~ìQiýŸ“¤b?t~ìQlãKòKµ‹ðÃH2z–‰ä}Ó÷_†bdö]ÉÁ8~맶`döMˉOƒðÂÀ—¢Ùi‹‡6‰¹·â„Š¼ËÌV¬Èà YÍþlÒ^_Sá¯\‹`|ý®yfIÿw×Û0X Ç“äf?º?v,­|˜çýÕø`¥âküÿï¯ÃO¿Áoþúü1¤q7þ ÷Ñû±¥âoüÿï£÷cIâwø1ÿßGîÆ—‰ßàÇÿ}»G´~Lzÿt~ìVÙF—ä翺ü0 —µy_ÊÌîü;a`Kéo*è¾’Çðt¦²^ë¤Zzh»tÂÀ²øV€abŠ§ê¦*ÿÿÒûùŠ»hŠâ¨Ib±V?}`$q­qM°=SËë(o‚¸ó=WÊ '/ÝuöÀÈžj>FV-ûŸÃd$Ä®¼„ ?¹ü0S.$šO ïýÏá/—øþ)ü1¥âWÈ[ÜþÒñ&ÖþB~çðÆ‘ÄȬüˆ?søa¤q2û$ªÓ÷_†(%›iþQD§î¿ ,m›XùmŸ»{b‹e–š: (´þ 5@(¸P™GZmŠ!iŠ´ËQŠ '€0;b–+¨i‹ o†µÀ—jÞZYy~ïðÅ•¼ÏUòb¹oÝ~)“¾ò %¿sø`¦\LfãÈB§÷?†4¼Isyî i?»ü0±¶§èI_ƒ6ËítõŒ .Zn€:b„-Ì5lRÂum?ÔðõÀògËž±ƒ0^s}äÁ#1ô¿ YZC'‘'÷?† O—ø¾ ixþïŸÃ^'€‡ûçðÆ—‰ßà!þùü1¥âwø¾ ixþïŸÃ^'€‡ûçðÆ—‰Q<†û§ðÆ—‰<²òB¡_Ý~iOBѼª±ýßá‹^¯¤i" ¿ )…,òÒ 0¡7E¦(TÅ_ÿÓûùŠ»v*ÑÅPÒDlU-žÍ^¿)Hît„züi Ç—ãjþìb¶“MåˆÚ¿»v)´yR2»ü1M¬ÿ Çþúü1¥µEò¤cýÖ>ìVѱyb1OÝ»Zk—cR?v>ìVÓˆ4TZ|îÅœC¦"Óá„Î+5^ت5!¶(WT^1VñWb«kŠ å€7lU)¸ÓÕÁøqJCs¢Fõø+6Üyr6¯îñM¥2ùZ3þëv+hSå8Ïû«ðÅ6áå8ÿßCîÅm•£~ì}Ø¢Óh<¹Ó÷cîÅm;·Ñ#Z|b‹NàÓQøp¢ÓX­•i¶*XÀíŠxâª2GQÓJ.m×lRÜi õø0&Òy|¾û­¡Ï–ãÿ}»Û_á¸ÿ߆+nÿ Çþûü1[wøn?÷ßáŠÛ¿Ãqÿ¾ÿ VÝþý÷øb¶ïðÜï¿Ã·†ãÿ}þ­¶<·ûì}Ø­¢¢òú)þìb‹Nm´„JQiŠÚ}oh›aBkS"¦*ìUÿÔûùŠ»v*ìUØ«\WÀb«}4=QOÐ1V½OXÿ±ªß«Ûž°Gÿ?¦*×Õ­¿åž?øý1W}VÛþYâÿ€ÓwÕ­¿åž?øý1Vþ¯oþøþLUw£ûé?àF*ߧé b­ñ_åv*Ý€Å[Å]Š»v*ìUØ«T«\TõQ÷b­zqž±©ú*·Ð„õ…ûŠµõk÷Äð#úb­}VÛþYâÿ€ÓwÕm¿åž/øý1Vþ­oþøþLU¿BÒìF*»ÓŒtGÐ1Vø¯ò»nƒÃov*êb«x©ê ý«^œg¬k÷ U¯F/÷ÒÀŒUÞŒ?ï¤ÿ«½ßIÿ1Wz0ÿ¾“þb®ôaÿ}'üÅ]èÃþúOøŠ»Ñ‡ýôŸð#w£ûé?àF*ïF÷ÒÀŒUÞŒ?ï¤ÿ«½¿ßIÿ1Vý8ÇDQô Uw²>ìU¼UØ«±WÿÕûùŠ»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å_ÿÙgcl/gcl.png000066400000000000000000000302251242227143400131010ustar00rootroot00000000000000‰PNG  IHDR,|äZ}ðPLTEÖÒÒoccàèæãÛÛ©¢¢çæ))œfgâèùûúéìííÄ¿¿æšojhµ¦¦ã••þþþýüýxijúúúôôôùþüÚÖ×ç弶¶¿¼¼ä÷õöõ÷÷¼’‘äãã{trÛÛÚÊÇƸ±±çýþûôòòëÒÊÊ÷øøm_`æ„„óïðäÿÿÿýýýüûü•Žéåævvãßàynn¤FFujjÑÏΦ³­­èÔ36þþýûúú†{zÒ¿¾ùøø’‰‰ëðîïŠìêëÿÿ÷éèècy93tEXtSoftwaregif2png 2.2.59·® IDATxÚí}mCâH³6‚Ä`ÔHƒ/Èd *:vd` ÿÿ߬‡K`&PO H¬Iò€­¬s æŸ4›8´ÀäÝù $ >'ž¬ý+~÷}´2_ƒŠ“hR*ã&ÊÍ^oܨ·XT»ðßÏÏÏ›ÍjµÚlviÌŽÅ#}.Á%ÔN»¯¯Öy¯·ˆÖ€húª˜¿ù÷ùùl »|tŘq¸-ßçü/‚…“‚9ïÏÓ©mÛAäãà€ÿ8½5»çN§ZˆÁ#qâ,x!ýá ’EøÓÜðŠæ¯69ZïÌMI:P`¶ XÁ£ÍŽ/üö,‹Ü€~Ûïf×ê#N9Ø@Þ©)0êkC¡a®ìé¨S-‹f6ÕmÎvá¡hCý‡r o¬µ‡/eP…ðoýÞ”Q6_=œ?·<‡ùçóy§Ú«žƒT ÄÏ ZÏz±ß9À»Ûí4k¾Ç[™³Ó ˜nxü~¹oµgT¾®ÕTU¯ÕÜP×uY øW= #TUUÓ´â5_,Ë^§Ø9ïÌè‘ÐÛx¦Rä*‰ë—‡°P©=šyµ®huÕgµl§ëÔjÌ—IIßêRš¢á$’$‡2Ÿ»?q74ðyu%oçËVq4ê‹ÝfµÉ¥=âpiÛV4&FDTÃ5LSò”`Q-zÀš½Nµ)мÖÇŃðžÛ¯° ESuO5Ç—pF#z9ÂK2Ãz]’üºë)ŽYÜFóѢ؛ã3ucæZ·°``!\G᤯PÉc®‹ óÙ}?"‡çÁº¾Ã͸ÑØ·È÷ ›æóÃs¿–^:â—ØÊCx8£^³—­Qk±„Gƒ¯‚utüW1ì—¬r{6¦Ò<‰nM–a¾ìÈÎ*XÄ`ºêøPÀH¿i+wߺ_Žp;ÈñHÁ Iä‚ØG/2Öñ§ìo%ÃǬËৠñ`þ›Öý}k´l-P{E,ÂÁ*¿äXÝõ6†áªŽìiù›ûKø«ßů¢®çtü'°@‹ìÁVWYÍqBæH*È„$7TÅC^(,F „öŠòÓËËËûœx¦j3ÍïˆU˜·ÜžJÝXXSà ÃP¯»B+ H¦ zÀsuxGQ‡ù[|~d.´#4}éuR¨‚økÃñL&kµ s’¹Ìå.s0W‡sý¬õa°ÚM@¦IÌQ%C•83; ð²ãȼåº5اçÕT$UuƒéÉÓåÉe«Õâ$Ü¤à€Ÿa û¹ ®è¡çâôõºaø¦éè®+p–"ï†8dßkÀç äÝLæääòžÃU7]:.Í‚FØ06†Œ¦HöÓÍÓS&“ɉov"½õO`•û9ÛWBÓ AW6×4=uI IÞ³k †i€üù” ŠØñe-˜>Ýˆí «¤·J’>œÛ’‚>d¦ê™€3Ød(&ø*Z ˆ#I,ˆ(ð—ëHLÁùO29Æ%¨Æˆ%sЕ68_f†Á$ áÕÞÕÕÕÍS†?Áüu°Êf”ÚÖ«W<§[½ÏY)\]M£‡*vP=ãCYh6ðü¼·ö4_çöîÓë0 ÆÍ•˜Yì‘$Âüe ¤Pj蛟÷˜ç¸Jáìôìlðâ_DÖª¢uØ®´þ Ön ÏóÚ¹(®6˜ôU°˜—·á±† ê—\= ­áðÝ7ðû=»Þ¨ ‘þìüjC²Kâù#Þ*ïö‚ºÏŒm`É̾~¾¾>E¸n­ÑXëÀÊ´ûÖ4¯¸¡ÉX¨~,%8==› rI„Ý€ŠQÁ¤\m¥è^ä{|v~p;ó‡{§W|×D œRîO™ê’n]K6t5ô¼søüŒpá÷À>çUâø¯þU¹c7ê’‚ êç‹£k=_ãS=! E®&/Ö.€ZÖ”)Žé9‘×ùYb8’[8Mæ'IDÿ´RÖR`¡äû cgçùÑzÊàc!Ǭö°< ÅÉ×]ØŠî~Yg…žVx>äu‹8~báq1èDž ¿ÂUœs-ÿ3ÙvkAîï¬Û 4Ç«³'†àeŽöŽ.|,`-úÈá×9 Ô•bèàÂ9õ:: _‹yZpDŠ+æø™eMÐÙ'[“¤œOaï> Skijt_¦ 5ô²ÛÀ2ó?~ÿ¾E¸v@é[­¥kð5Îu¥7˜g¨¾ƒžôWÁ‚çuƒ@ENÄAÄÙÄj÷‡m`^•é«™ÎÁRCP@uÚ7Qcb+¦®ê©ù` oüçÏŸª °XC—ÝwLíËbè…’YÿÁŸkXž³V¹ÙŸX€•${²†Žà,çó ¾!)ùÄ%À»H T[Ý9Z –ž6¥~ýú…hÁ—¯ÿ,—RéuŠAòúC9&ü'WRag¦1¢œ­ÕÀ;ÅÀ†™.xu5ئ“*…a-ßÏ"Z VZËÞ¼Ùœ »í`•Ú>><X0*cœ ˜ol‚z’áÈôœµ@©Œæó*`å5T5í’ÔÔDÔ®&ãÊ•Jw·Ì´sìë5ÇËßýúq+1sÒjÁš:(‡ÔçkîøàÛc‘ƒEÌŽþÅŸÖY *ê5¬Yò]ÔT.BõP°*0Pú/@<Zx ,É›`ž©X‚Ž{7'—àÆŸO™fx`ÉR{Óè5X~ŒÂR©T*D—LJq^â4XÌõ=¿ÀU•¹_½;Ý-`¹’+þY説‰HCù¸ë€.5\›‘šÌÞ°‰ Çê`º¸û…ã._©*~,ß•Üp|Á)/ÔéhTÍå¥Á|f:v“¤Š<<~C¤¹>¾ç몓ËðaO-D œÂ÷Ëi]ó%1H»Á÷ïß ,`Åk+«¬Ož”ZSÏc¤ozˆf6 *R•Güƒx›øõÇ‚º‰ÕR:K°ô,NÈѬ|ƒùi䩪 A¨uÄ:°ro¸¬P Í‚Øü3„ÔO—K[q™T¢§9+8°@ÁÿøÍ©©,ÂÒÁ*[“¶UšX¹¼N“o:Ô9j -|7¨\Ð*œ­©;à4™A,áàÝžÁ‡®›¹]@ Aφ\ÿôtÒš£rßpåCƒ˜Hy H g*„Šx÷ÏŸ_DFx“€ oÇp)8Hcã»DŸ.3ùt˜ã:p­Ç¾g ˆz‰Ê¢ bðQÎ*Y¥6Ķà'† H+¢ ¿ºªÙ”T‡ Ú‡q´ÿ³ eÁX©à§òk,´d…ïß¾!/ÐP )¼œæë)Õc:a]õu‹a.ë¹-0Hàsº`2}]ÛìcÆÁÂÝ«\ÚR65¿çû๡Xà:€ý)TXOa ?Ö``µÛVÙ×Çc>[‹¦3ÖƒÊéuŽ'Œß!ö+À6ÅÕt2ø… 7e´ã;á"Xøp ~Ó΢ÌdÕ ÁÖ‚Fˆ¿=â2œ"ÇÁJ·ÄZ  Š‡'ý@×Á+hÝ„V|º,(á°XÍÝ1‹KíŠv¹ÊúX˜zøRšª`‡CgEÖ#5/ >V`óAoä*~б³sx¸ólûuä¦B¡* 4>9a•Š#\ WÖЮ{iOÃ0·€ü­‚(ÇùMA’nía ¦.tÀU!1G…}±ÊYÓ ¾Å…àÃs1ê÷Ê…Âkô4Ðq ãÕ_²–Ê¥a ƒ5³æ4˜á­ñ*^ä«o•ÇdüOŸ¯aÚ¶}:Ú¿ý-ÐB쎔3a%béË›|¨¦¬T–©YCmä¿WÀ²ã:\xùY Qdçy¬™ºoúàÀ¸ª”œ@`#æM—'Ûh¤ÿDIáñáªö¢Í^²¶Ë/¶QK('SF\¬ønáÔ°V%ÚBuxˆgÙ§ggg{g§g×€ÛÎÏ££ýß?~ýùä<OQ2—à0¦]¬C˜ÍÑ¿ŽD0Ž(òü|ZP'rí pðÐ7>@ö½¸ˆx}ø@QÓž¾Žws>2Ö7Tïè$G±ÙÂã7/¤·€eµ!Ì ÍPsÁ$mÄ·ÀöàN#V•+Üü¡8õÇ[¥)üczzhsýøñG T9YL™§¦cB=„šQ_> \ýPÑiù)’¤ åŸ ö>.ð˜—dýaå‘WÀ|¤ÅBqKâR¸b ù™rµùöë°ðºÛ®« ¯tUUWM¯Ž±Ž|õ¸ÂW+<žÄë·§§›§›««³½ÓççCb®Û[°_Ü­¸MÎpQE ¸飖† 1ä÷Ôí`#¬bŠœM¯¦WvÁ¾‚ìÀ „Ö¯;>øa?žÚ»¿d X!Ä–®Iá¯Ä}oðØþ`vµ¦nhÖÒ§w F]§Â-šîБ,]àÅîÉ ü@¸@i3ˆÐ?²–ü^ÚaÕ¢-ü½æ‘b\ø°úC`¬,Këð³ãxwâàˆœÜfüàhµ®“ Eâ.Ït÷{:ÝãŸoŠ§£D¤b6¦$$Ñ*Vļ°L —@z\§Ä\?ÄàrÎyt"Dã©XSö=— )û¯I\ø°¬Ȇ§¦Á2C3W%Ü@óãôžà´ÄlH°Ü 2áEƒ¬Ì<Ÿ2:÷ri°¤ïˆ²oä3qŠp‚àË_B;g^”rb^!çWy$.}:á2O|çó#X+¶°;{37k+Xí@1@â¤- >]òý[t„Ëà:,ÁW‚³rœðÖÙ©×°…½éh§Ü} |,¼Dж\i߾ǫˆ#Š3~ÍŒIAÅù¼X\\D"GĽä“ù@9·5 zZ'!ó$Há¯u)Dô=ÆJƒ•cu?ÛHƒ%ûàUFDœÃ2Óࣣä‚?¡ÚÝàIÆ–‹•c!ü#N=é¢ñ3»ŠóŽ9À…²H¢xq¯`^„ 8 ˆ¿Åu0u&'qᦾã‘nËV@ÃJi1t!($°8ûþ>¢oj+›³€5ü¡høïô/€É§m\æZ#[KÕ€° %†¹@x,w'Ï /["ÅSê«Þ|!˜ àB>BÎ sî>“×d‹µ…0É`q[xÛÂλNÖ*X%Ìn—z˜ %;rjµÐGIONb¢5 òû©xÏB¼'‚¿šÁ„ ÜwÎÆñ$ÝÃCS¾“!êä^^eø3¦‹RY ÆÑÊ]r·N ôŠÁØä.[E»!{®TK_®¢~ç4ßf ?V»Sj÷­riZ¯;NcK.™Y#I§# øRàišoüå¶Ýe#Ëxâß zI`Ñ–Ó| ,æ‚s’õ=TïßQ W®0n£¬¼*UŽÌfÝfµÚ™ Íu‚n tŠOrdmæƒ?¥§üEæ{±-¤Ó™ç•¸pòQ°†íR© ~Cc;Ÿx5ZC,ÂÅcš±ë<Ùöm´Â°ÁdYWl ÿùc¹û¥­¤og\Ÿ†Ëz|‘ÀÓ[F<)FT%w.Ô\£÷ëh€€c–d Ír.ïš’ÜHê—óÊ–¸ðc¿M°ÚíR¿4ʃ¡?©M«¤K¢EÄ lÞ+¦ý3ˆéú6‰ ê÷Üe.ÐÒ§ÀYäÊ‘¥zŒÏƹFá7żÖÆäxÖE½EÌÕŠ¼arÁ0b¼©ª’\3RëH—‡ tN¶ðý¿LröÞXS¥êªž–C—KáãÃêÕßÔ©ÿ , |O Àùáþ(8¤Ózú´AâçL\½WVWáñ+^Sˆhsu.À t[¥æE¬L©‚Ô bªi?k,ÀÚv:óA°^¬~»ÿŠœÒp-Îâxõ„Ÿ_*_ÚŠ±y ›>Æ°4µpvöŠÌ:8YFJ—Hž`†A¾ü¸7¾ÎkRf;¯4pæj6‘»Š 1¨à©7ïôªç¹¼§Ê¬f˜[ìH:.Œ˜ ß/WË$G~åWºP×)°¤qŠä™LPwþ£äü¼MgQèZ …[ò¼<Ü"´…•DcqÆâ—êÑ^x1*G‹„QŒ–ÓuΛͮek&¥=Áº{ ¦Ï£ŠTQÌ:³š“ck”OÇQ!¨E‘#–Âka {9pØpJ_¥Ù–«)CvtL›'~C¤KN9›Õ`é(_÷5©ptž\᱆¼ÅSu&ôÉzÔÆCÜÝ~·Tî[Ö <é—fe YíøxÖí&¼T» šÇ²ašÃÁÎÈLÜF§3×±~¬~Ém t0ŒLÆã²o›‡ÖSÉ×+v¶€¥: I ~ßÞŠcôÓ½SÀ¸¦§ý< :oˆ‘ä³Ú´ÛƒÒðÅzm—†åÒäu8™¼ÎšÝòLŒ¸¢¼Ô.[[ˆîÐ}!‹î ï6î «o'GnkØßÖ·U3“Ò(øÕQLr0j’ëÿÍu0œÈðoqˆ‰®¬Íd¶%cˆ…RMâç ´ÊŠ¿ˆ«lµ­~y‚U/“ãV„Ïf“ãó,ŽYÊåÓ©Üâ¾P¸&)æÌO>–5ì·m×Mm"“ß³qùˆÓ(2׫µµ¢í^)óX!N Ö²5'«úé›èЯ‰ý\IÆC×”Tið:Ž^¹ÂNf‰FåàÃaßÚíÛJ:ËF6Г†DD?K¤R>Ø^¸û5ÐÜÔ&ÀD!Xã(AgE e³æ¤R‹ÒW[¹ÞEwÑÈZ …^,NV] Ÿ¨|“ü²6諲•Ë+=íu-ë ßyµ)!Råý°Ô sK†Ê'k…èÂ3y³`g+Xýr/ÐÒVJ–ܬ‡‡»•Ì/¼#eµ¤¨ò7}f({ã‹8%Áò˜¹íVÁŠ€b)ä‡rX„cuÑif5EÉÛÓÜëy«y•:4yíü1õsDëi×b©¬Ca:S«+ÜãØû7)°¬>Ÿjm XF çÞCž©( «kQ1{CJ§/ aá¡ß«?‚1µmW` Vd i•ˆì“Á.ž‰À“x¦ê**à5ªž7{E^ ¾Ò7b1›”¾C  Vé¥lMÍF:C«+<“Œ!ÙÛ(YõfºÞ¡P(€ªHûO¡àýu|–g³,xT)°BÉsØ÷¬•Ì%xš»“r´¸O,*gU´|0Í«åÌ=¬ômòó²…éUI%æ®ÜÚ¯ÙBRïŸë("§-®¬Xµ¬„{—ËâÄ—­ËÌÓÕÙóÎNA‚ÇÙ’ê9Nn¬âÛ­`ñ«ŠÇõ³“VýBpm,‰á]C•M l»U,—ò²ûîlq¡»%/ ÀÊJk®ÉzÛðï}L2Iøïµ4gøû£´î8à"øŒ£Vî郎@m¤Ù}fá¡ñ/\ɯ¥]+”øIìZf 0Vqb3.»Î˜÷UÉó4ˆ:§'£8®t8Xm—í:¸…zÚ¹ç8XqM62Ø>VÀ å´I °ÖN5ÀLáRëòä‰.ðlÉ“õ ø„X¨àO h”4XÌ7,nÖÑ)‚Ù;/‡¨·Y¨FfÄ—³XL*u7°ñn ëÔ®s°…ಥÀÒgmœvM")Ükr™ä¬ `ùéM€és°ÖÉVóå²uòtƒWéÍsj©ó#Ý]õýžaMS¸åÚÞ7™”Þ fwv±)æêÖe–adC,ÐÏ3M±éòëÔçs¼÷¬É[r ßGrÉ}¡pM’>©Îmop€•UÓüYËÇÌd¸H«Eš¢ˆbøtsuvú¸>K×P‹„•¡ï,Ó÷Ò ØÄ¿Æ—û-¼,qœ\š[=p§îE‡’Q«™’¡«`âž° Õƒç綢²-µ@&sÌä¦âG\¹p¿ŒÎ†Q‡¶dlàƒµ‹:ËIƒ%{¾Êè,:‘ãÕ 9x´^t+Wð{gvžIÙt2?E®‰µ°<ËMq ±6NéwôfX8†Çö¡ÊÌÈ÷ õlȳI%;é5°\,‚ºì¸Î°˜·vFÑEÞÌáx2ÜlØ6Øèmƒ5|Î2Òbhz€¥HñEÛϨ–«rØÖ‹t[°ÞP·ž°$‘ë^ Xž›¾¶Ã4XXئʬ)Ì:QÐ%ÉGcJጟ)ò&'ºÉÔP•Ò—·Ìû¾©²nø;³¤YÛ$î»5ÆÛkжlÅ•ý·âñ÷ô+’m ‡`‰»Îi ™SÍNÅdê,b}îuXà2n9(õÀùÅ$¶•ƒ î0.š¬Ëßü¼ÆÀ|†X5xx}}F)xsT´.e§­­8#}|X«ò@;Q@ó¿“œtá·$6OºÀ$ Þ‚ø3tÞK`°ƒ$Á4 °"#òž—‹QîòrjЀ + Õ‹3]Á'|æ+0VÌÛRñ K¦Ç­Uþ3²ìœ[Ó@ÑÓè6$°ÊÛ;<ï ê2wh¡©7ü-ñ<–`Bó¼Oç•iT|~.:ybO¾™eÍšç“8àä=sÖÁ*ï–¦J]}ó¨Å ¾]ÜÝÎ">“Ë‘Ÿ~鲸˜Ú˜±²ÅZÂö† aa8æFRõak ®,V…’Ýø£H΃À, ìç9t·íl_v)%iF™ÌýTrälj~¢xp¼Ù«mj/xo<LDsÚ5ס?eZ:_*¦<–áÉA”ñ~`g¾¬ÞOƒ|Ô¬©…+Å` PM“Õ\):¾?€Ú×K·;‘B_†¸až€Yÿ­eÆÆB>ŸmÉã2AƒÛ}ž«ÉÓ’îA:LIfi°«|x-2IDATBÓ•™kºÙl¶V«É &jÍÖ©†m¡’ F= (†ZéÖƒ5iryEz³`øFßý¹å`q®vr šâ‚' Z–V:Š˜Ž—Åͬßḃà^xu=] ÿ=k„n>(üúÍ3)¦S»¯ck(-‡1×3,Ƽ¥s2ʉx‹#Ôûib€sŦ®ëÞ{Ãô<Å.ö¸BîtâÞv¨·’Øp0WÆ©½yÿ'…š›„Ÿ‡[<ªJÝ4I£‚qžW+e¸ÁDhwÉÑýM“Ób"û>ö2 ¥·…BäY£ΞcélÆ”|áÇ/̹ݧ{{O˜.Θì¨[*7Bjäåó&VþJ?­¤ƒ×S§KŠ‹¤·¢&:Ëšíöf¯¦ª¡§(|ÜJo€ø…5Cwݬ®R¾š˜læx!3$¸®Þ á•¿ÇRXÂcB,óþª×WQ4W•ÐqñIM÷“PÑ{S’2¥É‹š Í𙤻ipQf=Sf‡#(ªŠm¿bÈuP2÷`)Z¼ýf£I\ñ³Êåf½–4͸ž`¹´Mó ÃÍ2l”eÈÞa Mð‚ï«'TÜé°_OW®Ê¦««Y]Ïb§5æKNƒ1_Ö±ÂÙņ])Ä‹BG:U¤dÊ@q±HRK_ûØHA2¨Ñ"F¼å˜^[;C¢§{L2¡ôUѸŒ7Å[å,«œ L—ˆµ¯6»Ð ê1&K~ˆÆ->IîL§y¯î|¹M xs˜Œª1%?\ðê):°u~¹±P\ø®»‡Xú€éK9ÑQ‹®VÁê[ÃI'P|5­šVÀîÜáë¡ë†ž ¸»?VV‹¶©pNßÂ*î9Þœª"VX<ý…œuµ-•é“`9ZpzEiÂIÿ1ÎZ+`µ‡å&VÂ;†^—¤†ùåÍ0<:QU<É¢d«ÇÇ$mŒÎÁ`ÞUçËÄ}#Ä’1–ý?&űȷÛî ? –‰áÓéÞJ·6Œgt8ƒÕ o l(7Ø×w£cÛB¨%Í Æ¼#º­A+ ¬}’WÔðË=m$ $øªr€åìwqNóÞ¡ëý3X®oŸ&9,ØI4ZkrØÖ ±Þ±ñõÖO¦úˆ9š)¬øŒ”˜ûܲ«|¹áÖ ¸Ï_UxÁŠ¸Ù¹F)4ü+Ø9äéô¼[±冭€U¶v‡Õê(pC°Ê[üšŽšÆ ¥Dlup$‚‹À¤-qñLJŸ…ÉÇXM{ °ŠrO§”Íý`i¬žù)zÛÑ%¯8J]k·<<¯–¦’Â$Ó”j_ÖYŽ§¡[9 *‚ô?Ö’øZ‹ª-_( ¾1ö/8 š|¼¼åiWvÞûr³Ë¤ÿÄ#*âýÇnâÖvkbØŸ”»»çs؇+×BãËÖÉÔÛ1<_­µ"ó²X~µtP…TÐN÷kXÈU¨ƒ:5ý_ÁÊÿNºµ%Ok`õKƒá¬ÛìÌ‹6 a>x†àÞ[×ò+~‰ëʾ^±id³¦ê2u^‰°â»! °X{Å\P¯C¼â;"‡h<õ·æ—ÀqÄæSLÂù†êê BM]Ö Wy0²lóyåð©A(X}•®GÉ¿ÔŒ©¹¦³ú¥Òð¸Û­Î{èIÕÉÔ-[+ï*îbšØ¨Ø3ÌvÇ8ø‘š>D þ¬¤³cïãžë,¦àûR—fè…:óý7.µ%³`[`°°8¹ÐWÜ¥ª±§C¼Yù4Hñðjód©p÷+*‡Rð—[ÀLŽ»ÕÞbžoËu\ÝWõ—ú¿ËYÀ„*žeé°c…:<Š5q†C$„àµÌ«ÅâršW٩ˆ‰¿ó&X& ˆMl?ƒPa÷‚.‚«|µws‰½stõo‰*oÚ 34YÍ °&æý)nÞ“Ök` gÕÎbÞº´ëØl¹… ñXžGÍÆ!Ó@þ@4¨oLÔK$*YŽˆ´è`61€µœâÍ…ÃN‡é[×d~Oõdºêõ$‚ê‘÷zXÇ ³Áq¨™òW‡Ç°r|qñÅÏ+ißi°&³fµ¸Zªª²Žþ7΂-€Úq½È Eí.D“âçýÕÆ–tÞÝéõæ½E«…•aškJj#|,ˆ1CtÜB`ÛÂÁC…w â 5~‹‚Ts=õêºoêŸå¨$·Êñü8‘“vü–œÒþ:X ‡çÅQ.—™ÚùºæÖ€šUð8U2Ø¿‚é!n²“´q8­öæ³jµÙ+.÷÷ ‰ì¹ö÷fo‹¹LɵªÄͺîâ6¢1é=¶ØôŒ7­Üß¼ä™aðbÅÙI­å”Z]¬¢»­S;ÐOfxûXš‹­M Ò…hÐvq·Òñâ0Á ƒÒóIõ|ÖœߟM _»°¥3[Ò¤ÌsCpÛ(ìé²Ò+HåSĉá¹Só²_ìa0¼¨Î:J2’Š¼Ð¼´ZoÈå° úd„é g×ö80µGëMŠÔ:-ÔG%i’P½^¬ Ÿ£!iå(ûÆ.¾ë¥ûŸÆbžZ|'_4ü}±UÌ´T¹9U4¹ŽEs#ûÁQ3±ø;œI+&0±¤ß{ÛÁ:ž«µÝ_fnöÎΞwl<•šÑ Ø–Ë+êSX*ê:õ ¹Üœ¯DÿÞ¾C©ZÖ‚UNíÂ8ÈçYk8=¾Œ«cóHŸúIUEñXÀy¯ hv~8›Fã0΋ÆxË(lÜy‹¤p%qd¶vžE`¡=l‚BY¢ RßlÉñƒ–KêwÅbÔëéá"ÆI´M£ÎM¿ãžQ‹ÞÆŸ^Áë1ÿ&Gù7Ô·æwwï\[…¯LõP‰­-°¿¿Ê´(ás–e‹‘T<ïíßòÎ+B…Äý;ãdém`MŽ›ÈZËû\†§Æðž?¨]Ñ]<'Âô´zŠŠ™jªËøÈ‘ÞçuL±2°ÈVBšÜþ¦–Hwwol#¢ÅïªHE pk,ׇëW.âq÷ƈ1E–ãy­si ,B+Ú•¶óEy ÒÝÊb H'Ñ7-êÜt(*uDm>86EÁ ¡ÕCA„M·h•Û•U.„­Î½»HÖýÆŽâîV2ŸòŠËïêó‹ãµZz ¬èQ‡–gŸEIƒM°°4 d¤Ú›“ "oFýwh'’墹9LDoê85]Q‡ß  Šwp`)*‘„Ô6g >=‘h_»àKÄLËÛ­ˆw0,¨ =8˜’s+o¼rKWþ|füŽlxìFó"« °8ZǸ·ìOQ“ ÜÈíö•E^oÂyêðYtWØïÂéŠLõ%üW9Z—O´ oü±/¶«j~ÅËü´ˆ :[ÁNµŠ‰U®³24!uðâý‘q‹c_4Šºéó#QÖSÚhU€"§:0ôåeÜðE´0Á¹¶­’ô0¢ˆ7hPç˜ûûQtûÖnvdI-ÚÛSܶ†/"ºH‰ö”&ÑÁn‡·†âóó6Aˆã.‚U$¥÷]I:¯DCÌD{Ù~Áß“-Ô^ˆZüó¼‘øA›}8ÕIÉ·îÁZñ<Ï¢…ÉÚ2û·ñRI#qzÍ¡Ê ¨6nÁ¹%Á#Ž9V„¯tù=‘èÙ÷WFD ÁT‰ÙE·Æà‘ðŠü¥m&Mˆ}tìììì$2~üEUùén’TÜ$ŽÆÌ+j2A-LÞZ;ZAô6áH‰–+ˈ«ºiŠtýÖ"ñ§1×Fi¤ÂÆb5<5h[ñÐ|ºç¨qЇ}žëÞÏûŠ‹>"¥m Qÿ YëÉ!Ö>¤&Ob$ $½Mø…›€*¡ûD°r\ŠJ›ëóOÔ(åšVÙº-qíeü¢+ñŽ>B+žKöÁ¹þÔ8Öˆ¯ÁªÕ$í;³å•àC<lv(o»õà‰šððIŸDq ˜¸· i*NõEò=®ÚãdµÏ¨~¾Hj;$‹œnÛCÜ#)#,lQ¼6Ž„‘²­öŠIÛœn/ê½ò‘Á?Î׸L^ð%2oKl„ú½saSl$s•¬Lø¬,!z›d"¤H™¨¢Wî½r.* '´D)Ñ(ee‘ÓôØ÷ç>QVMñ"Öhºê øôÌŸ7|Ñ{Ö¸ó.òJ3ÛÞ6/4 ßÈHt£ÅÅê{ ’P¹{ч‚^ÌפWçm{‹n¢·¨óGB”§¸µÌÚ"7QOAÞI¯‹§çͺqKÑN/j¼òÑ‘ÉÄôo³‹rÙÞèSJû@•Â»L—¢Û61Ù²:Ÿ?â¨)ñŽÓ«-¯ ¢ˆš†·þˆá„¡­ÁÛ§ÜsZ“W>FL+¼·&ñdlBH?5rÑ"sÎW+oiÍôßx?5EìÐM9¨‹ÉeÔöeuðƈ¸%€‰š#.Izt»¼Oº¼ îP´JÉ¥W-RpZôâ·c®d« ï·!¼V:¯|p´ZbÑRi6™¬P:óÖ;œIcRßÑ•ƒk½µÂ P¸‘æ,~©óF•Bi]Þ97;Ñ"Y4ë]fxòbT]¸òRñ‘9•ÃÅ'ÃŽwŸô Þz¤Gí§ŽWíÒ;/üDm&xWŽbqÁ÷Â{Õ Œ¢0|=^WÊ]…õ÷9¿ÍÁ‚«áµXrÄâ!6Y‹sÑmlÅoÛp¨'¢_T‡zˆqã|,þ2¢ÏE½Gh“õw¡fÞÙ g.Ò]È_ØÇdÛ¢+ó7£‚åä5ô}Õ9×\ÝhZ¤˜ÞILŠ•„ëÍ:.ì#r,ž'£Øúƒ£#F5~ŸzòÂë¿¿ð#òã­DkÏ“‘,Óƒª‰tüõí‚*1\|•ù|}¾n^cJlZX”ĈÀb¬t^ùРOv‡g[¡Ó{›¡‡ˆÐ[/›Z«ž]uJx³}šÁèï®0øK e4Ã{¥pïnuu_}íÿôø,ÂÿÛó}¬/pÊj³ÿG+ÿXÿ'›(½µÞ××-ýe|„3ÿ¯Åðÿ+ÎÙè2zÀLÿ¿ãN ÿ ÖÇÁúOÿ«àF¦`{¹©IEND®B`‚gcl/gcl1.jpg000077500000000000000000000411561242227143400131660ustar00rootroot00000000000000ÿØÿàJFIFHHÿí ÆPhotoshop 3.08BIMíHH8BIMó8BIM 8BIM' 8BIMõH/fflff/ff¡™š2Z5-8BIMøpÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿè8BIM@@8BIM V€4€N :ÿØÿàJFIFHHÿþ'File written by Adobe Photoshop¨ 4.0ÿîAdobed€ÿÛ„            ÿÀ4€"ÿÝÿÄ?   3!1AQa"q2‘¡±B#$RÁb34r‚ÑC%’Sðáñcs5¢²ƒ&D“TdE£t6ÒUâeò³„ÃÓuãóF'”¤…´•ÄÔäô¥µÅÕåõVfv†–¦¶ÆÖæö7GWgw‡—§·Ç×ç÷5!1AQaq"2‘¡±B#ÁRÑð3$bár‚’CScs4ñ%¢²ƒ&5ÂÒD“T£dEU6teâò³„ÃÓuãóF”¤…´•ÄÔäô¥µÅÕåõVfv†–¦¶ÆÖæö'7GWgw‡—§·ÇÿÚ ?õT’^õ÷묺·Òí5¹šgd0Ã"~ËKÿ5Û¤XÏø¯ôŠ~W•ÉÌåáç)–ýâ‰HeÚëß_º7H{ñªÝŸ˜É¦’6°Í¿!ߣ¯úŒõnÿ‚\µÿãO®=ÇìøXµ0ð,u–8i¾ƒè®Gö½´PÑ'À»ü•µõm¶€ –=ÝËk~[ƒÜ¶åË|3“9¿Y‹õqJ_Þà‡¢þó嶎‹ƇÖ0}ØØocQ˦úµõ÷¬Øq2iûpisY»}v4}3MÇogçÔöýô‹Ï3ºQÄÊ42‹oah{lc Aü׿ù¶½»}K¦ôþ¥F~>G¤jôl%ÎÇÑÑÝùŽG™å¾>\Î9qâ"|&¸¢=¹Kô¿¸¨™Þ¶_jex–™Tú¿\é}duÅ-v•³W=ç÷j©›¬³Ÿì~zóëz?D³? zÊ)˜6ZïæëŸÍnž¥¯üÊ—™u üÎ¥™f~}¾¶Mš9ßšÖ[U-ÿK?ug|;ᇙ&s&8bkOŸ$¿v÷Ëç>7³Ïÿ¹Ž3§5¬Y”ýOýgvÏýˆTGøÐúÉ2qðÈýݶú^ªÁÂéd´>ÇzMv¬hâ?{ù }S¢]ÓñÛ”\]Apc‹„“ô?²å©  G/ÂY/‡ü¤î»î|œK ÉV÷_W¿Æ5G%˜]F‡“o¶›íô½ßè÷81ôØïð{÷²Ïô‹°®æX%¦W‚²¬‹u {,syµÍÑúKÓ°úûðúFOP¿œzM›OwÄW_ö®sX³¾)ÈâÅ—ÁþTðûWÅÃ?Oõ½|Ká"A¾Z=güeåaul¼,<:¯£ÏHZ÷¹¥Îh¯µ­wÑ·{Ÿ«?^óúÏP~6F%XôUY²ËZ÷8É;*`ÜÖý7Ô/4ζÖ8—=Þ.qÜ÷iåt_U«±.n†÷I?Éoµ¿÷åsŸä¹N[”$cç§grõOô§ó~äg5±”Œ·Ñõš®m¢ZŠ¨ô¶9´7w‚¼¹æWÿÐôO¬=Tt~‹—Ôcségè›È6<Š¨iþK®{7/.{œ_c‹ìy.±ç—9ÇsÞï뼯Lÿv=½ѶæÖ×ù]öþ{¼Èðº_â奓ô²Lÿ‹—þí‡)Ö»;ßWð‹Ø댓ü‘£ýýjõ_¬èÿ³ñ1iÈ}u±×¾ÒðCßïôÛéͯfä_ªU×ki{憴xð µ[úÅõ;¡SöŽ¯Ÿ›‘[ïs­y²ÚšÒâ=´ÒÓN÷}NªþšÎÇ—N{,¹¨ÊveãR— #éÿ7Bòˆáqlÿ}JÆíNÄë[ýêÿÕŽªþ³•xÈÅ£šÒ_Yy%ï>ÊÿHí¿A®{× ‰"'X<Šê~©ÕcaºzÏ;ÏóYÿA^ø§-Êrü´¥ QŽIe§éHüß¹°”‰Ôµþ¼çŒŽµöêý5¾ƒsÀ³%ÿùê¯úÚÅÁ de2· `÷¶t?ÛÜ&¹¬¼n3Ý;E¬Õ›ãó,nú_ÿ¼s+' ÷cfÔìl†uV:~ã¾…þ]kÞȳ:§G§5…¶1¯úKGøœ¹Xœfæ2xªøe Tú¿ÅY8qk³âÔädc’ì{ì žMOs'ã鹩ŸeÙWo{ìÊ¿Ïs­|xny{š½"ß©x¡ÒÊ+7û‘*ú¬[ G€¯Kã¸Å˜`%V3É,†Ìøø4Ë’×L¡ÅZÓã{ëýæýá4Ðy,ü©ÿÍ6~èû‚_óMŸº>åwý?óÿ ÿ×k}¯ŠúšjÇênÏkZ]K u>ÏkÝýš}¿õÕêÝ3!÷VîëêÃkx1º?& þjùR ÐÒÖ¿õS*üþ›ýR?0çÿ¡Ùÿ”<ßò®_©iùÑùS~Álÿ2|±rX•Pš­©©ÓûÌ1Öà—,‘ù†œ¾Ìv®/¯K˜É9~¦gcæ'SC.™©ÚjqS%¤ñΠ{˜Ù†dFb\ˆ>çS›O“ ¬‘”OôÞ¿ŒþÐÉ5+¥Ê·CŠ àâ«ñWb®Å]Š­,*—궥CõOP¶Ó`ß÷÷R¤)·_ŠBFRÜšmÃ&cÃŽ&G¸~æ{ùÑùM§?¥{ù›å{i+N«ZƒQ¿ûó1å­Áy#óã²ý­”\4™ˆÿ…Ëõ!­ÿ;ÿ(ï$Úþgy^âSJ"j¶¤îiþüÄk´ç–HüÃ,žÊö¾1rÒfþ/ÔÍì<Ťê±ô­NÓT„ušÎxî|Ú6a™œeô}Λ6Ÿ&Yc(é¼Áoã?´2MH„¹VèkŠ àâ«ñWb« S±ÅTšR?dýØ¢ÂϬ{¸â¶KZW Rª³\U¼UØ«±WÿÐûùŠ»v*ìUØ«Ç¿5ÿ=¿,ÿ&¬>µço0Çm}2Óü»kIõ+ª¾­ÔÔüîU?ÊÌ-ghaÒ‹É-ûºŸƒÓ{9ì‡iöþN&"b9ÌúqÇß/Ð.^OÌŸÌÏùø7æ7˜d¸²ü·Ñí<‰¥V=NéRÿSu"•ø‡¡zÐ#üÙÊ꽤Í=±ßÌþ§ß{þ¥zùË<ÿš.ÇË×/œ}ÏŒüÏù™ù‹çY^_6ùç\ósÈÅy}3Bù0†¯û£Ë«Í—ë™?Ôû?°;;³Åi´øñÿV"ÿÓ}GâX!Ž2ÅÊ)sÕˆŸ§1éÜñK¸¯ò»YhÇuE?01¤ñ~¨ê:<ñ]i…Ö•s å Å”Ò[ȇÅZ6R>Œ”'(‰#ÜѨÓâÔDÇ,c0y‰ ~ß[þSÎeþey&îÖÃηóùïÊ䄘Ýu+té΃C%?–RküÃ7ºßÍ„”ñÇý÷ÖùWµ_ð#ìÞÒ„²h¢4ùúW÷r=ÒðÿZ<»‹õWÊ™ú'šô7]Ñu¾ÒõHV{;•4䧳º²C¸;íðæŽX ÀØ/Ë£Ù¹û?Q=6¢&1š?ÁæQ»Õ4ýf+€´pk–¸É¢”8×"1U¬ÊŠYˆUQRNÀÜâ [âïÎ?ùÍÿÊßËinô_-üÅóM¹håµÓ%UÓíäg½£) õXƒžÇŽhõ½½ƒOé®^\¾©õOeÿàKÚ®\ÿàØOY\‡ôa±øÈÇÊßœÞÿœÐüøóÓÍ·™ÈúT¤ñÓ|»ÕÜ)Úvåç&HeÃ9Onê³r—îëæû—bÿÀ§°{4,^<Çñd<_ìCì>÷Ì:®¯«ë³Éu®j׺ÕÌ»Ëqq-ÌóiY‰ÍLç)›‘'ß»èm.4DpÂ0¤@ˆûKh»*(ù‘§#ˆ—C±@G­”ËKÕu] æ+ÍT¼Ñ®á<¡º°žKiø«DÊFJ” Ä|¶hÔépê¢ašœO1 $>Fß`~TÎiþcyBæ×NóåÄžzòß ’ÝÍÄj–éÓ”s ‚ÿ,‚§³ ßè} Íˆ—×öCõü_%ö§þýÚ–M|ÝþêG¸Çø/¾;æ—ê_”3ô?5éZ~¹¡êQj:^§–Òê3³)Ø‚:«)؃¸;ípæ†X ÀØ/Ì]£ÙºŽÏÔOO¨†H þ7˜#b7z¥†³ÀZ85Ë\ d‘L\Pø?þsûó6÷Ê–º”´MN}7Zó¶¨ií&hfK ;Œ²ÈCÒ´Kî+œï´z£‹„M°~ìŸðìk»K&§4¡‚ˆ±Ç=‡=¶ˆ‘ù?!?Æþuïç-xÿÛÎïþªçùŒŸÎ?2ý3ü‘¢ÿPÇþ’?©oø×Îõ8k¿÷ºÿª˜þc'ó̯òF‹ýCúHþ¤n›æ?>ë–Ÿ¤Xù·]{ÝVæ+KU×÷“8Eÿvxœ–<™²HDJVMs.>¯GÙÚL3Ï“1 q2>ˆòˆ³Ñû±å-zÓBд?/[ݽÄ:-½Š\Jåä“ÐP»³Ib 59éØ¡áÀG¸SðÆ¿RušŒ™Èä‘• €â7B»¹=OKÖÒçÅZåŽ3&æÂÅŠ»v*ÿÿÑûùŠ»v*ìUùÏÿ99ÿ9±kä¹µ þQÏoªù®Ðk>m!g³Ó_£En7Y§^äÕìy5@æ{W·F+LJyu=»¼¾áìü 'Ú:ÎÓNñÇÊY<åÖ0ÿe/!¹ù¬k:¿˜uKÝo^ÔîµcRͪ^ÊÓO3žîîI>àíœlç)ÈÊFÉê_¥´º\:\Qƈ¡ŠÜ[ov*ìUØ«±Wb®Å_XÎ4~cÞè3j¾Všå¾£!†Ÿ1¤rT$Ê£°j©ùüó«ökTnXO/¨~—À?àßØPáÁÚ0«ðçæ+ŠûªCÝ]ÏÒß%ùÝnÄ_½­iß:ë~v!ôf¨‹ˆÑƒV£$ÖQþcóNƒäýSó?™õH4m G®5Jᨑ¢ýä’vU’vœ¯.X≜Íåè;?>¿<4úx䙨Äs'ñÌòrüXÿœŒÿœÄóoæÝÅ÷–|›5×”.94FØŪ ÛÛ¡ªFÝ¡SJ}²Ý Ú}·“RL!é‡Ú}ÿ©ú·Øoøi;1Ôj€Íªç|áÊóþyÿ6ºø´P €¢}U¼PìUØ«±Wb®Å_OÿÎ6~f_y_X»ò¬÷Mú+UêÆ&m¢ºŽœøøz‰×Ü é½œÖä8O)n=ãõ‡Ä?àÓìä3èáÚP¼DFg¿¾’«/²G¹úyäÏ<­ÐˆkZwÎÍù˜‡Ñz6¨.cB¤Œ“Y~'Îk~`Ž=uÛ+yým+È°Eåû WÖ‹÷·Œ?糕ÿb3Ï{{Sãjˆ£·ëû_°àMØ¿ÉÝ…Žr<ää>ã´?Ø‹ÿ9òViŸKv*ôŸÊJÛÎZÄÀÑ®b¯ûøŽýÕ'èÍç³úSÄy@_Ç|·þ ½±ù.Å8"jZ‰š=Sû„Î}õåo=Ís,cÖ&´ïå¿'¾¸òF¯%ÒDKZa 2}¦1hÔŸ “ðt¡Ø«±WÿÒûùŠ»v*ü×ÿœÔÿœ¤ŸË {ù?ùw©|Ãu_:y†ÙÈ{eúœ½&‘M]†è¦ƒâ?/Û½¬qÞ GÕüG»ËÞû¿ü à{ajk£xýÔ)‘ürÌéÄ|†ÿ#¦Ã8ÇévñCj¬ì¨Š]ØÑT ’O`0€dhnK ™!Šs"1ˆ²I êO@Êlü³#({ù¾¯]żtgúOAøçG¤övsYçú‡Úø¿´_ðeÒé¤qvv?ã•Çù£ê—¿Ò=éä>XÓ䢭¼Ž™œÿ fâ=¤pOÅó¬ÿð]öƒ$®3ÇÜ ?M¯¹ò’ÄÏaÍ%«†ªÇ½Fbj½œÆcxI¸îêzÁÿƒF³QÑ„gŒåÃ8ùðò•uçœIÅ#Å*䉊H‡¨e4 üŽr‰‰ ìCôfÐÍäÆx£ #‘p~!nE±¬RÌ<‹w%—˜íg‰ŠŸNE$xý™ºö|ÿ…q|Çþ ÑÙùßL˜ëçú‹ôòÏÌ3–€=»ç|’dvyS[·¶Ó¤¾¿ºŽÒÊΞòîf QF¥ÝŽÀ*‚IÂd³° !ŠY&!e)É;<É~EÎQÎHjÞem'F¸šÏòÓËó‘ éÕ(o¥J©¿¹^ìÛúj~Âÿ”Ny÷kö¡ÖN£¶1ËÏÌþ‡ëÿøû ÙÝ/‰˜ j²Yþ`ÿS»øñ *fôwbª°A5Ì‚(#2ÈÝYðËpážipÀY.höž›³°úœƒ8ó'îIîË"ƒËl@77!XõŽ!ÊŸìŽÙÑiýš‘–uä7û_íoø6`Ç#œäø¦x÷D~d#Ç”„£÷ʱ`ü)™3ögzfoÌØé4ßðoÖ‰þûKŒÇú2”OÎ\Cìc:–—y¥N »‰qÊ)ÙqâsZÝM$ø'ð= í¾Í{O£öƒMù);”OÕ wKô±Kóè]Š¦þ_¼}?\Ò¯#b­Ôgð'‰üfv|ø58Ïô‡Û³Íûc¥®ÅÕã=qLüb8‡ÚôòßÍr³À ‡¨ïž–ˆddIù‡oäï"ù“Î7Ž >[Òç¿ß·$hLIþÍø¯Ó•ê3Œ¥ÿ·3±».}§®Ã¤‡<³÷w?eøGy«_ßjº„¦}CT¹–òþvêóNæIüÙ‰Ï.”Œ‰‘æw~òÁ‚1ÇFD(Šb"ØìUšù]ÚÝ MšáêÇØl?ŽwÏéü=?ç3°ý/Ë_ð`íÎv¸ÓDútñÿ>^©}œ#àú¯òå&šhkSR3~$“ô/òêÍÄ0A’<ŸJ鱕‰~Y&´ë;v*ÿÿÓûùŠ»|éÿ9;ùÛäå­öµhñÉæÍq›Mòu›Ñ»u%®OT·_Œøž+ûY¬í]xÒa2QØ{ûþqì²rö‹´£ŠWàÃÕÿGù£Îgañ=ÏÍííæ¥{y¨ê7Rßj„ò\ßÞÎÅåšiX¼’;Éf$“žq)Nä¿ibÅ 0Ž8ÄäØîC`fìTšÜ³m"Ål‘eeå{ ÜŸ÷X?²=üsºì~ËhŒ“³þÇËßÞü«ÿo2vÖyi4Ò­, mþVCøô˜?Î;òžèú4÷ο 5Íã儽ËË—’Ü&×Û 02zý‡åQ1ŠÛöðÃL ž)æ¯ùÆ íC_Õµ“­‹++é½X¬a¶äëð€Õvp7 —9ÍW³ã>yd3¡#tìý‡ÿ vOfaÑÇMâOxx¥:s[{ ¹¼óRüŽ³ÒA[»Æ_ÚvР~¼³³šhýFRø×Üâk?àÍÛYÿºŽ,CÊ&Gç"GØÅÈÂä%˜ ; ƹ²´¸ùcþ÷–Ö{{Ûº¿ï5y+º$@°“hÞMš9„E{  ͆8Çh€=Ï/¨ÕåÎx²ÎS=ò&Gí%õåï—® ’PŽ²ÀâH±ŸùÊÿÍ™ô]ÓòBº1ÝëPGwç)£?ZX- =R9¸þP££g/íhp's¼½ÝÅ÷Oø {"3ä=­ž>˜@õŸñOüߦ?Ò¾çç¦qïÑîÅU!…ç•!ŒUÜÐx~Yv Ï1s.¿µ»Seérjµ±ã{Ïpä€ïgz}¢[ ‚ÜU›ûÙ{¹þž= C Ç¤‡ yõ=Oìò~:ö«Ú½_´:£›9¨¢é€ý2?Å.gÝAèz–g½tø W3žX—·h_–²Ì¨L×Û 02c_œß•÷–¾O‡P±Óf»¾¶¿!ŠÞ&’B³rFTGLÑûA€äÓ‚‘!Uæú§ü;Z:>Ø”rLCLRââ FãR‰³¶Ûüß9Aù[çùK'–.ìb"¾¥àû«! øg/‹±õy9@~ß{îÚÿø${?£±-TfGH“ýÈáûT¦ò±jivñÆê¥\ýô68½šÊ~¹îßõ<^¿þ ºm¦ÓäÉç" ?ß°"tÿ'‘Åÿ^ÅüÏiäÖÈzpF‡õòXû"%ó~zçý>ìUµR̪:±}9vµz׫Üÿ°-hÿÕÈþ¦cþ^ÒÊ$¿ÓCþ)€Éçïɧ·øÂׯûâãþ©`þZÑÿª‘ýL¿äÙûGÿ(’ÿMø§µùCËZ'˜tË oF•ot½E=K+°Œ‚D WÒª{fÇX倜 ƒÉã»GCŸ³õÓê#Ã’¤,5ubÇW¯?Hò_—õ4jäC¥ùzÊkûçèLp!r£Ý©AîpåËP3—(‹aÙú½¡©Ç¦Â.y$"=ò5ös/Åÿ5ù—Ró—™5¿5jî_P׮仜v@çà|5G°Ï0ÏžYòK$¹ÈÛ÷_döfÌÒbÒa QuÌŸ9'̤K°v*È4x(¦j|rü)죯Þs°öwGØó–ÃÝ×æ~ççø2ûFsêaٸϣN~sôƒýXïï—“Öü«¡=äÑüªFtψûÈBˆKC^²@4ÊO¬¼¹ä(R(ëè;d©¤É™Íä¨DGŒt4¥@ÅoóoU’ï¿l3ŒŸ8k¿–Ló= ïá‚›’‹/ÊÇõô_ ž'²yWòí­š3èˆí„OÏÏùɯ2®¿ù±¬Ø[J$Óü¡z%§Uõ «\‘ÿ=‡ÑžÛºU 9GÓúþ×ëïøv7òwab”…O99Oº[Cý€âùÿ4Féñz—öA_§¶o=ŸÓøšŽ3Êþ<ƒåŸð]íÉv7åâ}Z‰ÿ™Tÿ@ø½»É:o­qãZ‘Ð~U“ôò«C ¶ä§†H8ó/·<·f"†=©@2M%F(¸Xªb®Å]Š¿ÿÕûùŠ¼[þróþXþNyïÍÐJ"Ô­4çµÑ h~½xE½¹<^@ß!˜=¥©ü¾žsë[{ÎÁê}Šì_åŽØÓ鈸™\¿©T¾`WÅüçUK1vbK»–'rIîIÏ2~äv*ìU•hÖĤKMä<ÓÓðÎÿ±tþš=òÜüy}ÈŸðNíŸåÜʸaýÜÍú¾s¿}'ù{åÿ¬M )Z‘Û6áó¹¾~mê+ùù/¯ÞBÂK_TÐôÃѹ^&aþ¬*ç5µ¨ð4²®rô?²Þãþ}Œ;S·p‰ †/ÞËüϧç3æ/M¼3ϲÅÅ]Š£tÝ>}_Q°Ò­Enu+ˆí¡öiX(?Ek–bÆrL@s&œ]v·‹O“Q“hc‰‘÷D[ö7É÷úV¥é%‡³Ò-!³µQ·Á žô®zŽ,c +äü¯ÖdÖê2j2}Y$d}ò6ò/ùÌ?ÌÑ¿–ZW”,fásç[ðo‚þ£aÆWÙ¥hÇÐsEí&§ƒÆ9ÌýƒöÓêÿðìQªíLšÉNž_%Ä|¢$üÂÎú‘Ø«j¥˜(êƃéÉBrɯ›N«S 6æÉ´a#÷=E²õ$Š5-g§áÄ1B0¢)ø[´ûC'hj²êr}Y$dÎ7_O­-|³ëI1÷²àëd_yË P“Ù Ñ"úOÓcŠ5FÃ$Ö™Éj…iAŠ±KEŽpÕPkí °[¯%Á3“èƒôcIâjßÈöèkè»^$ž®ôïËo!ù·Î×h«–t»‹ØÔíÎdB ýœ…WéÊ5YÆ RÈ„[µì.ËŸjëðé#Ï,Ä}ÂýGá/ç®êêæúêæúòS5åôÒ\]ÌÝ^YX»±ù±'<¶R26y—ï,x£Š€îPûp3v*É4[rÜM7‘«ô™Üû?§ðôügœÍü9åø/vÇç;cÀ‰¸éâ#þ|½Sÿz>¨?-ôs,ÐHÍè|¢Eú/ùm£¡€ð§L˜q¤_QipâQNÙ&²ž †(ov*ìUÿÖûùŠ¿7çã¾i’ÏÈÞAò|Rq`ÖfÔow‹N‡Šì^àšç1í>jÅw›ùkîŸð ìá“]¨ÕòxÄG¾g²5ñ~Cçý2ìU°9¿Ì@ûòxáÇ!òÍ£U¨|3ÊyB2—úPOèzo—-=YâTÏQŒD@¦ÏÁÙóË4å’F̉‘÷ÈÙ}¹ùW¡«5¹)ÜvɇEäŸó™^lŽo1yWȲCË6'QÕ¾·}A#Å!@Ùçí.§‹,qá}çö}ïÒðìC‡C›_!¾ipGú˜ùüæؾ.ä¿Ì>üæ_p¢ÝAÅ[ÅÅY¯]-|Åo©?ý+U¤Š¿ïÆTý'7¾ÏéüMGå°|«þ ¯ù>Æü¼O«Q!ó#êŸûÑñ}“å5Oq4CÔ$TwÎéùL‡‚ÎJy’msÏÖ¶ !h<»¥ÛÛ"Wa%Ån$?HuÎÚ,Üzžæ€>{¿TÿÀo³†›°üjß6IKá@û¤ùó4/¬;EY';˜Çòü_vm»‰«•Ÿ—í|ÿþ  t}ž¹äáÇþ˜ïþÄ´y;Oõîbªõ#=ù¾ýü«ÐV–燇lqæ_qycNX`á¥É4•oÌÌ ò£Èºÿž¼Æäiº¿¨-£ Ks;ÛÅÊ€¼®B§a”jµ0Ób9%È~)Ûvbgí­v=«!«éÎR>Q—‚ù þs_ò+ÏB {¯0KäZn éÞaêéÌöK¤/ßmÜáší7nésleÂ|ÿ_'²í¿øvïfÜ£ˆg€ëŒñŒ Oì/¥mõ;Q¶ŠöÂò û)Ç(/-¤Y¡u=ÖD,¤|Žn#!!`Ø|ç.)â‘„âc!ÌAðwWIà~„a`ŒDzS~}ÏÃ|ü4oËÿ,~^YOÂëΚ‰½ÔãS¹±ÓhÁXx<î‡ýŽs^Òêx1Gþ#gÜ?kíßðì_Ìv†]t†Ø#ÃëäýPù¿³‰~žv*Ú©vUX€>œ³3’b™5óquúØh´ù5>œq2>è‹zO—l½IâP*€}éØñŒq€¯“ð¶·W=^yçɼ²HÈûäl¾×ü«ÐêО²ÐàH¿A¼‘¦ˆ`‹áèL8ò/gµŠ(ðÂÁŠ»v*ìUÿ×ûøzUùÿ?!º•üýùifOîaÐ/'Uÿ*[¥RiòAœ_µ÷¸ÇôOÞý3ÿœ`h5SêrD|£û_œ™Ì>èìUtd ž?~]§ŽXÈò}0K>‡>(o)c˜óOnò\î"¨î3Ô„ª…è?åMŠq·4ðɉ¾µµòæ…u ¸»Ðôû»‡QÎâ{Xdv  «2pp;Á²ÝF1à “ˆˆ ^Uç+hž”¢MM8Z@?RdN4|ƒl{KUþ«?ôÒýoÉ/Ï«ËfóíÖe 0A¡D°L°¢ 3È’WˆQôg Ûùc-G@"¾'rýSÿ.Ïˇ±ÿ3šR”³ÈÈq}ôÇŸyâ?Šæõ7b¬¯ËêÉB62µOÈl3¹ì ?‡§â<æoáÈ?*ÿÁw¶?;Û'MÇOóª šú›òæÊIe‡cÛ7Áò™>qüÛ‘ßó/΋%k¤ð ÿ,J¨?žqÚÒ½^Oë?hÀûÇìþˆ¸øÈ’~÷žf½ìŠ¦:] ÚƒÝM? ß{; 5$wÄþ‡É¿àÍŠrìHÈ £š$üD€ûM|_Iþ^Z+Ü@HFwùfOѯÊûX­Í; ˜qäúºÊ{M;Ošööæ+;+8Zk»¹ÝcŠ(£ÝØ€ª T’p’³° qã–I@"h¹$òw¿¿ç.¿ç#çO™âòï–.\~[ùRwýÛ¨Ôï(÷̦‡€¬@þÉ-Õ¨8ÚíOÍφDyyžÿÔýuÿ?aÐþ”çÔð¬£Õþ×c¿¬üèt|w×c¸Í#ê »Ê~~ó·‘.Eד¼Õ©ùr@jÉepéÿ¯ LoþÉN_ƒU—¼r1÷:žÔì-jC‡W†Gô€${¥õ~ŸÎ2~{~fù÷MÕ/|úÚ|ÚM“¥¶“¬C¶ºº¸ËÉúEPPª>#NÇ;~ÄÖê5P2Ë\#`j‰=|Ÿ—àŸìÏcö£ ˜Ë!Å8qFþϪåÐvÔ>ÞÒ|ÉÒ­$©9¼|¬‡â¿üææüÀüòó'¡7«¤ù9˺] TýP³\°ùÜ; gžvæ§ÆÕJ¹GÒ>þ×ìøv/òg`â2<ß½—ùÕÃþÀGæù{5¢;Giñó¸ J„úOLÞû?§ñ5g”üNÃô¾SÿþØüŸd 4MKQ!ó#ê—ÛÂ>/mò]‡«qGR3¹~X/Ð/ʽ!UmÏ qæûoË$0F)ØdšK9ŽEo…Š§ª¾8«bAŠ¯U¼UÿÐûøzUù?ÿ?#Ðf—ågšU ·{}KIš@6­ÂiܧÈç!íF3xçï¥ú3þúØøzÍ7[„þÄþ±ù‹œ›ô ±Wb—¡ù7ÍÖºDñ&¦®!B8ÜƼ¨?Ê^¿HΧ³{xc€Çšöå!¿Ïõ¾ í¯ü rj³ÏWÙ†72L±Hðú3 rÜïÂk~G£î¿ËÎÏË=6(^ÿÎ66A.³ U…=¸W7±í!âµò|ßð9ö†áüœÏ»„˜/hÕ?ç3ÿ$<»dâ×Y¾óEâ¯îí4«9b?âÛEúrœÞÐi1¤d|‡ë§gÙÿð"öƒU!âbŽ÷ÎCýÌx‹ãÌÿùÍ;yÃ×±òf‘oä}2J¨½fš‹/üdeGþÅ ÿ+4:¿hódÛàüÏê}cÙÿø önˆ‰ë¦uÃôcùÅ/‰ÉñÍÝÝÕýÕÅõõÌ·—·r4×Ws1y$‘ÍYš¤’{œçå#"I6Kì0cÁŽ8ñÄF€Cä[W"—eEêÄôå˜q³ÉÃí t4:lšŒŸN8™óEý¯Jòõ©4J€g§cÆ1ÄDr¾OÂúÝ^M^yçÈny$d}ò6_iþWhœŒ§†ZÈÿóšºæÿœ-åB‹¨M¥nH hîáG¨ù7%ùŒóÎÚÆa«Ÿ™¿˜~Çÿ–¶:¯gt¤L¾#î£ñxÆjÞíتø¤xdIc4t5S–áÍ,3¢ÓìÜ¥¦ž›Q,yúGqpz´ù'ó+HÑdˆê¶×p§'DŠ~Š‚3®Áí&"?y–ãõ¿ççà37A¢ž¯(„yu=ÃñÉ潫öŸOìþŠZœ»Èíuœúpç#ÐyÓî?"yš&ÓOÒtÕú½…‚,Vð¯`7$ø’w'¹ÏFÊ8`!@?vž¿?hêrjuâÉÙ? y@t¥¥üÊÿù'Ì~l¸“þ8zt×0)?jp¼`Aþ´Œ£#ªÔ eÿûz}­½ÙínÐÁ£ùY€|£ÎGá/Çk‹‰îî..î¥3]]ÊóÜÌz¼’1wcó$œòòI6y—îÜxãŽ"€î`¥“±TD2ÛšÇÇsSQ\ØhûK.Ž·ï#í'±=ŸíHdÕñ“DDeÂ76v®g½•i~{×´vW³6Õ^ž¤\¿Žf¢Wô~O4à;Ø=ÙÓþÇ«hßó”?šzU°“H)ORÄ7Oöcú"ÕGäÄÿÀo°L¿éÿc9·ÿœäü÷¶P±\è•Óÿ™˜ÿ¢=_ô~LäÌû?Ý—ý?ìEùÏÏáÿ>^ÿ¸Xÿª¸Ñ¯ú?%ÿ“1ìÿv_ôÿ±õüâÏüä?æ·æ֩櫯<\écËš ´0Û-•·y/®ù¶É1"Ÿ´<3yØ¡¨ÖJG%pǸu/–Á?ØþÈöwiü\¤“Å. !ÝCœˆùÜvzüS€×:Ç©”Û],€k…ŠaËá®*ÿÿÑûøzUó/üåGå\ß›Ÿ”ºÞ§D$ó”é¬y`W–¡«'§­LòFŸcîõi_RÔ hKMEŒõcUÏBìM?ƒ¥|½GãËì~=ÿ‚‡l)öîj7 ?ºùŸWÎfO²|£ç¼hÿyZÓ¾mß:!ô¶zÓÆ„šÔak,Þ§ÒÂÅÿÒûùŠ¥wñs¶Þ˜«ócþrgþqbÇΚ÷|”Ðè¾m¹&MZÆJ­ž¢àxHþêSMØ 7í üYÎö¯aI91m>½ÒýEöO`৓±¡¸šq´HúñyJÑç›lüÄó'“üÑå¹,¼É¡Ýé3FJó™+PÒ©*Õcœv£I—¬‘#îùò~‘ìh;?µ '¤Í ƒ¸P÷ÄÔ‡Ä1ªƒÓ1ÝÍ7ŠŠµŠim¦_Ý‘èZÈÀþÛ+÷µ33gê3ý>þCæ^kµ}°ìŽÌó˜?„9¥–Keå2h×Ó×þ)‡ø±þ7Ú_fúæ—À~·É»wþ cxvnóò~ˆ÷Òø3 - "ˆ­-„(z•Ÿ™;œé4ú\ZqXâã½ñnØíýwkäñ5™eôéõb=1øs¢ù.{™˜‰©³!Ó’úcÈž@txI„õ²@5JOµ<•å¡kUJPÙ&’^™ªèVzŽ•y¦ßÚE{a}ÛÞÙÌ¡ã–)«£©Ø‚  DHE‚Ëiáɘäc(AÁˆóÇÏùĽÉÚî¯ùw šÿ•åf‘tNU¾²Ô¢†?¿AØŽ›zçÚ>ÏäÆL°z£ÝÔ~¿½úwØßø/i5˜ãƒµØmÇþN~gù’ï¿OqŸ]ZÜÙNö׶ÒÙÜÆi%¼èѺŸu`ÎvQ05!GÍö\ñê 'ŠBq<ŒHù…‹k±V±M+Eó·byOù"¿Ž]‡O“1¨DËÜohö¾³¡ÇªÍ CúDæ~‘YyvG!ïŠÿ¾Sv?6è>Œèt~ÎÊ^¬æ‡pçñ/ŽûKÿ\8ÅÙpã—ú¤ÅDyÆåþwò,âÃGw úq/DQV0à ð>Ñí-Ohg–}NC“$¹“÷à:°zß•¼“5ı“;ŽÙh¾R}wä/ ôI‡}»d€i”ŸŸßó’h‹ÌŸ›~c†Öa&›å†] O¡ªÿ¡ÔNÃç3>yçmj|mT«”}#áÏí·ìoøö)ìÎÁÂ$*yo,¿Ïú~PxUGˆÍSèêVQŠÑuF+EÕ­Tb´]QŠÑDZÀnn`€oê¸åßðÌ&Ÿ,qŽ§û~ÇOíjDz»?>®_äàHó—(Œˆ¤|µ{rÒC’h¨£°žš‡'ᬓ”äg#r$’|Ï7Ú_–K<† ÔôɇO¸<«b¯†I ½Ÿ¹ÂÅÿÓûùŠ¨ÊœÅX>½¤­ÔN Ö£ _/yïÈI}èöâTjòF©¯±Û"EŠ-ØòKŠ$‚:ÍñÏšÿ%ô––G²±'tˆ'üF™…“³´Óú±ÇäôúOl»kJ+¯(×'ýÕ¼‚ÿò’Ò'<4þ#Àþ¹Aìm!ÿ&>ßÖí£ÿŸh@ÿ—ÄGõ$ÇòÖ(ÎÖ ·ˆ'õä£Ù:AþL4eÿ‚oäu™>¸# ò#ÄG§h¨Gu@ecÓbÇôÄp‹WÛšífÙóä˜î”äGÊé;·òMÛ‘XÉú2çYa•éß—w•¬$ýiOQп+¤bœ ?v4ÄÉîž[ü°Xý2`ð톘=÷˾IŠØF}*R²Md½LÒÒÝ¥0°%8–Ü¥;b‡˜y§@[¸ä+Pp3ñÿæåž©êýoM†ó¯Z%’Ÿ.@Ó*ɆLïçè»GQ£—Ÿ$ñŸèÈÇî!òw˜?%ô¸äţũû¯ê9ƒ>ÉÒKž0õZø öþQÖd#̉}à¼öçò®Þ&~òÝœ‰0M¶ZƒN0F?RäN8÷“duy¿Ÿ/ôÇõ¾8óW‘ÌÓIÆÍIèŠ?†=ÃäÜ5™¿Ÿ/ôÇõ¼ÊoË™Yú0ÿ<8÷“/Îfþ|¿ÓÖ£ÿ*Þ_ùfÿ…Ó=ÃäŸÎfþ|¾gõ¶?.%ÿ–aÿ‡áòGç3>_éëoþUÌßòÌ?à1ðãÜ>KùÜßÏ—úcúÝÿ*æoùgð8øqî ùÜßÏ—Ìþµh.¦ ·¡ÂÓøa e©É1R‘#Ì—¤ù_È$Ñ ê;d© ÉöWåï•šØBLtéÛ$d_Vh–žŒ()J “QeTø)ŠÿÔûùŠ»BOpE:â¬;TÐc¹Vª\ yf±ä(n D£d$ómCò¾'b~®>ìˉIùR„ÿ¼ÃîÁIâZŸ•(ûÍøa¥âN-?+bVÜ}ØÒ8™–ùk q>€F4Ž&¦ùxþè£ g–>^†´@)Š-’Ád‘€Ó Œ.(\TŠ¥—vk*EkŠ^¬yb ÕŒû`H/(Ö?.aœ¹_lÌI€Þ~VÆI¥¸û±¦\I9ü©Jÿ¼ß† O.ßòª0¶ÃîÃHâeúwåŒHTý\mí#‰èúO‘`ƒî@§¶bdô;@†´Œ bÆÙD6« ab¡ymͦ)yž»åÅ»ä8V¾Øò½Còê9‰€}°S.$”þWÄM~®>ìi‡býC~ÓÚ‰òæœ{?áý1[pòÞœ;?áý1[T]Ázü?¦+h”Ò­SìƒøLVÑ+i t¡XF£ ÅWôÅ]Š»h€zâª/oõªô»Y>Ð?‡ôÅm Þ_°n¡·ùLSjá½;Áÿá¦+k—˺zôøLVÑ £YÇöC~Ó´ZY@ůLU~*µ‘[®*…{dûUÅPçH´n þÓÚßÐÖ~ øLVÝúËù[ðþ˜­»ô5—ò·áý1[wèk/åoÃúb¶ïÐÖ_Ê߇ôÅm¿ÐÖÊ߇ôÅmzév«ÐÃúb‹E%´IökŠ«€LU¼UÿÖûùŠ»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±WÿÙgcl/gcl2.jpg000066400000000000000000000131511242227143400131560ustar00rootroot00000000000000ÿØÿàJFIFÿÛC    $.' ",#(7),01444'9=82<.342ÿÛC  2!!22222222222222222222222222222222222222222222222222ÿÀ|,"ÿÄ ÿĵ}!1AQa"q2‘¡#B±ÁRÑð$3br‚ %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyzƒ„…†‡ˆ‰Š’“”•–—˜™š¢£¤¥¦§¨©ª²³´µ¶·¸¹ºÂÃÄÅÆÇÈÉÊÒÓÔÕÖ×ØÙÚáâãäåæçèéêñòóôõö÷øùúÿÄ ÿĵw!1AQaq"2B‘¡±Á #3RðbrÑ $4á%ñ&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz‚ƒ„…†‡ˆ‰Š’“”•–—˜™š¢£¤¥¦§¨©ª²³´µ¶·¸¹ºÂÃÄÅÆÇÈÉÊÒÓÔÕÖ×ØÙÚâãäåæçèéêòóôõö÷øùúÿÚ ?÷ú(¢€ (¢€ (¬]sÄúO‡¡ßrB2§Í#ýõ½ÊŸzÿ‚}>%´àà׆h?5]6DŽþF½µèwÿ¬Qêƽ[OÖ­ï­¢¸‚PñH»•‡zë¥Z56< vY_ÿyª{5±¾ -SŠà?z´­šÔóÇQE! ž”´f¸ŸüIÑôvx- ¿º^ Äß"Ÿvþƒ5çZ¯Ä_jd„ºqà¶OýõÖ¹êbiÃMÏ_ ’bñ+šÜ«»ÿ-Ïvšx ]ÒÊ‘¯«°õªx‹EˆâMZÉO¡ƾpžâ{§/q4“1êdrÄþuès¼ké؇ ÆÞýO¹Á>Oè²6ÔÕ¬˜ú ×üjôWpλ¡–9Õ0ý+æJ’ æµ=¼ÒBã£FÅHü¨X×Õ|/{•>õÿúxJ=iÁÁ¯о#jš|‹¢ÆöÛ¡fÿX£Ø÷ükÔì5«{ëxî-åY"eXw®ºU£Qh|þ;-¯‚—ïf¶7Á¥ª‘\ïVU³ZžxêL×ñSZ“OÐmì­åhç»—$£`„^OO}µä?ÚWÿóýuÿ›ük–®)S—-w‘OEVçåOÈúl·µ&úù—ûJÿþ®¿ïó>ÍFâxàŽö輌|ÝIÇ­gõÕü§cá‰%wU}ßðO¥÷ŠPÙ®vÂé-là¶W,"PrN2kV ýë¹.Õž…ú)ŠÙ§Ð ¢Š(¢Š(¢ŠóOˆÞ6k ú&™..bæd<Æðƒê{úTT¨©Ç™X<%L]UJŸü2îIã?ˆé¦´šnŠÉ-Øùd¸ûËô­ú òK‹‰îîâæWši^I%¹¨©kÈ«VUÙú/£ƒ‡-5¯WÕÿ]‚Š$€MZŽÈ‘™o°ëJå7h£\N2Ž<Õ¥oÏî*ÑZ+eà)?SJúYeÌyÐ÷­ž¢W<Øgø9K•Ýyµ¡›EbÁQ\Ǵº¿ëZ´¶lçË?¼@OCÐÿJäêæ™!ŽùXƵ¡&ª+~mJ50Uº+ýÚžÙ§jBLs]¼ÛÔטè×m•æ»»•H ’8TUÜÌÇÜ×°~pÑ«y}m§ÙËww2ÃK¹ÝW‹x»â î¼òZX³Úé¹ÆÃÊ=XößVñ·Œ%ñ-ù†dÓ!oÝ'O0ÿ}¿ í\­y¸ŒK“åŽÇÚå,hEV®¯>‹·üÈJZ)UYÛ 2}«‘+ŸE)(«· ”U•³?Æüú “ì¾ë6}ëu†ªÕìyRÎð1—/?àÊTT“@ð>×zZŽ±i§fztêF¤Tàî˜WOàífK+§³g>TŸ2‚z0ëùŠæ*[I Wq8<‡t¤ã4Î\„ká§Ûñ[ã§jañÍtvóïQÍyn|I^k²:²éúEÍóž ˆ¾róÅ{7²»?5Pr’Œwg™üGÕ´ü_èRÅÏ©}ÏüŽ6ûÁRKy4ÿhØŽÙ©Èük:o ¤äsîq]ôÞ.ðÂ¥ýðßáY7:ÿ‡¥'múø…cÉB÷Óï=¬fܪ I%¦‘kô8Ã¥<%Z·Ó˜0ÂÖÉÕt"Ùûrß-þ·§ÙÛÝÛÇqŒ«c¬6Ž BÅ%Í]KçÔ§¤Ú2°âªøë^kk4Ñmß*‡¸#²ö_Ç©ü=k­ò Ó¬¦»Ÿˆ Bì}€¯¾¼—Q¾žòs™&rçÛÐ~Ž.§,yWSÔÈ0J½wZkHþð?È‚Š(¯0ûUK0QÔÕè£6¯^çÖ«Û¯»ž•¯cjdaÅz8ZJ1ç{³âóÜÂUj¼<»üßüÖ¶M!V完X–µ4­/v2µÖYéj|µÙcç<×ÄZ#¦˜%Ž&i@UÉçŠçDÔ˜dÚHƒÕþ_ç^ôÚjíàV=þ”–¹êa£9s6{<궇±„S×vxãiS§ß niÑiÿ8''»Û­–?-C†w}ÚqÃSB+g8ʪÎv^ZÁ(é18eâ¬ø×P6ú6 ~k—ËöWŸçŠÞ±Ò òןxÎóí^#š49ŽØW£ï~¤ÒÅO–Ÿ©yÛc{G_òüL (¢¼£ïÀ +JÒ<°B%Ëý+oM‡sŽ+ÐÁÂÑrî|wâ9ªÆŠû*ïÕÿÀüΧC¶ÉSŠô-2¨8®[C¶À^+¶³j íGÌ2ê } éKL¢Š(¬Oj¿Ø¾¿½S‰V2±ÿ¾ÜÔÖÝy·Åëã‘abú錌=”‹~••irÁ³·. «â¡MìÞ¾‹Vy=Î}ÏzZ(¯ý4*Õºp­UëÅiÙǹÅv`ãvä|×Wq¥ K«¿Ýÿni6›Øq[úôÃJð­Ã©Ä³bÿuý3QèvÀ•â²>!߆¾µÓPü¶éæ8ÿiº~ƒõ®ºóä¦ÙóùVëÈG¢Õü¿«]-&G­ä¢‹EPቮ'ŽûÒ0Qø×±éòÃoo ¼xÙ_ ¯&ÒˆKå”ÿË1‘õ®ÊÂù‡5èàáh¹w>3‰1õ£E}•›ÿùšuo'@ŠÊ6Ã]Éócû‹Éýq^a]ŒoçYXÉù`‰TsÉþb¹úåÄËš£=ì–‚£‚‡w¯ßÿÁ@8¢Ì‚²„y¤‘߈«ìiJ§dÙzÚ<°ºÝËs/Ïiñnq]þ‡j>^+ÚJÇæ3“m·»:.È*Ž+¡Šª8ªÖP…AÅÆ­m¡i…ÑýÜ+£«€ri¶’»"1”ä£vËÅ*¬ÖÁ³ÅsºWÄjaUîZÎSü#hϳtýk¦Kˆ¥ŒIŠèz2œƒøÒŒã/…šVÃV íV-z™¯§+»BiŠ?†µ)§ŒUÜÄÔä‹GÑîïÜ [ÄÎ=Î8ž+ç§w–F‘Î]سÜžMzÿÅWìú5®™a®¤Þàqúä~Uãõæc'yòö>߆ðܘwUï'ø/ø7 (  +úÒWe‹dÎ=ë¨Ñí÷2ñX6‘åÀ®ÛC¶åx¯jœyb¢~g‹®ëÖ•WÕÿÃvoµWŠê`\(¬6¨8­¤¡ÆÇÑE(¢Š+Çþ09:ΘŸÂ-Ù¿6ÿëW°W“üaµo?J¼å+$DûðGõ®|RýÓ=Œ…¥…üÿ&yQ^Iú¼+sN\¸¬:ÐÓ¯ÒÝÀ”£ø€®¼-XÁµ.§ÏgØ ¸ˆÆ¥%wèzn…Â×\–vÞ&cÔ²Oé^£ø“I…A’ú$Ç]Ù­©þ"ø~Ò#²yn_²Ãçñ8ÜêÓKV“ŽåhÓ•ý¡©ØÛí;m¡HÇøW’x¦D:ÃAª¬#iÚ1ÉäÿJÙÖ¾#_꣰,¢?ÄNùãÐ~UÆÉ#Ë#I#³»³1É'Þ¸±ã5Ëê2lª¾§¶¯ÛEé E’®=ϤmE]–­‰®«HŒ³ ç­"Ë]¦‰m’¼WµN<‘Q?2Å×uëJ«êÿáŽ#^$ë× ö¯åÅgÖÏ‹-¯‰¯Œoa ÷ ÿƯ"§ÆýOÑpM<56¿•~ARAþ²£¡IVuS—,”ƒAס:KvŽ§IŒZôm kÊ´Ýf fr8Çu®²Ûâ›cÉÄÎ:ÌŸé^¢ÄSµî|²œj—/³§ß±ê‘ºCI#ª"Œ³1Àu5â¾>ñü$z€µ´sý›lÇgý5oïý=?úõSÄ~7ÔüCÙØ‹k/ùáûßïÿʹªãÄby×,v>'É^^Ú¿ÅÑvÿ‚%\°Õu .Mö7“[ŸHÜ€~£¡ª•-¼â`€àz åŠmÚ;žõiS7*¶å[Üõ_øŸVÕ –MHÄaB9v³·~:WqàqÖ¼«K½X#Ž†ØÐ`]3k?`ÒnoXÿ©Œ°÷=‡çŠöaxCÞgæ؇F!º1²oD¿„øƒ«jøºçkf+P-Óþ÷¿ñâk—¥wiÎY‰f>¤óI^<äå'&~‘‡¢¨R(ì•‚ŸËçÒ™J®S¦)ÒqŒÓ–ÆXêujáåN—Äôÿ?ÀÝÓ¢Üâ½C·/åj—6äÙø­jÛøÛXµÀŒÛñëz[¦|‹áìg—ßÿ÷[5 ‚¯1^ŸÍ €¾\{Ir}sèç]ÌwAZÞS2<œVxj®”íuØ¿EDŽ J*Îp®cÇkþžÚ%ÍÌdM»߈Ȯž¢•r¦¦QRM3Z5eF¤jCtî|¼ÊUŠ°*Àà‚9Šõø=Fy/ì ÃvÜȇîJ}}y…æŸwa!ŽêÞHˆîÃô=+È«FTÞ»¢às*ȧiu]à•è¤¥¬@(¢’€ŠzC$ŸuãVc°ï#~ ZBŒç²8qŽ¿y5~ËVS±ÀŸj±»ºúV„vØDÀ«öÚs;+¶–EÞZ³æ1ùõJñtè®X½<ÿàéÖ¥œq]þ‹i€¼VN—¥Wå®ÛM³Ø£Šì>u³ˆø“¡<–vú¼)“ò§Ç÷Iá¿Çã^i_JOj“[¼R"¼n¥YXdzƒ^=âoÜé÷>˜¦{SÏ•Ÿ=¿Ú­pb¨6ùâ}fEšÓ5†¬ímŸOCŒ¢•Ñãr’##¡†¤®꓾¨(¢’‹E*«1‚~•b;Bysø ¸RœþrbqØ|2½Y[˯ÜAM+aGÏ¥iAÀÔúÓâ·' «è+^ÇMgaÅzTh*zõ>/2ͪc*Ò §ù’i–î̼T¾1¹6ÚEµ?4ｇû+ÿ×#ò®›KÒ±–¼ûÆ¢óÄ—*˜íÿpŸð¿®ib§ËNÝÊÈ°þÛ¤öŽ¿åþ#ŠJ?òϽŠJ(h¤¢€’Šr.ù}M ]Ù9(EÊ[#½ðµÊéÚLqƒ‡™ñéúb»+ @ÈG5æ–r9e§jítPÇm{p,TQù†&«­VUe»w;ËY («Ã¥fØ©Ú+MGg0´Œ3KEPº€:ž+–Õ4±*°+‘èkµeÍSžÔ8Z«ÜãmtBq•­Û= |µÒæ*㊿¢¯j,+™všhLq[Àt©V0;T€b™#8¬»ëQ"ž+c‘†皶Š“ç|Jÿï.k’»ðä!Ž Qô¯`¸²WÏ“q¤+gå©p‹ÝÓÄU§ðI¯GcÉ_CUÏ¡©h ¾Ï¡£ìéRÑ@ˆS‚ÒEQEÿÙgcl/gmp.patch000066400000000000000000000012451242227143400134320ustar00rootroot00000000000000diff -ruN ../libgmp3-4.0.1/mpn/generic/mul_n.c gmp/mpn/generic/mul_n.c --- ../libgmp3-4.0.1/mpn/generic/mul_n.c Thu Jun 28 19:04:08 2001 +++ gmp/mpn/generic/mul_n.c Sun Jul 28 14:01:36 2002 @@ -1144,9 +1144,15 @@ * multiplication will take much longer than malloc()/free(). */ mp_limb_t wsLen, *ws; wsLen = MPN_TOOM3_MUL_N_TSIZE (n); +#ifdef BAD_ALLOCA ws = __GMP_ALLOCATE_FUNC_LIMBS ((size_t) wsLen); +#else + ws = TMP_ALLOC ((size_t) wsLen * sizeof(mp_limb_t)); +#endif mpn_toom3_mul_n (p, a, b, n, ws); +#ifdef BAD_ALLOCA __GMP_FREE_FUNC_LIMBS (ws, (size_t) wsLen); +#endif } #if WANT_FFT || TUNE_PROGRAM_BUILD else gcl/gmp4/000077500000000000000000000000001242227143400124735ustar00rootroot00000000000000gcl/gmp4/.gdbinit000066400000000000000000000022611242227143400141150ustar00rootroot00000000000000# Copyright 1999 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library 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 copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. define pz set __gmpz_dump ($) end define pq set __gmpz_dump ($->_mp_num) echo / set __gmpz_dump ($->_mp_den) end define pf set __gmpf_dump ($) end gcl/gmp4/.pc/000077500000000000000000000000001242227143400131535ustar00rootroot00000000000000gcl/gmp4/.pc/.quilt_patches000066400000000000000000000000171242227143400160170ustar00rootroot00000000000000debian/patches gcl/gmp4/.pc/.quilt_series000066400000000000000000000000071242227143400156610ustar00rootroot00000000000000series gcl/gmp4/.pc/.version000066400000000000000000000000021242227143400146310ustar00rootroot000000000000002 gcl/gmp4/.pc/4a6d258b467f.patch/000077500000000000000000000000001242227143400160175ustar00rootroot00000000000000gcl/gmp4/.pc/4a6d258b467f.patch/mpn/000077500000000000000000000000001242227143400166115ustar00rootroot00000000000000gcl/gmp4/.pc/4a6d258b467f.patch/mpn/powerpc64/000077500000000000000000000000001242227143400204425ustar00rootroot00000000000000gcl/gmp4/.pc/4a6d258b467f.patch/mpn/powerpc64/mode64/000077500000000000000000000000001242227143400215405ustar00rootroot00000000000000gcl/gmp4/.pc/4a6d258b467f.patch/mpn/powerpc64/mode64/gcd_1.asm000066400000000000000000000052461242227143400232260ustar00rootroot00000000000000dnl PowerPC-64 mpn_gcd_1. dnl Copyright 2000-2002, 2005, 2009, 2011-2013 Free Software Foundation, Inc. dnl This file is part of the GNU MP Library. dnl dnl The GNU MP Library is free software; you can redistribute it and/or modify dnl it under the terms of either: dnl dnl * the GNU Lesser General Public License as published by the Free dnl Software Foundation; either version 3 of the License, or (at your dnl option) any later version. dnl dnl or dnl dnl * the GNU General Public License as published by the Free Software dnl Foundation; either version 2 of the License, or (at your option) any dnl later version. dnl dnl or both in parallel, as here. dnl dnl The GNU MP Library is distributed in the hope that it will be useful, but dnl WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY dnl or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License dnl for more details. dnl dnl You should have received copies of the GNU General Public License and the dnl GNU Lesser General Public License along with the GNU MP Library. If not, dnl see https://www.gnu.org/licenses/. include(`../config.m4') C cycles/bit (approx) C POWER3/PPC630 ? C POWER4/PPC970 8.5 C POWER5 ? C POWER6 10.1 C POWER7 9.4 C Numbers measured with: speed -CD -s16-64 -t48 mpn_gcd_1 C INPUT PARAMETERS define(`up', `r3') define(`n', `r4') define(`v0', `r5') EXTERN_FUNC(mpn_mod_1) EXTERN_FUNC(mpn_modexact_1c_odd) ASM_START() PROLOGUE(mpn_gcd_1,toc) mflr r0 std r30, -16(r1) std r31, -8(r1) std r0, 16(r1) stdu r1, -128(r1) ld r7, 0(up) C U low limb or r0, r5, r7 C x | y neg r6, r0 and r6, r6, r0 cntlzd r31, r6 C common twos subfic r31, r31, 63 neg r6, r5 and r6, r6, r5 cntlzd r8, r6 subfic r8, r8, 63 srd r5, r5, r8 mr r30, r5 C v0 saved cmpdi r4, BMOD_1_TO_MOD_1_THRESHOLD blt L(bmod) CALL( mpn_mod_1) b L(reduced) L(bmod): li r6, 0 CALL( mpn_modexact_1c_odd) L(reduced): define(`mask', `r0')dnl define(`a1', `r4')dnl define(`a2', `r5')dnl define(`d1', `r6')dnl define(`d2', `r7')dnl define(`cnt', `r9')dnl neg. r6, r3 and r6, r6, r3 cntlzd cnt, r6 subfic cnt, cnt, 63 li r12, 63 bne L(mid) b L(end) ALIGN(16) L(top): and a1, r10, mask C d - a andc a2, r11, mask C a - d and d1, r3, mask C a andc d2, r30, mask C d or r3, a1, a2 C new a subf cnt, cnt, r12 or r30, d1, d2 C new d L(mid): srd r3, r3, cnt sub. r10, r30, r3 C r10 = d - a subc r11, r3, r30 C r11 = a - d neg r8, r10 and r8, r8, r10 subfe mask, mask, mask cntlzd cnt, r8 bne L(top) L(end): sld r3, r30, r31 addi r1, r1, 128 ld r0, 16(r1) ld r30, -16(r1) ld r31, -8(r1) mtlr r0 blr EPILOGUE() gcl/gmp4/.pc/applied-patches000066400000000000000000000000511242227143400161350ustar00rootroot00000000000000arm-asm-nothumb.patch 4a6d258b467f.patch gcl/gmp4/.pc/arm-asm-nothumb.patch/000077500000000000000000000000001242227143400172605ustar00rootroot00000000000000gcl/gmp4/.pc/arm-asm-nothumb.patch/mpn/000077500000000000000000000000001242227143400200525ustar00rootroot00000000000000gcl/gmp4/.pc/arm-asm-nothumb.patch/mpn/generic/000077500000000000000000000000001242227143400214665ustar00rootroot00000000000000gcl/gmp4/.pc/arm-asm-nothumb.patch/mpn/generic/div_qr_1n_pi1.c000066400000000000000000000170011242227143400242640ustar00rootroot00000000000000/* mpn_div_qr_1n_pi1 Contributed to the GNU project by Niels Möller THIS FILE CONTAINS INTERNAL FUNCTIONS WITH MUTABLE INTERFACES. IT IS ONLY SAFE TO REACH THEM THROUGH DOCUMENTED INTERFACES. IN FACT, IT IS ALMOST GUARANTEED THAT THEY'LL CHANGE OR DISAPPEAR IN A FUTURE GNU MP RELEASE. Copyright 2013 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library 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 copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" #include "longlong.h" #if GMP_NAIL_BITS > 0 #error Nail bits not supported #endif #ifndef DIV_QR_1N_METHOD #define DIV_QR_1N_METHOD 2 #endif /* FIXME: Duplicated in mod_1_1.c. Move to gmp-impl.h */ #if defined (__GNUC__) #if HAVE_HOST_CPU_FAMILY_x86 && W_TYPE_SIZE == 32 #define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ __asm__ ( "add %6, %k2\n\t" \ "adc %4, %k1\n\t" \ "sbb %k0, %k0" \ : "=r" (m), "=r" (s1), "=&r" (s0) \ : "1" ((USItype)(a1)), "g" ((USItype)(b1)), \ "%2" ((USItype)(a0)), "g" ((USItype)(b0))) #endif #if HAVE_HOST_CPU_FAMILY_x86_64 && W_TYPE_SIZE == 64 #define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ __asm__ ( "add %6, %q2\n\t" \ "adc %4, %q1\n\t" \ "sbb %q0, %q0" \ : "=r" (m), "=r" (s1), "=&r" (s0) \ : "1" ((UDItype)(a1)), "rme" ((UDItype)(b1)), \ "%2" ((UDItype)(a0)), "rme" ((UDItype)(b0))) #endif #if defined (__sparc__) && W_TYPE_SIZE == 32 #define add_mssaaaa(m, sh, sl, ah, al, bh, bl) \ __asm__ ( "addcc %r5, %6, %2\n\t" \ "addxcc %r3, %4, %1\n\t" \ "subx %%g0, %%g0, %0" \ : "=r" (m), "=r" (sh), "=&r" (sl) \ : "rJ" (ah), "rI" (bh), "%rJ" (al), "rI" (bl) \ __CLOBBER_CC) #endif #if defined (__sparc__) && W_TYPE_SIZE == 64 #define add_mssaaaa(m, sh, sl, ah, al, bh, bl) \ __asm__ ( "addcc %r5, %6, %2\n\t" \ "addccc %r7, %8, %%g0\n\t" \ "addccc %r3, %4, %1\n\t" \ "clr %0\n\t" \ "movcs %%xcc, -1, %0" \ : "=r" (m), "=r" (sh), "=&r" (sl) \ : "rJ" (ah), "rI" (bh), "%rJ" (al), "rI" (bl), \ "rJ" ((al) >> 32), "rI" ((bl) >> 32) \ __CLOBBER_CC) #if __VIS__ >= 0x300 #undef add_mssaaaa #define add_mssaaaa(m, sh, sl, ah, al, bh, bl) \ __asm__ ( "addcc %r5, %6, %2\n\t" \ "addxccc %r3, %4, %1\n\t" \ "clr %0\n\t" \ "movcs %%xcc, -1, %0" \ : "=r" (m), "=r" (sh), "=&r" (sl) \ : "rJ" (ah), "rI" (bh), "%rJ" (al), "rI" (bl) \ __CLOBBER_CC) #endif #endif #if HAVE_HOST_CPU_FAMILY_powerpc && !defined (_LONG_LONG_LIMB) /* This works fine for 32-bit and 64-bit limbs, except for 64-bit limbs with a processor running in 32-bit mode, since the carry flag then gets the 32-bit carry. */ #define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ __asm__ ( "add%I6c %2, %5, %6\n\t" \ "adde %1, %3, %4\n\t" \ "subfe %0, %0, %0\n\t" \ "nor %0, %0, %0" \ : "=r" (m), "=r" (s1), "=&r" (s0) \ : "r" (a1), "r" (b1), "%r" (a0), "rI" (b0)) #endif #if defined (__s390x__) && W_TYPE_SIZE == 64 #define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ __asm__ ( "algr %2, %6\n\t" \ "alcgr %1, %4\n\t" \ "lghi %0, 0\n\t" \ "alcgr %0, %0\n\t" \ "lcgr %0, %0" \ : "=r" (m), "=r" (s1), "=&r" (s0) \ : "1" ((UDItype)(a1)), "r" ((UDItype)(b1)), \ "%2" ((UDItype)(a0)), "r" ((UDItype)(b0)) __CLOBBER_CC) #endif #if defined (__arm__) && W_TYPE_SIZE == 32 #define add_mssaaaa(m, sh, sl, ah, al, bh, bl) \ __asm__ ( "adds %2, %5, %6\n\t" \ "adcs %1, %3, %4\n\t" \ "movcc %0, #0\n\t" \ "movcs %0, #-1" \ : "=r" (m), "=r" (sh), "=&r" (sl) \ : "r" (ah), "rI" (bh), "%r" (al), "rI" (bl) __CLOBBER_CC) #endif #endif /* defined (__GNUC__) */ #ifndef add_mssaaaa #define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ do { \ UWtype __s0, __s1, __c0, __c1; \ __s0 = (a0) + (b0); \ __s1 = (a1) + (b1); \ __c0 = __s0 < (a0); \ __c1 = __s1 < (a1); \ (s0) = __s0; \ __s1 = __s1 + __c0; \ (s1) = __s1; \ (m) = - (__c1 + (__s1 < __c0)); \ } while (0) #endif #if DIV_QR_1N_METHOD == 1 /* Divides (uh B^n + {up, n}) by d, storing the quotient at {qp, n}. Requires that uh < d. */ mp_limb_t mpn_div_qr_1n_pi1 (mp_ptr qp, mp_srcptr up, mp_size_t n, mp_limb_t uh, mp_limb_t d, mp_limb_t dinv) { ASSERT (n > 0); ASSERT (uh < d); ASSERT (d & GMP_NUMB_HIGHBIT); ASSERT (MPN_SAME_OR_SEPARATE_P (qp, up, n)); do { mp_limb_t q, ul; ul = up[--n]; udiv_qrnnd_preinv (q, uh, uh, ul, d, dinv); qp[n] = q; } while (n > 0); return uh; } #elif DIV_QR_1N_METHOD == 2 mp_limb_t mpn_div_qr_1n_pi1 (mp_ptr qp, mp_srcptr up, mp_size_t n, mp_limb_t u1, mp_limb_t d, mp_limb_t dinv) { mp_limb_t B2; mp_limb_t u0, u2; mp_limb_t q0, q1; mp_limb_t p0, p1; mp_limb_t t; mp_size_t j; ASSERT (d & GMP_LIMB_HIGHBIT); ASSERT (n > 0); ASSERT (u1 < d); if (n == 1) { udiv_qrnnd_preinv (qp[0], u1, u1, up[0], d, dinv); return u1; } /* FIXME: Could be precomputed */ B2 = -d*dinv; umul_ppmm (q1, q0, dinv, u1); umul_ppmm (p1, p0, B2, u1); q1 += u1; ASSERT (q1 >= u1); u0 = up[n-1]; /* Early read, to allow qp == up. */ qp[n-1] = q1; add_mssaaaa (u2, u1, u0, u0, up[n-2], p1, p0); /* FIXME: Keep q1 in a variable between iterations, to reduce number of memory accesses. */ for (j = n-2; j-- > 0; ) { mp_limb_t q2, cy; /* Additions for the q update: * +-------+ * |u1 * v | * +---+---+ * | u1| * +---+---+ * | 1 | v | (conditional on u2) * +---+---+ * | 1 | (conditional on u0 + u2 B2 carry) * +---+ * + | q0| * -+---+---+---+ * | q2| q1| q0| * +---+---+---+ */ umul_ppmm (p1, t, u1, dinv); add_ssaaaa (q2, q1, -u2, u2 & dinv, CNST_LIMB(0), u1); add_ssaaaa (q2, q1, q2, q1, CNST_LIMB(0), p1); add_ssaaaa (q2, q1, q2, q1, CNST_LIMB(0), q0); q0 = t; umul_ppmm (p1, p0, u1, B2); ADDC_LIMB (cy, u0, u0, u2 & B2); u0 -= (-cy) & d; /* Final q update */ add_ssaaaa (q2, q1, q2, q1, CNST_LIMB(0), cy); qp[j+1] = q1; MPN_INCR_U (qp+j+2, n-j-2, q2); add_mssaaaa (u2, u1, u0, u0, up[j], p1, p0); } q1 = (u2 > 0); u1 -= (-q1) & d; t = (u1 >= d); q1 += t; u1 -= (-t) & d; udiv_qrnnd_preinv (t, u0, u1, u0, d, dinv); add_ssaaaa (q1, q0, q1, q0, CNST_LIMB(0), t); MPN_INCR_U (qp+1, n-1, q1); qp[0] = q0; return u0; } #else #error Unknown DIV_QR_1N_METHOD #endif gcl/gmp4/AUTHORS000066400000000000000000000071451242227143400135520ustar00rootroot00000000000000Authors of GNU MP (in chronological order of initial contribution) Torbjörn Granlund Main author John Amanatides Original version of mpz/pprime_p.c Paul Zimmermann mpn/generic/mul_fft.c, now defunct dc_divrem_n.c, rootrem.c, old mpz/powm.c, old toom3 code. Ken Weber Now defunct mpn/generic/bdivmod.c, old mpn/generic/gcd.c Bennet Yee Previous versions of mpz/jacobi.c mpz/legendre.c Andreas Schwab mpn/m68k/lshift.asm, mpn/m68k/rshift.asm Robert Harley Old mpn/generic/mul_n.c, previous versions of files in mpn/arm Linus Nordberg Random number framework, original autoconfery Kent Boortz MacOS 9 port, now defunct. Kevin Ryde Most x86 assembly, new autoconfery, and countless other things (please see the GMP manual for complete list) Gerardo Ballabio gmpxx.h and C++ istream input Pedro Gimeno Mersenne Twister random generator, other random number revisions Jason Moxham Previous versions of mpz/fac_ui.c and gen-fac_ui.c Niels Möller gen-jacobitab.c, mpn/generic/hgcd2.c, hgcd.c, hgcd_step.c, hgcd_appr.c, hgcd_matrix.c, hgcd_reduce.c, gcd.c, gcdext.c, matrix22_mul.c, gcdext_1.c, gcd_subdiv_step.c, gcd_lehmer.c, gcdext_subdiv_step.c, gcdext_lehmer.c, jacobi_2.c, jacbase.c, hgcd_jacobi.c, hgcd2_jacobi.c matrix22_mul1_inverse_vector.c, toom_interpolate_7pts, mulmod_bnm1.c, dcpi1_bdiv_qr.c, dcpi1_bdiv_q.c, sbpi1_bdiv_qr.c, sbpi1_bdiv_q.c, sec_invert.c, toom_eval_dgr3_pm1.c, toom_eval_dgr3_pm2.c, toom_eval_pm1.c, toom_eval_pm2.c, toom_eval_pm2exp.c, divexact.c, mod_1_1.c, div_qr_2.c, div_qr_2n_pi1.c, div_qr_2u_pi1.c, broot.c, brootinv.c, mpn/x86/k7/invert_limb.asm, mod_1_1.asm, mpn/x86_64/invert_limb.asm, invert_limb_table.asm, mod_1_1.asm, div_qr_2n_pi1.asm, div_qr_2u_pi1.asm, mpn/x86_64/core2/aorsmul_1.asm, mpz/nextprime.c, divexact.c, gcd.c, gcdext.c, jacobi.c, combit.c, mini-gmp/mini-gmp.c. Marco Bodrato mpn/generic/toom44_mul.c, toom4_sqr.c, toom53_mul.c, toom62_mul.c, toom43_mul.c, toom52_mul.c, toom54_mul.c, toom_interpolate_6pts.c, toom_couple_handling.c, toom63_mul.c, toom_interpolate_8pts.c, toom6h_mul.c, toom6_sqr.c, toom_interpolate_12pts.c, toom8h_mul.c, toom8_sqr.c, toom_interpolate_16pts.c, mulmod_bnm1.c, sqrmod_bnm1.c, nussbaumer_mul.c, toom_eval_pm2.c, toom_eval_pm2rexp.c, mullo_n.c, invert.c, invertappr.c; mpz/fac_ui.c, 2fac_ui.c, mfac_uiui.c, oddfac_1.c, primorial_ui.c, prodlimbs.c, goetgheluck_bin_uiui.c. David Harvey mpn/generic/add_err1_n.c, add_err2_n.c, add_err3_n.c, sub_err1_n.c, sub_err2_n.c, sub_err3_n.c, mulmid_basecase.c, mulmid_n.c, toom42_mulmid.c, mpn/x86_64/mul_basecase.asm, aors_err1_n.asm, aors_err2_n.asm, aors_err3_n.asm, mulmid_basecase.asm, mpn/x86_64/core2/aors_err1_n.asm. Martin Boij mpn/generic/perfpow.c Marc Glisse gmpxx.h improvements David Miller mpn/sparc32/ultrasparct1/{addmul_1,mul_1,submul_1}.asm mpn/sparc64/ultrasparct3/{mul_1,addmul_1,submul_1}.asm mpn/sparc64/ultrasparct3/{add_n,sub_n}.asm mpn/sparc64/ultrasparct3/{popcount,hamdist}.asm mpn/sparc64/ultrasparct3/cnd_aors_n.asm mpn/sparc64/{rshift,lshift,lshiftc}.asm mpn/sparc64/tabselect.asm Mark Sofroniou mpn/generic/mul_fft.c type cleanup. Ulrich Weigand Changes to support powerpc64le: configure.ac, mpn/powerpc64/{elf,aix,darwin}.m4, mpn/powerpc32/{darwin,elf}.m4, mpn/powerpc64/mode64/{dive_1,divrem_1,divrem_2}.asm, mpn/powerpc64/mode64/{gcd_1,invert_limb,mode1o}.asm, mpn/powerpc64/mode64/{mod_1_1,mod_1_4}.asm, mpn/powerpc64/mode64/p7/gcd_1.asm, mpn/powerpc64/p6/{lshift,lshiftc,rshift}.asm, mpn/powerpc64/vmx/popcount.asm. gcl/gmp4/COPYING000066400000000000000000001045131242227143400135320ustar00rootroot00000000000000 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 . gcl/gmp4/COPYING.LESSERv3000066400000000000000000000167271242227143400150100ustar00rootroot00000000000000 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. gcl/gmp4/COPYINGv2000066400000000000000000000432541242227143400140060ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. gcl/gmp4/COPYINGv3000066400000000000000000001045161242227143400140060ustar00rootroot00000000000000 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 . gcl/gmp4/ChangeLog000066400000000000000000041312671242227143400142630ustar00rootroot000000000000002014-03-24 Torbjorn Granlund * Version 6.0.0 released. * mpn: Update countless gmp-mparam.h files. 2014-03-22 Torbjorn Granlund * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*): Bump version info. * gmp-h.in: Bump version. 2014-03-17 Torbjorn Granlund * configure.ac: Remove clipper, i960, ns32k, pyr, a29k, z8000. * mpn/clipper: Remove directory and all its files. * mpn/i960: Likewise. * mpn/ns32k: Likewise. * mpn/pyr: Likewise. * mpn/a29k: Likewise. * mpn/z8000: Likewise. * mpn/Makefile.am (TARG_DIST): Purge removed directories. * doc/gmp.texi: Remove special mentions of removed architectures. 2014-03-12 Marco Bodrato * mini-gmp/mini-gmp.c (mpz_probab_prime_p): Micro-optimisation. 2014-03-12 Torbjorn Granlund * mpn/x86/bd2/gmp-mparam.h: New file. * mpn/x86_64/bd2/gmp-mparam.h: New file. 2014-03-06 Niels Möller * tests/mpz/t-pprime_p.c (check_composites): New function. (check_primes): New function. (main): Call them. Also use TESTS_REPS. * mini-gmp/mini-gmp.c (gmp_millerrabin): New internal function. (mpz_probab_prime_p): New function. * mini-gmp/mini-gmp.h (mpz_probab_prime_p): Declare it. * mini-gmp/tests/t-pprime_p.c: New test program. * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Added t-pprime_p. 2014-03-03 Niels Möller * mini-gmp/mini-gmp.c (mpz_congruent_p): New function. * mini-gmp/mini-gmp.h: Declare it. * mini-gmp/tests/t-cong.c: New file, based on tests/mpz/t-cong.c. * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Added t-cong. * mini-gmp/tests/testutils.c (dump): New function. Deleted static functions in other files. (mpz_set_str_or_abort): Moved function here, from... * mini-gmp/tests/t-cmp_d.c: ... old location. * mini-gmp/tests/t-reuse.c (dump3): Renamed, from ... (dump): ...old name. 2014-03-01 Niels Möller * mpn/generic/sec_powm.c (mpn_sec_powm): Clarify comment and asserts. 2014-02-28 Torbjorn Granlund * mpn/x86_64/fat/fat.c (fake_cpuid): Handle id 7, make bold claims. 2014-02-27 Torbjorn Granlund * mpn/x86_64/fat/fat_entry.asm: Zero ecx for the benefit of new BMI2 feature test. * mpn/x86_64/fat/fat.c (__gmpn_cpuvec_init): Run CPUVEC_SETUP_coreihwl conditionally on BMI2 availability. * config.guess: Revert "coreihwl" to "coreisbr" if cpuid indicates that BMI2 is missing. (x86 cpuid, 2 variants): Zero ecx for the benefit of new BMI2 feature test. 2014-02-21 Marco Bodrato * mini-gmp/mini-gmp.c (mpn_sqrtrem): New function. * mini-gmp/mini-gmp.h: Declare it. * mini-gmp/tests/t-sqrt.c: Test it. 2014-02-17 Niels Möller * mpn/generic/div_qr_1.c (mpn_div_qr_1): Revert yesterday's fix. Hopefully no longer needed. * mpn/s390_64/gmp-mparam.h (DIV_QR_1_NORM_THRESHOLD): Up to 1. * mpn/s390_64/z10/gmp-mparam.h (DIV_QR_1_NORM_THRESHOLD): Up to 1. * tune/tuneup.c (tune_div_qr_1): Ensure DIV_QR_1_NORM_THRESHOLD, DIV_QR_1_UNNORM_THRESHOLD >= 1. 2014-02-16 Marco Bodrato * mpn/generic/div_qr_1.c: Disallow DIV_QR_1_NORM_THRESHOLD==0. 2014-02-15 Torbjorn Granlund * tests/mpn/t-div.c: Fix typo. 2014-02-15 Marco Bodrato * doc/gmp.texi (mpz_roinit_n, MPZ_ROINIT_N): Document that at least a readable limb is required. * mini-gmp/mini-gmp.c (mpz_div_qr): init + set = init_set . 2014-02-14 Niels Möller * doc/gmp.texi (Low-level Functions): Update docs for mpn_sec_powm, to specify that left-over exponent bits must be zero. 2014-02-11 Niels Möller * Makefile.am (EXTRA_DIST): Distribute COPYING.LESSERv3, COPYINGv2, and COPYINGv3. * doc/gmp.texi (Low-level Functions): Updated mpn_sec_powm docs. * mpn/generic/sec_powm.c (mpn_sec_powm): Replaced exponent limb count argument by bit count. Don't leak high exponent bits, and drop the requirement that the most significant exponent limb is non-zero. (mpn_sec_powm_itch): Analogous interface change. * gmp-h.in: Updated prototypes. * mpz/powm_sec.c (mpz_powm_sec): Update mpn_sec_powm* calls. * tune/tuneup.c (tune_powm_sec): Likewise. Also deleted code fiddling with the high exponent bits. 2014-02-10 Marco Bodrato * mini-gmp/tests/t-limbs.c: New test for mpz_limbs_*. * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Add it. 2014-02-09 Niels Möller * tune/tuneup.c (tune_powm_sec): Avoid timing of the nonsensical parameters nbits = 1, winsize = 2. Decrement tabulated values, to better match the > comparison when the table is used. * mpn/generic/sec_powm.c (win_size): Comment why we always get win_size(eb) <= eb. Make the table const. (mpn_sec_powm): Deleted handling of winsize > initial ebi. For now, replaced with an ASSERT_ALWAYS. 2014-02-08 Marco Bodrato * mini-gmp/mini-gmp.c (mpz_realloc2, mpz_limbs_read, mpz_limbs_modify mpz_limbs_write, mpz_limbs_finish, mpz_roinit_n): New functions. (mpn_perfect_square_p): New function. * mini-gmp/mini-gmp.h: Declare them. * mini-gmp/tests/t-mul.c: Use roinit and limbs_read to test mpn. * mini-gmp/tests/t-sqrt.c: Test also mpn_perfect_square_p. 2014-02-08 Niels Möller * mpn/generic/sec_invert.c (mpn_cnd_neg_itch): #if:ed out unused function. * mpn/generic/sec_div.c: Simplified code for the normalized case. * tests/mpn/t-div.c (main): Test mpn_sec_div_qr and mpn_sec_div_r with normalized d. 2014-02-04 Niels Möller * doc/gmp.texi (Low-level Functions): Document mpn_sec_add_1 and mpn_sec_sub_1. 2014-02-03 Marco Bodrato * mini-gmp/mini-gmp.c (mpn_rootrem): Allow NULL argument. * mini-gmp/mini-gmp.c (mpn_zero): New function. (mpz_perfect_square_p): New function. * mini-gmp/mini-gmp.h: Declare them. * mini-gmp/tests/t-sqrt.c: Test mpz_perfect_square_p. * mini-gmp/tests/t-root.c: Test also 1-th root, allow perfect powers. 2014-01-29 Torbjorn Granlund * doc/gmp.texi (Floating-point Functions): Revise. 2014-01-29 Niels Möller * README: Don't refer to specific COPYING* files, instead refer to manual for details. * COPYING.LIB: Renamed, to... * COPYING.LESSERv3: ... new name. * COPYING: Renamed, to... * COPYINGv3: ... new name. * COPYINGv2: New file, GPLv2. * doc/gmp.texi (Copying): Document dual licensing. 2014-01-27 Torbjorn Granlund * Update library files license to use LGPL3+ and GPL2+. 2014-01-27 Marco Bodrato * tests/mpn/t-aors_1.c: Check sec_aors_1 red zones (not smart). * mpn/generic/sec_aors_1.c: Mark the 2nd argument as const. * gmp-h.in (mpn_sec_add_1, mpn_sec_sub_1): Likewise. 2014-01-24 Torbjorn Granlund * mpn/x86_64/fat/fat.c (fake_cpuid_table): Use proper steamroller and excavator values. * config.guess: Amend last AMD change. * mpn/s390_64/lshift.asm: Align loop. * mpn/s390_64/rshift.asm: Likewise. * mpn/s390_64/lshiftc.asm: Likewise. * mpn/s390_64: Add z10 cycle numbers. 2014-01-23 Marco Bodrato * printf/repl-vsnprintf.c: Feed case 'z' in switch (type) with case 'z' in switch (fchar). * mini-gmp/tests/t-aorsmul.c: New file, test for mpz_{add,sub}mul{,_ui} * mini-gmp/tests/Makefile: Add t-aorsmul. 2014-01-21 Marco Bodrato * acinclude.m4 (GMP_FUNC_VSNPRINTF): Get rid of varargs. 2014-01-20 Torbjorn Granlund * mpn/x86_64/fat/fat.c (__gmpn_cpuvec_init): Fix duplicate entries for AMD "jaguar". * demos/expr: Get rid of varargs code and references. 2014-01-19 Torbjorn Granlund * config.guess: Add new AMD CPUs (piledriver, steamroller, excavator, jaguar). * config.sub: Corresponding updates. * configure.ac: Likewise. * acinclude.m4 (X86_64_PATTERN): Likewise. * mpn/x86_64/fat/fat.c: Likewise. * Rename mpn_sec_minvert => mpn_sec_invert, many files affected. * mpn/generic/sec_invert.c: New name for sec_minvert.c. * doc/gmp.texi: Undocument mpz_array_init. * acinclude.m4 (GMP_C_STDARG): Comment out. * configure.ac: Suppress GMP_C_STDARG invocation. * Get rid of varargs code and references, many file affected. * Use mpq_t in favour of MP_RAT, many mpq files affected. * Get rid of BYTES_PER_MP_LIMB, most files affected. * mpz/iset.c: Avoid overflow in allocation computation. * mpz/mul.c: Likewise. * mpf/init.c: Likewise. * mpf/init2.c: Likewise. * mpf/iset.c: Likewise. * mpf/iset_d.c: Likewise. * mpf/iset_si.c: Likewise. * mpf/iset_str.c: Likewise. * mpf/iset_ui.c: Likewise. * mpz/array_init.c: Avoid two overflow scenarios in allocation computation. * mpn/s390_64/z10/gmp-mparam.h: New file. * mpz/clears.c: Call __gmp_free_func ourselves instead of via mpz_clears. * mpf/clears.c: Analogous change. * mpq/clears.c: Analogous change. * mpz/clear.c: Add cast to avoid overflow of (later ignored) argument. * mpf/clear.c: Likewise. 2014-01-19 Marco Bodrato * mini-gmp/mini-gmp.c (mpn_popcount): New function. (mpz_popcount): Use it. (mpz_addmul_ui, mpz_addmul, mpz_submul_ui, mpz_submul): Added. * mini-gmp/mini-gmp.h: Declare them. 2014-01-18 Niels Möller * tests/mpn/t-aors_1.c: Test also mpn_sec_add_1 and mpn_sec_sub_1. * tests/mpn/t-minvert.c (main): Pass smallest allowed bit_size argument to mpn_sec_minvert. 2014-01-18 Marc Glisse * doc/gmp.texi (C++ Interface Limitations): Warn against C++11 auto. 2014-01-18 Marco Bodrato * tests/t-parity.c: Use 1UL to generate unsigned constants. * tests/t-constants.c: Disable a non portable (unneeded) check. 2014-01-18 Niels Möller * mpn/generic/sec_aors_1.c (mpn_sec_add_1, mpn_sec_sub_1): New file. * mpn/generic/sec_minvert.c (mpn_sec_add_1_itch, mpn_sec_add_1): Deleted static definitions. (mpn_cnd_swap): Use volatile. * configure.ac (gmp_mpn_functions): sec_add_1 and sec_sub_1. (GMP_MULFUNC_CHOICES): Set up for sec_aors_1. 2014-01-16 Niels Möller * tune/common.c (speed_mpn_sec_minvert): New function. * tune/speed.h: Declare it. (SPEED_ROUTINE_MPN_SEC_MINVERT): New macro. * tune/speed.c (routine): Added mpn_sec_minvert. * mini-gmp/mini-gmp.c (mp_bits_per_limb): New const value. * mini-gmp/mini-gmp.h: Declare it. 2014-01-12 Marc Glisse * demos/expr/expr.h: Add extern "C" for C++. 2014-01-11 Torbjorn Granlund * doc/gmp.texi (Notes for Particular Systems): Add items about old NetBSD and current FreeBSD m4 problems. Add item about FreeBSD's broken limits.h. 2014-01-05 Marco Bodrato * gmp-impl.h: Declare all _itch functions using ATTRIBUTE_CONST. 2014-01-05 Torbjorn Granlund * configure.ac (alpha): Set extra_functions conditionally. * gmp-h.in (mpn_sec_minvert): Remove formal parameters. * doc/gmp.texi: Improve doc for several functions. * mpn/generic/sec_tabselect.c: Declare input arg using 'const'. * gmp-h.in: Analogous change. * gmp-h.in: Declare all itch functions using __GMP_ATTRIBUTE_PURE. * gmp-impl.h: Likewise. 2014-01-05 Marco Bodrato * tests/mpn/t-minvert.c: Always compare with mpz_invert results, add red zone to scratch. * tests/mpn/t-sizeinbase.c: New test. * tests/mpn/Makefile.am (check_PROGRAMS): Added t-sizeinbase.c . * tests/mpn/t-div.c: Use mpn_sec_div_*_itch(). * mpn/generic/pow_1.c: Micro-optimisation. 2014-01-04 Torbjorn Granlund * acinclude.m4 (GMP_PROG_M4): Avoid hex output, since case varies. 2014-01-03 Torbjorn Granlund * config.guess: Support newer haswell, broadwell, silvermont. * mpn/x86_64/fat/fat.c (__gmpn_cpuvec_init): Likewise. * acinclude.m4 (GMP_PROG_M4): Check that eval's radix argument work. * mpz/invert.c: Rely on gcdext for all operands, removing faulty special case. * tests/mpz/t-invert.c: Enforce correct behaviour for |mod| = 1. 2014-01-02 Niels Möller * doc/gmp.texi (Low-level Functions): Document mpn_sizeinbase. Enable previously unused mpn_sizeinbase function. * configure.ac (gmp_mpn_functions): Added sizeinbase. * gmp-h.in (mpn_sizeinbase): New prototype. 2014-01-02 Marc Glisse * gmp-impl.h: Always include . * tests/mpn/t-get_d.c: Remove comment about * gmp-h.in (__GMP_USHRT_MAX): Use the promoted type. * gmp-impl.h (USHRT_HIGHBIT, SHRT_MIN, SHRT_MAX): Likewise. * tests/t-constants.c: Adapt printf strings. * tests/t-gmpmax.c: Likewise. * tests/mpn/t-hgcd_appr.c (hgcd_appr_valid_p): Add parentheses. 2014-01-01 Torbjorn Granlund * doc/gmp.texi (Low-level Functions for cryptography): Update interface for mpn_sec_div_qr and fix typos in mpn_sec_minvert text. * mpn/generic/sec_div.c: Rewrite to make mpn_sec_div_qr return high quotient limb. * gmp-h.in (mpn_sec_div_qr): Update declaration. * tests/mpn/t-div.c: Adapt. 2013-12-31 Niels Möller * doc/gmp.texi (Low-level Functions for cryptography): Document mpn_sec_minvert. 2013-12-30 Marc Glisse * doc/gmp.texi (C++ interface internals): Break long line. 2013-12-30 Torbjorn Granlund * doc/gmp.texi (Low-level Functions for cryptography): New section. 2013-12-29 Niels Möller * tests/mpn/Makefile.am (check_PROGRAMS): Added t-minvert. * tests/mpn/t-minvert.c: New file. * configure.ac (gmp_mpn_functions): Added sec_minvert. * gmp-h.in (mpn_sec_minvert, mpn_sec_minvert_itch): New declarations. * mpn/generic/sec_minvert.c (mpn_sec_minvert) (mpn_sec_minvert_itch): New functions. (mpn_sec_add_1, mpn_cnd_neg, mpn_cnd_swap, mpn_sec_eq_ui): New helper functions. 2013-12-28 Torbjorn Granlund * mpn/generic/sec_powm.c: Fix an ASSERT. * gmp-h.in (mpn_sec_mul, mpn_sec_mul_itch): New declarations. * gmp-h.in (mpn_sec_sqr, mpn_sec_sqr_itch): Likewise. * mpn/generic/sec_mul.c: New file. * mpn/generic/sec_sqr.c: New file. * gmp-h.in (mpn_sec_powm, mpn_sec_powm_itch): New declarations. * gmp-h.in (mpn_sec_div_qr, mpn_sec_div_qr_itch): Likewise. * gmp-h.in (mpn_sec_div_r, mpn_sec_div_r_itch): Likewise. * gmp-impl: Remove declarations of above functions. * configure.ac (gmp_mpn_functions): Add sec_mul and sec_sqr. 2013-12-26 Marco Bodrato * Update many file's encoding to UTF-8. * doc/tasks.html: Update accordingly. * doc/projects.html: Likewise. 2013-12-26 Torbjorn Granlund * configure.ac: Rename mpn_blah_sec to mpn_sec_blah. * gmp-impl.h: Corresponding changes. * mpn/asm-defs.m4: Corresponding changes. * tune/Makefile.am: Corresponding changes. * tune/common.c: Corresponding changes. * tune/speed.c: Corresponding changes. * tune/speed.h: Corresponding changes. * tune/tuneup.c: Corresponding changes. * mpz/powm_sec.c: Update calls. * tests/mpn/t-div.c: Likewise. * mpn/generic/sec_powm.c: New name for mpn/generic/powm_sec.c. * mpn/generic/sec_div.c: New name for mpn/generic/sb_div_sec.c. * mpn/generic/sec_pi1_div.c: New name for mpn/generic/sbpi1_div_sec.c. * mpn/generic/sec_tabselect.c: New name for mpn/generic/tabselect.c. * mpn/alpha/sec_tabselect.asm: New name for tabselect.asm. * mpn/arm/neon/sec_tabselect.asm: New name for tabselect.asm. * mpn/arm/sec_tabselect.asm: New name for tabselect.asm. * mpn/ia64/sec_tabselect.asm: New name for tabselect.asm * mpn/powerpc32/sec_tabselect.asm: New name for tabselect.asm * mpn/powerpc64/sec_tabselect.asm: New name for tabselect.asm * mpn/sparc64/sec_tabselect.asm: New name for tabselect.asm * mpn/x86/mmx/sec_tabselect.asm: New name for tabselect.asm * mpn/x86/sec_tabselect.asm: New name for tabselect.asm * mpn/x86_64/bd1/sec_tabselect.asm: New name for tabselect.asm * mpn/x86_64/core2/sec_tabselect.asm: New name for tabselect.asm * mpn/x86_64/coreinhm/sec_tabselect.asm: New name for tabselect.asm * mpn/x86_64/coreisbr/sec_tabselect.asm: New name for tabselect.asm * mpn/x86_64/fastsse/sec_tabselect.asm: New name for tabselect.asm * mpn/x86_64/k10/sec_tabselect.asm: New name for tabselect.asm * mpn/x86_64/pentium4/sec_tabselect.asm: New name for tabselect.asm * mpn/x86_64/sec_tabselect.asm: New name for tabselect.asm 2013-12-25 Torbjorn Granlund * mpz/powm_sec.c: Handle 0^e mod m specially. * mpn/generic/powm_sec.c: ASSERT that the base is non-zero. 2013-12-23 Torbjorn Granlund * mpn/generic/powm_sec.c (redcify): Use passed scratch instead of locally allocated. (mpn_powm_sec_itch): Accommodate mpn_sb_div_r_sec's scratch needs. 2013-12-20 Mark Sofroniou * mpn/generic/mul_fft.c: Major overhaul of types. 2013-12-18 Torbjorn Granlund * doc/gmp.texi (Low-level Functions): Rewrite mpn_set_str docs. 2013-12-14 Ulrich Weigand * mpn/powerpc32/darwin.m4: Allow (and ignore) optional 'toc' parameter to PROLOGUE_cpu. * mpn/powerpc32/elf.m4: Likewise. 2013-12-09 Ulrich Weigand * configure.ac: Check for ELFv2 ABI on PowerPC. * mpn/powerpc64/elf.m4: Set assembler ABI version for ELFv2 and use appropriate PROLOGUE_cpu/EPILOGUE_cpu sequences. Support optional 'toc' parameter to PROLOGUE_cpu. * mpn/powerpc64/aix.m4: Allow (and ignore) optional 'toc' parameter to PROLOGUE_cpu. * mpn/powerpc64/darwin.m4: Likewise. * mpn/powerpc64/mode64/dive_1.asm (mpn_divexact_1): Add 'toc' parameter to PROLOGUE. * mpn/powerpc64/mode64/divrem_1.asm (mpn_divrem_1): Likewise. * mpn/powerpc64/mode64/divrem_2.asm (mpn_divrem_2): Likewise. * mpn/powerpc64/mode64/gcd_1.asm (mpn_gcd_1): Likewise. * mpn/powerpc64/mode64/invert_limb.asm (mpn_invert_limb): Likewise. * mpn/powerpc64/mode64/mod_1_1.asm (mpn_mod_1_1p_cps): Likewise. * mpn/powerpc64/mode64/mod_1_4.asm (mpn_mod_1s_4p_cps): Likewise. * mpn/powerpc64/mode64/mode1o.asm (mpn_modexact_1c_odd): Likewise. * mpn/powerpc64/mode64/p7/gcd_1.asm (mpn_gcd_1): Likewise. * mpn/powerpc64/p6/lshift.asm (mpn_lshift): Likewise. * mpn/powerpc64/p6/lshiftc.asm (mpn_lshiftc): Likewise. * mpn/powerpc64/p6/rshift.asm (mpn_rshift): Likewise. * mpn/powerpc64/vmx/popcount.asm (mpn_popcount): Likewise. 2013-12-07 Niels Möller * configfsf.sub: Updated to version 2013-10-01, from gnulib. * configfsf.guess: Updated to version 2013-11-29, from gnulib. 2013-12-03 Torbjorn Granlund * mpn/generic/div_qr_1.c: Make constant args asm inlines become limbs. * mpn/generic/div_qr_1n_pi1.c: Likewise. * mpn/generic/div_qr_2.c: Likewise. * mpn/generic/div_qr_2.c: Likewise. * mpn/generic/mod_1_1.c: Likewise. * mpn/generic/mod_1_2.c: Likewise. * mpn/generic/mod_1_3.c: Likewise. * mpn/generic/mod_1_4.c: Likewise. * mpn/generic/mulmid_basecase.c: Likewise. * mpn/generic/mulmod_bnm1.c: Likewise. * mpn/generic/sqrmod_bnm1.c: Likewise. * mpn/sparc64/divrem_1.c: Likewise. * mpn/sparc64/mod_1_4.c: Likewise. * mpn/generic/toom_interpolate_7pts.c (BINVERT_15): Fix typo. 2013-11-11 Torbjorn Granlund * mpn/x86_64/dos64.m4 (CALL): Provide to override default. 2013-11-08 Torbjorn Granlund * mpn/x86_64/x86_64-defs.m4 (CALL): Swap PIC test and macro defn. * mpn/generic/div_qr_2.c: Test HAVE_HOST_CPU_FAMILY_x86, not i386. * doc/gmp.texi: Update many URLs. 2013-11-04 Torbjorn Granlund * configure.ac: Set symbol OPENBSD for x86-openbsd hosts. * mpn/x86_64/fat/fat_entry.asm (PRETEND_PIC): New name for PIC_OR_DARWIN. (PRETEND_PIC): Set also for OPENBSD. 2013-10-29 Torbjorn Granlund * printf/doprnt.c (__gmp_doprnt): Use memcpy instead of strcpy. 2013-10-24 Torbjorn Granlund * mpn/generic/div_qr_1u_pi2.c: New file. * mpn/generic/div_qr_1n_pi2.c: New file. 2013-10-24 Niels Möller * mpn/x86_64/div_qr_1n_pi1.asm: Bugfixes, for case n == 1 and in-place operation. * mpn/x86_64/k8/div_qr_1n_pi1.asm: Likewise. * mpn/generic/div_qr_1n_pi1.c (mpn_div_qr_1n_pi1): Bug fixes, off-by-one MPN_INCR_U, and support for in-place operation. 2013-10-24 Torbjorn Granlund * mpn/x86/fat/fat.c (fake_cpuid_table): Add Haswell. 2013-10-23 Torbjorn Granlund * mpn/x86_64/x86_64-defs.m4 (oplist): New define, data from `regnum'. (regnum): Use x86_lookup, feed oplist. 2013-10-22 Niels Möller * tests/devel/try.c: Support mpn_div_qr_1n_pi1. * mpn/x86_64/k8/div_qr_1n_pi1.asm: Moved the below k10 file here. Applied tweak from Torbjörn to get it to run well on k8. * mpn/x86_64/k10/div_qr_1n_pi1.asm: New file (renamed above). Differs from generic x86_64 version by using cmov. * mpn/x86_64/div_qr_1n_pi1.asm: Reordered arguments to second mul. Deleted misleading cycle annotations. 2013-10-21 Niels Möller * configure.ac: Add HAVE_NATIVE_mpn_div_qr_1n_pi1 to config.in. * mpn/generic/div_qr_1n_pi1.c (mpn_div_qr_1n_pi1): Fix typos affecting ASSERT. 2013-10-20 Niels Möller * mpn/x86_64/div_qr_1n_pi1.asm: New file. * tune/div_qr_1_tune.c (__gmpn_div_qr_1n_pi1): Check div_qr_1n_pi1_method only when !HAVE_NATIVE_mpn_div_qr_1n_pi1. * mpn/asm-defs.m4 (define_mpn): Add div_qr_1n_pi1. * tune/common.c (speed_mpn_div_qr_1): New function, replacing... (speed_mpn_div_qr_1n, speed_mpn_div_qr_1u): ... deleted functions (speed_mpn_div_qr_1n_pi1, speed_mpn_div_qr_1n_pi1_1) (speed_mpn_div_qr_1n_pi1_2): New functions. * gmp-impl.h [TUNE_PROGRAM_BUILD]: Declare div_qr_1-related tuning variables. * tune/tuneup.c (speed_mpn_div_qr_1_tune, tune_div_qr_1): New functions. (div_qr_1n_pi1_method, div_qr_1_norm_threshold) (div_qr_1_unnorm_threshold): New globals. * tune/speed.c (routine): Replaced mpn_div_qr_1n and mpn_div_qr_1u by mpn_div_qr_1, requiring ".r" parameter. Added mpn_div_qr_1n_pi1 and variants. * tune/speed.h (SPEED_ROUTINE_MPN_DIV_QR_1): Use the "r" parameter as divisor. * tune/div_qr_1n_pi1_2.c: New file. * tune/div_qr_1n_pi1_1.c: New file. * tune/div_qr_1_tune.c: New file. * tune/Makefile.am (libspeed_la_SOURCES): Added div_qr_1n_pi1_1.c, div_qr_1n_pi1_2.c, and div_qr_1_tune.c. * tune/speed.c (routine): Added mpn_div_qr_1n and mpn_div_qr_1u. * tune/speed.h (SPEED_ROUTINE_MPN_DIV_QR_1): New macro. (speed_mpn_div_qr_1n, speed_mpn_div_qr_1u): Declare. * tune/common.c (speed_mpn_div_qr_1n, speed_mpn_div_qr_1u): New functions. * gmp-impl.h (mpn_div_qr_1n_pi1): Declare function. * gmp-h.in (mpn_div_qr_1): Declare function. * configure.ac (gmp_mpn_functions): Added div_qr_1 and div_qr_1n_pi1. * mpn/generic/div_qr_1.c (mpn_div_qr_1): New file and function. * mpn/generic/div_qr_1n_pi1.c (mpn_div_qr_1n_pi1): New file and function. * tests/mpn/t-div.c (main): Test mpn_div_qr_1. 2013-10-17 Torbjorn Granlund * configure.ac (alpha): Pass -mieee via gcc_cflags_maybe. 2013-10-16 Torbjorn Granlund * config.guess: Let AMD64 cpuid bit override pessimistic cpu guesses. * mpn/alpha/unicos.m4 (DATASTART): Accept optional align parameter. * mpn/alpha/divrem_2.asm: Use provided gp mechanisms. * mpn/alpha/default.m4 (PROLOGUE): Provide "..ng" post-gp label. * mpn/alpha/invert_limb.asm: Align table to 8-byte boundary. Make code work if table is not fully aligned. Properly test for BWX. 2013-10-15 Torbjorn Granlund * mpn/alpha/default.m4 (DATASTART): Use RODATA instead of DATA; accept optional align parameter. * mpn/alpha/invert_limb.asm: Align table. * mpn/alpha/ev5/diveby3.asm: Likewise. 2013-10-11 Torbjorn Granlund * mpn/x86/k7/mod_1_1.asm: Use 'subl' form to avoid ambiguity. * mpn/x86/k7/mod_1_4.asm: Likewise. * configure.ac (X86_64_PATTERN): Append "cc" to cclist_64 and cclist_x32. 2013-10-08 Torbjorn Granlund Marc Glisse * tests/mpf/reuse.c (main): Compare addresses instead of names. Use larger numbers for exponents. 2013-10-08 Marc Glisse * doc/mdate-sh, doc/texinfo.tex, install-sh, missing, ylwrap: Remove. * .bootstrap: Use autoreconf (and in particular automake -a). * gmp-h.in: Remove __need_size_t. Include , not . * tests/mpf/reuse.c (main): Use small numbers as exponents. 2013-10-05 Torbjorn Granlund * mpn/x86_64/atom/aorsmul_1.asm: Slight tweak. * doc/gmp.texi (ABI and ISA): Document x32. * mpn/sparc64/ultrasparct3/dive_1.asm: Use our register names. 2013-09-24 Torbjorn Granlund * mpn/x86_64/atom/redc_1.asm: New file. 2013-09-23 Torbjorn Granlund * mpn/x86_64/bobcat/redc_1.asm: Make the code for 1 <= n <= 3 work. 2013-09-22 Torbjorn Granlund * mpn/x86_64/coreisbr/redc_1.asm: Slightly tweak basecase code. * mpn/x86_64/core2/redc_1.asm: New file. * mpn/x86_64/bobcat/redc_1.asm: New file. 2013-09-21 Torbjorn Granlund * mpn/x86_64/coreinhm/redc_1.asm: New file. 2013-09-21 Marc Glisse * tests/mpn/t-mulmid.c: Cast arguments of printf to int to match %d. * tests/rand/t-urbui.c: Use 1UL for unsigned constant. * mpn/generic/get_str.c: Avoid temporarily pointing outside an array. 2013-09-20 Torbjorn Granlund * mpn/x86_64/coreisbr/redc_1.asm: New file. * mpn/x86_64/k8/redc_1.asm: Complete rewrite. * mpn/x86_64/coreisbr/mullo_basecase.asm: Postpone pushes, short- circuit a branch. * mpn/x86_64/coreihwl/mullo_basecase.asm: Short-circuit a branch. * mpn/x86_64/core2/mullo_basecase.asm: New file. 2013-09-19 Torbjorn Granlund * mpn/x86_64/fastsse/copyi-palignr.asm: Allocate more stack under DOS. 2013-09-18 Torbjorn Granlund * mpn/x86_64/core2/mul_basecase.asm: New file. * mpn/x86_64/core2/sqr_basecase.asm: New file. * mpn/x86_64/coreihwl/mullo_basecase.asm: New file. * mpn/x86_64/coreisbr/mullo_basecase.asm: New file. 2013-09-16 Torbjorn Granlund * mpn/x86_64/fastsse/copyi-palignr.asm: Preserve xmm6-xmm8 under DOS. 2013-09-15 Torbjorn Granlund * mpn/x86_64/tabselect.asm: Use R8 for bit testing. * mpn/x86_64/coreihwl/mul_basecase.asm: Replace mul_1 code. * mpn/x86_64/coreisbr/aorsmul_1.asm: Rewrite. 2013-09-12 Torbjorn Granlund * mpn/ia64/gcd_1.asm: Use dep for combining table base and low bits. * mpn/x86_64/fastsse/com-palignr.asm: Implement temp fix to properly handle overlap. 2013-09-10 Torbjorn Granlund * mpn/x86_64/fastsse/copyi-palignr.asm: Rewrite rp != up (mod 16) code to make it handle any allowed overlap. 2013-09-09 Torbjorn Granlund * mpn/x86_64/atom/com.asm: New file, grabbing fastsse code. * mpn/x86_64/bd1/copyi.asm: New file, grabbing fastsse code. * mpn/x86_64/bd1/copyd.asm: Likewise. * mpn/x86_64/bd1/com.asm: Likewise. * mpn/x86_64/fastavx/copyi.asm: New file. * mpn/x86_64/fastavx/copyd.asm: New file. 2013-09-05 Torbjorn Granlund * mpn/x86_64/coreihwl/aorsmul_1.asm: Streamline. 2013-09-04 Torbjorn Granlund * mpn/x86_64/coreihwl/sqr_basecase.asm: Implement larger "corner". Misc tuning. 2013-09-03 Torbjorn Granlund * mpn/x86_64/coreihwl/redc_1.asm: New file. * mpn/x86_64/x86_64-defs.m4 (mulx): Handle negative offsets. 2013-08-31 Torbjorn Granlund * mpn/x86_64/coreisbr/sqr_basecase.asm: New file. * mpn/x86_64/sqr_diag_addlsh1.asm: New file. 2013-08-30 Torbjorn Granlund * mpn/x86_64/fat/mul_basecase.c: New file. * mpn/x86_64/fat/sqr_basecase.c: New file. * mpn/x86_64/fat/mullo_basecase.c: New file. * mpn/x86_64/fat/redc_1.c: New file. 2013-08-29 Torbjorn Granlund * mpn/x86_64/k8/mul_basecase.asm: Move top-level basecase file to k8 subdir. * mpn/x86_64/k8/sqr_basecase.asm: Likewise. * mpn/x86_64/k8/redc_1.asm: Likewise. * mpn/x86_64/k8/mullo_basecase.asm: Likewise. * mpn/x86_64/k8/mulmid_basecase.asm: Likewise. * mpn/ia64/aors_n.asm: Clean up some bundlings. * mpn/x86_64/fat/fat.c (__gmpn_cpuvec_init): Support Haswell. (fake_cpuid_table): Likewise. * configure.ac (x86): Remove any mulx paths. Let bwl path = hwl path. (fat_path): Add coreihwl. * mpn/x86_64/coreihwl/aorsmul_1.asm: Move from `mulx' directory, use mulx() macro. * mpn/x86_64/coreihwl/mul_1.asm: Likewise. * mpn/x86_64/coreihwl/mul_2.asm: Likewise. * mpn/x86_64/coreihwl/mul_basecase.asm: Likewise. * mpn/x86_64/coreihwl/sqr_basecase.asm: Likewise. * mpn/x86_64/x86_64-defs.m4 (mulx): New macro. (regnum, regnumh, ix): Supporting macros. 2013-08-28 Torbjorn Granlund * mpn/x86_64/coreisbr/divrem_1.asm: New file. 2013-08-23 Torbjorn Granlund * mpn/x86_64/fastsse/com-palignr.asm: New file, closely based on copyi-palignr.asm. * mpn/x86_64/fastsse/copyi.asm Use "test R8(reg)" instead of "bt". * mpn/x86_64/fastsse/copyd-palignr.asm: Likewise. * mpn/x86_64/fastsse/copyi-palignr.asm: Likewise. * mpn/x86_64/fastsse/lshift-movdqu2.asm: Likewise. * mpn/x86_64/fastsse/lshiftc-movdqu2.asm: Likewise. * mpn/x86_64/fastsse/rshift-movdqu2.asm: Likewise. * mpn/x86_64/fastsse/tabselect.asm: Likewise. * mpn/sparc64/ultrasparct3/sqr_diag_addlsh1.asm: New file. * mpn/alpha/aorslsh2_n.asm: New file. * mpn/alpha/aorslsh1_n.asm: Rewrite. * mpn/alpha/ev6/aorslsh1_n.asm: New file. 2013-08-21 Torbjorn Granlund * mpn/alpha/sqr_diag_addlsh1.asm: New file. * mpn/alpha/sqr_diagonal.asm: Remove. * mpn/alpha/ev6/sqr_diagonal.asm: Remove. 2013-08-20 Torbjorn Granlund * mpn/powerpc32/sqr_diag_addlsh1.asm: New file. * mpn/powerpc32/sqr_diagonal.asm: Remove. 2013-08-15 Torbjorn Granlund * mpn/x86_64/coreihwl/mulx/sqr_basecase.asm: New file. 2013-08-05 Torbjorn Granlund * mpn/x86_64/coreisbr/aors_n.asm: Complete rewrite. 2013-08-04 Torbjorn Granlund * mpn/x86_64/coreihwl/mulx/mul_basecase.asm: New file. * mpn/x86_64/bd1/mul_2.asm: New file. * mpn/x86_64/coreihwl/gmp-mparam.h: New file. 2013-08-03 Torbjorn Granlund * mpn/x86_64/coreihwl/mulx/mul_2.asm: New file. * mpn/x86_64/coreihwl/mulx/addmul_2.asm: New file. * mpn/x86_64/coreinhm/aorsmul_1.asm: New file. * mpn/x86_64/coreisbr/mul_basecase.asm: Save some O(n) and O(1) cycles. * mpn/x86_64/coreisbr/mul_2.asm: New file. 2013-08-02 Torbjorn Granlund * mpn/x86_64/coreisbr/addmul_2.asm: Complete rewrite. 2013-08-01 Torbjorn Granlund * mpn/x86_64/bd1/mul_basecase.asm: New file. * mpn/x86_64/coreisbr/mul_basecase.asm: New file. * mpn/x86_64/coreihwl/aorsmul_1.asm: New file. 2013-07-31 Torbjorn Granlund * mpn/x86_64/atom/mul_2.asm: New file. * mpn/x86_64/atom/addmul_2.asm: New file. * mpn/x86_64/atom/mul_1.asm: New file. * mpn/x86_64/atom/aorsmul_1.asm: New file. * mpn/x86_64/coreihwl/mul_1.asm: New file. * configure.ac (x86): Add Haswell-specific path. * configure.in (fat_functions): Add cnd_add_n, cnd_sub_n.. * gmp-impl.h (struct cpuvec_t): Add fields for new fat functions. * gmp-impl.h: Adjust corresponding declarations. * mpn/x86_64/x86_64-defs.m4 (CPUVEC_FUNCS_LIST): Add new fat functions. * mpn/x86/x86-defs.m4 (CPUVEC_FUNCS_LIST): Likewise. * mpn/x86_64/fat/fat.c (__gmpn_cpuvec): Likewise. * mpn/x86/fat/fat.c (__gmpn_cpuvec): Likewise. 2013-07-30 Torbjorn Granlund * mpn/x86_64/coreisbr/popcount.asm: New file. 2013-07-23 Torbjorn Granlund * mpn/x86_64/bobcat/aors_n.asm: New file. * mpn/x86_64/pentium4/aorslshC_n.asm: Remove a spurious emms insn. * mpn/x86_64/bd1/aorrlsh1_n.asm: New file. * mpn/x86_64/bd1/sublsh1_n.asm: New file. 2013-07-22 Torbjorn Granlund * mpn/powerpc64/mode64/mod_1_1.asm: Handle little-endian mode. * mpn/powerpc64/mode64/mod_1_4.asm: Likewise. 2013-07-16 Torbjorn Granlund * doc/gmp.texi: Declare countless of function arguments as 'const'. 2013-07-15 Torbjorn Granlund * mpn/x86_64/core2/aors_n.asm: Rewrite. * mpn/generic/sb_div_sec.c: Compute inverse as floor(B^2/(dh+1)), per Niels' suggestion. * mpn/generic/sbpi1_div_sec.c: Remove inverse rounding-up code. 2013-07-14 Torbjorn Granlund * mpn/powerpc64/mode64/divrem_1.asm: Remove explicit nop after CALL. * mpn/powerpc64/mode64/divrem_2.asm: Likewise. * mpn/powerpc64/mode64/mod_1_1.asm: Likewise. * mpn/powerpc64/mode64/mod_1_4.asm: Likewise. 2013-07-13 Torbjorn Granlund * mpn/x86/atom/cnd_add_n.asm: New file. * mpn/x86/atom/cnd_sub_n.asm: New file.o 2013-07-12 Torbjorn Granlund * mpn/generic/sbpi1_div_sec.c: Partial rewrite. 2013-07-11 Torbjorn Granlund * mpn/x86_64/cnd_aors_n.asm: Tweak for better speed on K8, bobcat, bd1, NHM, Atom. 2013-07-05 Torbjorn Granlund * mpn/powerpc64/p7/copyi.asm: Handle n = 0. * mpn/powerpc64/p7/copyd.asm: Likewise. 2013-07-04 Torbjorn Granlund * mpn/powerpc64/mode64/p7/aormul_2.asm: New file. * mpn/powerpc64/darwin.m4 (EXTRA_REGISTER): New define. * mpn/powerpc64/aix.m4: New define (actually undefine). * mpn/powerpc64/elf.m4: Likewise. 2013-07-03 Torbjorn Granlund * mpn/powerpc64/com.asm: Rewrite. * mpn/powerpc64/p7/copyi.asm: New file. * mpn/powerpc64/p7/copyd.asm: New file. 2013-07-02 Torbjorn Granlund * mpn/powerpc64/mode64/gcd_1.asm: New file. * mpn/powerpc64/mode64/p7/gcd_1.asm: New file. 2013-07-01 Torbjorn Granlund * configure.ac: Comment out AC_PROG_F77. * mpn/powerpc64/mode64/rsh1add_n.asm: Remove. * mpn/powerpc64/mode64/rsh1sub_n.asm: Remove. * mpn/powerpc64/mode64/rsh1aors_n.asm: New file, code not based on removed files. 2013-06-28 Marc Glisse * cxx/ismpf.cc: Use GMP_DECIMAL_POINT. * cxx/osmpf.cc: Likewise. * tests/cxx/t-locale.cc: Likewise. 2013-06-28 Torbjorn Granlund * mpn/powerpc64/mode64/p7/aorsorrlshC_n.asm: New file. * mpn/powerpc64/mode64/p7/aorsorrlsh1_n.asm: New file. * mpn/powerpc64/mode64/p7/aorsorrlsh2_n.asm: New file. * mpn/powerpc64/mode64/aorsorrlshC_n.asm: Use alias regname. 2013-06-27 Torbjorn Granlund * mpn/powerpc64/mode64/p7/aors_n.asm: New file. 2013-06-22 Torbjorn Granlund * aorslshC_n.asm, aorslsh2_n.asm, aorslsh1_n.asm: Remove. * aorsorrlshC_n.asm, aorsorrlsh1_n.asm, aorsorrlsh2_n.asm: New files. 2013-06-19 Torbjorn Granlund * mpn/powerpc64/p6/lshift.asm: Rewrite switching-into-loop code. * mpn/powerpc64/p6/rshift.asm: Likewise. * mpn/powerpc64/p6/lshiftc.asm: Likewise. 2013-06-17 Torbjorn Granlund * mpn/powerpc64/p6/lshift.asm: Fix typo in label reference. For 32-bit mode, zero extend `n' argument and split retval. * mpn/powerpc64/p6/rshift.asm: Likewise. * mpn/powerpc64/p6/lshiftc.asm: Likewise. 2013-06-10 Torbjorn Granlund * mpn/generic/mu_div_q.c: Remove obsolete comment. 2013-06-09 Marc Glisse * mpn/generic/get_d.c (mpn_get_d): Avoid signed overflow. * mpz/kronzs.c (mpz_kronecker_si): Use ABS_CAST. 2013-05-31 Torbjorn Granlund * mpn/generic/mu_div_q.c: Call mpn_mu_divappr_q for entire division, never just for tail. (This fixes performance issues at the expense of memory needs.) 2013-05-26 Torbjorn Granlund * configure.ac (*sparc*-*-*): Major overhaul. 2013-05-22 Torbjorn Granlund * doc/gmp.texi (Reporting Bugs): Ask for configure's output. * mpn/ia64/divrem_2.asm: Don't clobber f16-f18. 2013-05-20 Torbjorn Granlund * mpn/arm/udiv.asm: Change spacing to work around binutils bug. 2013-05-16 Torbjorn Granlund * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*): Bump version info. * tests/misc.c (tests_hardware_getround, tests_hardware_setround): Avoid assembly dependency unless WANT_ASSEMBLY. * configure.ac (WANT_ASSEMBLY): Conditionally define. 2013-05-14 Torbjorn Granlund * configure.ac (arm1156): Don't fall back to plain v6 compiler option. 2013-05-11 Torbjorn Granlund * mpn/x86_64/coreisbr/mul_1.asm: Handle n = 1 for DOS64. Streamline. * mpn/x86_64/coreisbr/aorsmul_1.asm: Streamline. 2013-05-10 Torbjorn Granlund * mpn/x86_64/coreisbr/aorsmul_1.asm: Fix, then enable DOS64 support. * mpn/x86_64/coreisbr/mul_1.asm: Enable DOS64 support. * mpn/x86/p6/mmx/gmp-mparam.h: Set down SQR_TOOM2_THRESHOLD to parent directory value. 2013-05-09 Torbjorn Granlund * configure.ac (--enable-fake-cpuid): New option. * mpn/x86_64/fat/fat.c (WANT_FAKE_CPUID): Remove defaulting. * mpn/x86/fat/fat.c (WANT_FAKE_CPUID): Likewise. * mpn/x86_64/bd1/mul_1.asm: Fix typo. 2013-05-07 Torbjorn Granlund * mpn/x86_64/fat/fat.c (fake_cpuid): Handle 0x80000001 request. (fake_cpuid_available): Remove unused function. * mpn/generic/mod_1_1.c: Cast constant udiv_rnnd_preinv arguments. * mpn/generic/mod_1_2.c: Likewise. * mpn/generic/mod_1_3.c: Likewise. * mpn/generic/mod_1_4.c: Likewise. * mpn/generic/divrem_2.c: Likewise. 2013-05-06 Torbjorn Granlund * config.guess (power*): Handle all ppc970 variants. 2013-05-03 David S. Miller * tune/common.c (speed_mpn_addlsh1_n, speed_mpn_sublsh1_n, speed_mpn_rsblsh1_n, speed_mpn_addlsh2_n, speed_mpn_sublsh2_n, speed_mpn_rsblsh2_n): Don't define if these routines are macros. * tune/speed.c (routine): Likewise don't table if they are macros. * mpn/sparc64/ultrasparct3/addmul_1.asm: Add T4 and T3 timings. * mpn/sparc64/ultrasparct3/aormul_4.asm: Likewise. * mpn/sparc64/ultrasparct3/aorslsh_n.asm: Likewise. * mpn/sparc64/ultrasparct3/cnd_aors_n.asm: Likewise. * mpn/sparc64/ultrasparct3/submul_1.asm: Likewise. 2013-05-03 Torbjorn Granlund * mpn/sparc64/ultrasparct3/aorslsh_n.asm: Invoke INITCY where it has effect. * gmp-impl.h: Amend last change. * tests/devel/try.c (choice_array): Don't try to table addlsh1_n etc if a macro. 2013-05-02 Torbjorn Granlund * mpn/arm/copyd.asm: Suppress dead pointer update. * mpn/arm/copyi.asm: Likewise. * mpn/arm/neon/logops_n.asm: Likewise. * mpn/arm/neon/tabselect.asm: Likewise. * mpn/arm/rshift.asm: Likewise. * mpn/arm/tabselect.asm: Likewise. * mpn/arm/v6/dive_1.asm: Likewise * mpn/arm/v7a/cora15/neon/copyi.asm: Likewise. * mpn/arm/v7a/cora15/neon/com.asm: New file. 2013-05-01 Torbjorn Granlund * mpn/sparc64/ultrasparct3/aormul_4.asm: New file. * configure.ac (GMP_MULFUNC_CHOICES): Support mul_3 + addmul_3 and mul_4 + addmul_4. * mpn/sparc64/ultrasparct3/aormul_2.asm: Optimise lead-in code. * mpn/sparc64/ultrasparct3/missing.m4 (addxccc): Allow g2 as input. (umulxhi): Save and restore o7 to allow it as in/out parameter. 2013-04-29 Torbjorn Granlund * mpn/arm/v7a/cora15/cnd_aors_n.asm: New file, was mis-named. * mpn/sparc64/ultrasparct3/addmul_1.asm: Rewrite. * mpn/sparc64/ultrasparct3/submul_1.asm: Rewrite. * mpn/sparc64/ultrasparct3/cnd_aors_n.asm: New file. * gmp-impl.h: Override mpn_addlsh1_n, mpn_addlsh2_n, mpn_sublsh1_n, etc with mpn_addlsh_n, etc when !HAVE_NATIVE the former but HAVE_NATIVE the latter. * mpn/sparc64/ultrasparct3/aorslsh_n.asm: New file. * configure.ac (sparc-*-*): Recognise t5 along with t3 and t4. Remove sparc64/ultrasparct1 from path_64 for T3, T3, and T5. 2013-04-27 Mike Frysinger * configure.ac (arm*-*-*): Set up path also for plainest CPU variants. 2013-04-27 Torbjorn Granlund * mpn/arm/v6/popham.asm: New file. * mpn/arm/v7a/cora15/cnd-aors_n.asm: New file. 2013-04-25 Torbjorn Granlund * mpn/arm/mod_34lsub1.asm: Clear carry smarter. * mpn/arm/v7a/cora15/logops_n.asm: Conditionally suppress conditionally used code. * mpn/arm/v7a/cora15/submul_1.asm: New file. 2013-04-24 Torbjorn Granlund * mpn/arm/v7a/cora15/com.asm: New file. * mpn/arm/v7a/cora15/logops_n.asm: New file. 2013-04-19 Torbjorn Granlund * mpn/arm/v7a/cora15/aors_n.asm: New file. * mpn/arm/v7a/cora15/addmul_1.asm: Rewrite. 2013-04-18 Torbjorn Granlund * mpn/alpha/tabselect.asm: New file. 2013-04-17 Torbjorn Granlund * mpn/powerpc32/tabselect.asm: New file. * longlong.h (arm64 count_trailing_zeros): New. * mpn/arm64/invert_limb.asm: New file. * mpn/generic/dive_1.c: Rewrite to use Hensel division also for size = 1. * mpn/generic/mod_1_1.c (add_mssaaaa): Provide VIS3 variant. * configure.ac: Remove "missing" from extra_functions_64 for coreibwl. * mpn/sparc64/ultrasparct3/mul_1.asm: Decrease loop alignment. * mpn/sparc64/ultrasparct3/aormul_2.asm: Likewise. 2013-04-16 Torbjorn Granlund * mpn/alpha/invert_limb.asm: Generate table. * mpn/powerpc64/mode64/invert_limb.asm: Likewise. * mpn/s390_64/invert_limb.asm: Likewise. * mpn/sparc64/ultrasparct3/invert_limb.asm: Likewise. * mpn/x86_64/invert_limb_table.asm: Likewise. 2013-04-15 David S. Miller * mpn/sparc32/sparc-defs.m4 (LEA64): New macro. * mpn/sparc64/gcd_1.asm: Use it. * mpn/sparc64/ultrasparct3/dive_1.asm: Likewise. * mpn/sparc64/ultrasparct3/invert_limb.asm: Likewise. * mpn/sparc64/ultrasparct3/mode1o.asm: Likewise. * mpn/sparc64/gcd_1.asm: Use RODATA, TYPE, and SIZE. 2013-04-15 Torbjorn Granlund * mpn/sparc64/ultrasparct3/invert_limb.asm: Avoid addend for GOT entry, it is not portable. * mpn/sparc64/tabselect.asm: New file. * mpn/x86/mmx/tabselect.asm: New file. * configure.ac (x86): Add x86/mmx to path for relevant CPUs. * mpn/sparc64/gcd_1.asm: Use rdpc for PIC. * mpn/sparc64/ultrasparct3/mode1o.asm: Use rdpc for PIC. * mpn/sparc64/ultrasparct3/dive_1.asm: Use rdpc for PIC. * mpn/sparc64/ultrasparct3/invert_limb.asm: Handle PIC, use rdpc. * Revert remaining parts of recent sparc LEA changes. 2013-04-14 David S. Miller * mpn/sparc32/v9/sqr_diagonal.asm: Revert LEA and INT32 changes. * mpn/sparc64/gcd_1.asm: Likewise. 2013-04-13 Torbjorn Granlund * mpn/x86_64/bd1/tabselect.asm: New file. * mpn/x86_64/coreisbr/tabselect.asm: New file. * mpn/x86_64/k10/tabselect.asm: New file. * mpn/x86_64/coreinhm/tabselect.asm: New file. * mpn/x86_64/core2/tabselect.asm: New file. * mpn/x86_64/pentium4/tabselect.asm: New file. * mpn/x86_64/fastsse/tabselect.asm: New file. * mpn/arm/neon/tabselect.asm: Rewrite. * mpn/arm/tabselect.asm: Rewrite. * mpn/powerpc64/tabselect.asm: Rewrite. * mpn/x86_64/tabselect.asm: Rewrite. * tune/speed.h (SPEED_ROUTINE_MPN_TABSELECT): Implement special code, making .r argument be table width. 2013-04-11 David S. Miller * mpn/sparc32/sparc-defs.m4 (LEA): Remove unused local label. (LEA_LEAF): Likewise. 2013-04-11 Niels Möller * mpn/arm/v6/submul_1.asm: New file, using the corresponding addmul_1 loop + complement trick. 2013-04-10 David S. Miller * acinclude.m4 (GMP_ASM_SPARC_GOTDATA, GMP_ASM_SPARC_SHARED_THUNKS): New feature tests. * configure.ac: Call GMP_ASM_SPARC_GOTDATA and GMP_ASM_SPARC_SHARED_THUNKS on sparc. * mpn/sparc32/sparc-defs.m4 (LEA, LEA_LEAF, LEA_THUNK): New macros. * mpn/sparc32/udiv.asm: Convert over to LEA, LEA_LEAF, and LEA_THUNK. * mpn/sparc32/v8/addmul_1.asm: Likewise. * mpn/sparc32/v8/mul_1.asm: Likewise. * mpn/sparc32/v8/supersparc/udiv.asm: Likewise. * mpn/sparc32/v8/udiv.asm: Likewise. * mpn/sparc64/gcd_1.asm: Likewise. * mpn/sparc64/ultrasparct3/dive_1.asm: Likewise. * mpn/sparc64/ultrasparct3/invert_limb.asm: Likewise. * mpn/sparc64/ultrasparct3/mode1o.asm: Likewise. * mpn/sparc32/v9/sqr_diagonal.asm: Likewise and use INT32. 2013-04-09 Torbjorn Granlund * longlong.h (sparc64): Test __VIS__ instead of __sparc_vis3. * config.guess (sparc*): Invoke set_cc_for_build to get $dummy. 2013-04-08 Torbjorn Granlund * config.guess: Rework tmp file names, make sure to remove tmp files. * mpn/arm/dive_1.asm: Rewrite count-trailing-zeros code, using private table. * mpn/arm: Canonicalise arm assembly to use old style "mov ... lsl" for shift ops. 2013-04-07 Torbjorn Granlund * mpn/sparc64/ultrasparct3/mod_34lsub1.asm: New file. * longlong.h (sparc64): Define umul_ppmm, add_ssaaaa, and count_leading_zeros conditionally under the symbol __sparc_vis3. * mpn/arm/dive_1.asm: New file. * mpn/arm/v6/dive_1.asm: New file. * mpn/arm/v6t2/mode1o.asm: Make trivial change to avoid v6t2... * mpn/arm/v6/mode1o.asm: ...instruction, move file accordingly. * mpn/powerpc64/mode64/invert_limb.asm: Put all multiplies low-limb first. 2013-04-04 David S. Miller * mpn/sparc64/ultrasparct3/add_n.asm: Rewrite. * mpn/sparc64/ultrasparct3/sub_n.asm: Rewrite. * mpn/sparc64/ultrasparct3/invert_limb.asm: Align table. 2013-04-04 Torbjorn Granlund * mpn/sparc32/sparc-defs.m4: Provide dummy lzcnt. * tests/mpn/logic.c: Seed using RANDS, then use mpz_rrandomb. * tests/mpn/t-div.c (random_word): Remove. Let callers invoke urandom. * mpn/sparc64/ultrasparct3/mul_1.asm: Rewrite. * mpn/sparc64/ultrasparct3/bdiv_dbm1c.asm: New file. * mpn/sparc64/ultrasparct3/dive_1.asm: New file. * mpn/sparc64/ultrasparct3/invert_limb.asm: New file. * mpn/sparc64/ultrasparct3/mod_1_4.asm: New file. * mpn/sparc64/ultrasparct3/mode1o.asm: New file. 2013-04-03 Torbjorn Granlund * mpn/sparc64/ultrasparct3/aormul_2.asm: Reschedule for better speed. 2013-04-02 Torbjorn Granlund * mpn/sparc64/ultrasparct3/missing.m4: Misc tweaks. (lzcnt): New. * mpn/sparc64/ultrasparct3/missing.asm (__gmpn_lzcnt): New function. * mpn/sparc32/sparc-defs.m4: Put FAKE_T3 stuff here... * mpn/sparc64/ultrasparct3/aormul_2.asm: ...moved from here. * mpn/sparc64/ultrasparc1234/lshift.asm: Remove. * mpn/sparc64/ultrasparc1234/rshift.asm: Remove. 2013-04-01 Torbjorn Granlund * mpn/sparc64/ultrasparct3/missing.m4 (umulxhi): Don't clobber retaddr, allowing use in functions that does not do save/restore. * mpn/sparc64/gcd_1.asm: Tweak for tighter loop. 2013-03-31 David S. Miller * mpn/sparc64/lshift.asm: New file. * mpn/sparc64/rshift.asm: New file. * mpn/sparc64/lshiftc.asm: New file. 2013-03-31 Torbjorn Granlund * mpn/sparc64/ultrasparct1/lshift.asm: Remove. * mpn/sparc64/ultrasparct1/rshift.asm: Remove. * mpn/sparc64/ultrasparct1/lshiftc.asm: Remove. 2013-03-29 Torbjorn Granlund * mpn/sparc64/ultrasparct3/aormul_2.asm: Always do mulx before umulxhi. 2013-03-28 Torbjorn Granlund * mpn/sparc64/mod_1_4.c (mpn_mod_1s_4p): Make precomputed arg 'const'. (mpn_mod_1s_4p_cps): Update from generic code. 2013-03-27 Torbjorn Granlund * mpn/generic/trialdiv.c: Make variables 'const' to match tables. * mpn/generic/mod_1_1.c (mpn_mod_1_1p): Make precomputed arg 'const'. * mpn/generic/mod_1_2.c (mpn_mod_1s_2p): Likewise. * mpn/generic/mod_1_3.c (mpn_mod_1s_3p): Likewise. * mpn/generic/mod_1_4.c (mpn_mod_1s_4p): Likewise. * gmp-impl.h: Update prototypes. * mpn/x86_64/mulx/aorsmul_1.asm: New file. * mpn/x86_64/mulx/addmul_1.asm: Remove. 2013-03-26 Niels Möller Make mpn_cnd_add_n and mpn_cnd_sub_n public. * doc/gmp.texi (Low-level Functions): Document mpn_cnd_add_n and mpn_cnd_sub_n. * gmp-h.in (mpn_cnd_add_n, mpn_cnd_sub_n): Moved prototypes here... * gmp-impl.h: ... from here. 2013-03-26 Torbjorn Granlund * mpn/x86/pentium4/sse2/cnd_add_n.asm: New file. * mpn/x86/pentium4/sse2/cnd_sub_n.asm: New file. * mpn/x86/cnd_aors_n.asm: New file. 2013-03-25 David S. Miller * mpn/sparc64/ultrasparct3/hamdist.asm: New file. * mpn/sparc64/ultrasparct3/popcount.asm: New file. 2013-03-25 Torbjorn Granlund * mpn/ia64/aorsorrlshC_n.asm: Generalised from aorslshC_n.asm. * mpn/ia64/aorsorrlsh1_n.asm: Generalised from aorslsh1_n.asm. * mpn/ia64/aorsorrlsh2_n.asm: Generalised from aorslsh2_n.asm. 2013-03-24 Torbjorn Granlund * mpn/arm/v7a/cora15/neon/aorsorrlshC_n.asm: New file. * mpn/arm/v7a/cora15/neon/aorsorrlsh2_n.asm: New file. * mpn/arm/v7a/cora15/neon/aorsorrlsh1_n.asm: New file. * mpn/arm/v7a/cora15/neon/rsh1aors_n.asm: New file. * configure.ac (GMP_MULFUNC_CHOICES): Support add+sub+rsb lsh files. * tests/refmpn.c (refmpn_addlsh_nc, refmpn_sublsh_nc): Remove silly assert of mp_limb being non-negative. 2013-03-21 Torbjorn Granlund * mpn/arm/neon/lshiftc.asm: New file. * mpn/arm/v6/sqr_basecase.asm: Trim 'sqr_diag_addlsh1' loop. * gen-trialdivtab.c: Output just raw data, remove actual variables. * mpn/generic/trialdiv.c: Put variables from gen-trialdivtab.c here, and make them 'const'. 2013-03-20 Torbjorn Granlund * config.guess: Rework arm CPU recognition. * config.sub: Corresponding updates. * configure.ac: Likewise. * mpn/x86_64/mulx/adx/addmul_1.asm: Let FAKE_MULXADX be off by default. * mpn/arm/v7a/cora15/neon/copyi.asm: Move from "..". * mpn/arm/v7a/cora15/neon/copyd.asm: Likewise. * config.guess: Tack on "neon" for appropriate arm CPUs. * configure.ac (arm*-*-*): Recognise neon suffix for a8, a9, and a15. 2013-03-19 Marco Bodrato * mpf/fits_u.h: Accept numbers truncating to zero before checking the sign. * tests/mpf/t-fits.c: Check new edges. 2013-03-19 Torbjorn Granlund * tests/arm32check.c: Get printing of clobbered register right. * mpn/arm/neon/popcount.asm: New file. * mpn/arm/neon/hamdist.asm: New file. * tests/Makefile.am (EXTRA_libtests_la_SOURCES): Add arm32call.asm and arm32check.c. 2013-03-18 Torbjorn Granlund * configure.ac (arm*-*-*): Define CALLING_CONVENTIONS_OBJS. * tests/arm32call.asm: New file. * tests/arm32check.c: New file. * mpn/arm/arm-defs.m4 (LEA): Rewrite to properly handle repeated use. (EPILOGUE_cpu): Define. * mpn/arm/v6/addmul_3.asm: Make code work for PIC. * tests/x86call.asm: Modernise asm syntax. * tests/amd64call.asm: Likewise. * mpn/x86/darwin.m4 (m4append): Move definition from here... * mpn/asm-defs.m4: ...to here. 2013-03-18 Marco Bodrato * doc/gmp.texi (--enable-fat): No quote in concept index. * mpf/swap.c: Reduce the number of variables. 2012-03-17 Marc Glisse * tests/cxx/t-do-exceptions-work-at-all-with-this-compiler.cc: New file. * tests/cxx/Makefile.am: Add new file. Reorder the tests. 2013-03-17 Torbjorn Granlund * mpn/generic/mul_fft.c: Use TMP_BALLOC*, but combine several areas. * mpz/powm_ui.c (mod): Use TMP_BALLOC in mu code. * mpn/arm/v6/addmul_3.asm: New file. * mpn/arm/v7a/cora15/copyd.asm: Tweak. * mpn/arm64/copyi.asm: New file. * mpn/arm64/copyd.asm: New file. 2013-03-16 Torbjorn Granlund * mpn/arm/v6/addmul_2.asm: Tweak for better A9 performance. 2013-03-14 Torbjorn Granlund * mpn/ia64/cnd_aors_n.asm: New file. * mpn/arm64/cnd_aors_n.asm: New file. * mpn/arm64/aors_n.asm (ADDSUB): Remove unused definition. * mpn/ia64/aors_n.asm: Remove a redundant ASM_START. * mpn/arm/cnd_aors_n.asm: Avoid ARM conditional insn execution. * mpn/x86_64/missing.asm: Move from mulx/adx since we cannot currently prune missing.asm from path. * mpn/x86_64/mulx/adx/missing-call.m4: Likewise. * mpn/x86_64/mulx/adx/missing-inline.m4: Likewise. * mpn/x86_64/mulx/adx/addmul_1.asm: Update hardwired path. 2013-03-13 Marco Bodrato * mpz/cong_2exp.c: Write loops in a cleaner way. * mini-gmp/mini-gmp.c: Likewise. * gmp-impl.h (mpz_zero_p): Likewise. 2013-03-12 Niels Möller New names mpn_cnd_add_n and mpn_cnd_sub_n. * mpn/generic/cnd_add_n.c (mpn_cnd_add_n): Renamed file and function, from addcnd.c:mpn_addcnd_n. * mpn/generic/cnd_sub_n.c (mpn_cnd_sub_n): Renamed, from subcnd.c:mpn_subcnd_n. * mpn/arm/cnd_aors_n.asm: Renamed file, from aorscnd.asm, and renamed functions. * mpn/x86_64/cnd_aors_n.asm: Analogous renaming. * mpn/powerpc64/mode64/cnd_aors_n.asm: Analogous renaming. * gmp-impl.h (mpn_cnd_add_n, mpn_cnd_add_n): Updated prototypes with new names. * configure.ac: Updated for new names. * tests/refmpn.c (refmpn_cnd_add_n): Renamed, from refmpn_addcnd_n. (refmpn_cnd_sub_n): Renamed, from refmpn_subcnd_n. * tests/tests.h (refmpn_cnd_add_n, refmpn_cnd_sub_n): Updated prototypes with new names. * tune/common.c (speed_mpn_cnd_add_n): Renamed, from speed_mpn_addcnd_n, call mpn_cnd_add_n. (speed_mpn_cnd_sub_n): Renamed, from speed_mpn_subcnd_n, call mpn_cnd_sub_n. * tune/speed.h (speed_mpn_cnd_add_n, speed_mpn_cnd_sub_n): Updated prototypes with new names. * tune/speed.c (routine): Updated list with new names. * tests/devel/try.c: Updated for new mpn_cnd_* names. * mpn/generic/sbpi1_div_sec.c: Likewise. * mpn/generic/powm_sec.c: Likewise. 2013-03-12 Torbjorn Granlund * configure.ac: Add "missing" to extra_functions_64 for coreibwl. * mpn/x86_64/mulx/adx/addmul_1.asm: Simplify. Make FAKE_MULXADX the default awaiting proper qemu behaviour. 2013-03-11 Torbjorn Granlund * mpn/x86_64/aorscnd_n.asm: Read 32 bits for 'n' arguments on DOS64. * tests/mpz/t-powm_ui.c: Test larger arguments. General cleanup. * mpz/powm_ui.c (mod): Adhere to mpn_mu_div_qr's overlap requirements. 2013-03-10 Niels Möller * mpn/generic/sbpi1_div_sec.c: Update calls of mpn_addcnd_n and mpn_subcnd_n. * mpn/generic/powm_sec.c (MPN_REDC_1_SEC, MPN_REDC_2_SEC) (mpn_powm_sec): Update calls of mpn_subcnd_n. * tests/tests.h (refmpn_addcnd_n, refmpn_subcnd_n): Update declarations. * tests/refmpn.c (refmpn_addcnd_n, refmpn_subcnd_n): Similar reorder of arguments. * tests/devel/try.c (call): Pass condition first, for TYPE_ADDCND_N and TYPE_SUBCND_N. * tune/common.c (speed_mpn_addcnd_n, speed_mpn_subcnd_n): Update to pass condition as first argument. * gmp-impl.h (mpn_addcnd_n, mpn_subcnd_n): Updated declarations. * mpn/generic/addcnd_n.c (mpn_addcnd_n): Reordered arguments, make condition the first argument. * mpn/generic/subcnd_n.c (mpn_subcnd_n): Likewise. * mpn/arm/aorscnd_n.asm: Likewise. * mpn/x86_64/aorscnd_n.asm: Likewise. * mpn/powerpc64/mode64/aorscnd_n.asm: Likewise. 2013-03-10 Torbjorn Granlund * mpn/x86_64/mulx/adx/missing.asm: Simulate some mulx/adx insns. * mpn/x86_64/mulx/adx/missing-call.m4: Call variant. * mpn/x86_64/mulx/adx/missing-inline.m4: Inline variant. * mpn/sparc64/ultrasparct3/missing.asm: Simulate some v9-2011 insns. * mpn/sparc64/ultrasparct3/missing.m4: Inline or invoke missing.asm for v9-2011 insn. * configure.ac: Strip `haswell' from paths for now. * mpn/x86_64/mulx/addmul_1.asm: New. * mpn/x86_64/mulx/mul_1.asm: Rewrite file from `haswell' subdir. * mpn/x86_64/mulx/adx/addmul_1.asm: Likewise. * mpn/x86_64/haswell: Remove. * mpn/arm/v7a/cora15/mul_1.asm: New file. * mpn/arm/v7a/cora15/addmul_1.asm: New file. 2013-03-09 Marco Bodrato * tests/mpz/t-cong_2exp.c: Improve coverage. 2013-03-09 Torbjorn Granlund * mpn/sparc64/ultrasparc1234/add_n.asm: Use g5 instead of g4. * mpn/sparc64/ultrasparc1234/sub_n.asm: Likewise. * mpn/sparc64/ultrasparct3/aormul_2.asm: Fix a typo. 2013-03-07 Torbjorn Granlund * mpn/arm/v7a/cora9/gmp-mparam.h: New file. * configure.ac (GMP_MULFUNC_CHOICES): Support mul_2 + addmul_2. * mpn/sparc64/ultrasparct3/aormul_2.asm: New file. * mpn/sparc64/ultrasparct3/submul_1.asm: Optimise out two carry propagating adds. 2013-03-06 David Miller * config.guess: Recognize UltraSparc T4 under Linux. * configure.ac: Add sparc64/ultrasparct3 to path_64 when T3 or T4. Append -xarch=v8plusd or -xarch=v9d to command line, as needed. * mpn/sparc64/ultrasparct3/mul_1.asm: New file. * mpn/sparc64/ultrasparct3/addmul_1.asm: New file. * mpn/sparc64/ultrasparct3/submul_1.asm: New file. * mpn/sparc64/ultrasparct3/add_n.asm: New file. * mpn/sparc64/ultrasparct3/sub_n.asm: New file. * mpn/sparc32/ultrasparct1/mul_1.asm: Unroll main loop one time, add T2/T3/T4 timings. * mpn/sparc32/ultrasparct1/addmul_1.asm: Likewise. * mpn/sparc32/ultrasparct1/submul_1.asm: Likewise. 2013-03-04 Torbjorn Granlund * mpn/arm/neon/lorrshift.asm: New file. 2013-03-03 Torbjorn Granlund * mpn/arm/v7a/cora15/copyd.asm: New file. * mpn/arm/v7a/cora15/copyi.asm: New file. * mpn/arm64/logops_n.asm: New file. * mpn/arm64/gcd_1.asm: New file. * mpn/arm64/aorsmul_1.asm: New file. * mpn/arm64/addmul_1.asm: Remove. * mpn/arm64/aors_n.asm: Complete rewrite. * mpn/arm/tabselect.asm: New file. * mpn/arm/neon/tabselect.asm: New file. * mpn/arm/copyi.asm: Software pipeline. * mpn/arm/copyd.asm: Likewise. * config.guess: Rework tmp file handling to resemble configfsf.guess's. 2013-03-03 Niels Möller * doc/gmp.texi (Integer Special Functions): Document mpz_limbs_read, mpz_limbs_write, mpz_limbs_modify, mpz_limbs_finish, mpz_roinit_n and MPZ_ROINIT_N. * mpz/roinit_n.c (mpz_roinit_n): Normalize the input. 2013-02-27 Niels Möller * tune/common.c (speed_measure): Increase repetition count if we get a zero measurement. 2013-02-27 Marco Bodrato * mini-gmp/mini-gmp.c (mpz_div_q_2exp): Adjust only if needed. (mpn_common_scan): New service function to unify scan loops. (mpz_scan0, mpz_scan1): Simplify by using mpn_common_scan. (mpz_make_odd): Simplify, assume in-place operation on positive. (mpn_scan0, mpn_scan1): New functions. * mini-gmp/mini-gmp.h (mpn_scan0, mpn_scan1): New declarations. * mini-gmp/tests/t-scan.c: Test also mpn_scan0 and mpn_scan1. 2013-02-26 Niels Möller * tests/mpz/t-limbs.c (check_roinit): Test MPZ_ROINIT_N only if compiler supports c99. 2013-02-25 Niels Möller * mini-gmp/tests/t-double.c (testmain): Declare double variables as volatile, to drop extended precision. * mini-gmp/tests/testutils.c (testfree): New function. Use it everywhere where test programs deallocate storage allocated via the mini-gmp allocation functions, including uses of mpz_get_str for various test failure messages. * mpz/limbs_finish.c (mpz_limbs_finish): New file and function. * mpz/limbs_modify.c (mpz_limbs_modify): New file and function. * mpz/limbs_read.c (mpz_limbs_read): New file and function. * mpz/limbs_write.c (mpz_limbs_write): New file and function. * mpz/roinit_n.c (mpz_roinit_n): New file and function. * gmp-h.in: Declare new functions. (MPZ_ROINIT_N): New macro. * mpz/Makefile.am (libmpz_la_SOURCES): Added new files. * Makefile.am (MPZ_OBJECTS): Added new object files. * tests/mpz/t-limbs.c: New testcase. * tests/mpz/Makefile.am (check_PROGRAMS): Added t-limbs. 2013-02-22 Torbjorn Granlund * configure.ac: Fix typo in adx/mulx path stripping code. * config.sub: Match coreibwl. 2013-02-20 Niels Möller * tests/mpq/t-get_d.c (check_random): Rewrote to make test less dependent on float operations. Fixes problem with m68k-linux and extended float precision. 2013-02-20 Torbjorn Granlund * mpn/x86_64/haswell/mulx/adx/addmul_1.asm: New file. * configure.ac: Support coreibwl. Use proper name for ADX extension. * acinclude.m4 (GMP_ASM_X86_ADX): Rename from GMP_ASM_X86_ADOX. * tests/tests.h (TESTS_REPS): Keep count >= 1. 2013-02-19 Marco Bodrato * mini-gmp/mini-gmp.c: Move asserts to work-around a compiler bug. (mpz_export): Reorder branches. (mpz_mul_ui): Avoid temporary allocation (mpn_mul_1 can work in-place). * mini-gmp/tests/t-reuse.c: Fix typo causing the same negation condition to be applied to all operands. (See 2013-02-03, Torbjorn) 2013-02-17 Marco Bodrato * gmpxx.h (mpq_class, mpf_class) [init_ui, init_si, assign_si]: Optimise _si using _ui for positive arguments. (__gmp_hypot_function): Use _mul_ui to square an ui, abs for si. * mini-gmp/mini-gmp.c (mpz_mul): Read sizes just once. (mpn_set_str_other): Remove a redundant variable. (mpz_abs_add): Use SWAP once, to order sizes. (mpz_mul_ui): Micro-optimisation. (mpz_rootrem): Use _init2 before _setbit. (mpz_set_str): Optimise-out a variable. (mpz_import): Normalise only if needed. (mpn_div_qr_1): Speed-up the d=1 case, delaying a branch. * rand/randmts.c: Use init2, as size of variables is known in advance. (mangle_seed): Get a single argument. * mpz/remove.c: Delay allocation in the generic case; use swap instead of set. * mpn/generic/remove.c: Delay (possibly smaller) allocation. 2013-02-17 Marc Glisse * cxx/osdoprnti.cc: Use and rather than and (revert 2002-12-21). * tests/cxx/Makefile.am: Link with libm. * tests/cxx/t-ops2.cc: Comment about more tests. Use rather than and using namespace. Don't include . * gmpxx.h (__GMPXX_BITS_TO_LIMBS, __GMPQ_NUM_DBL_LIMBS, __GMPQ_DEN_DBL_LIMBS, __GMPXX_TMPQ_D): New macros. (__gmp_binary_plus, __gmp_binary_minus, __gmp_binary_multiplies, __gmp_binary_divides, __gmp_binary_equal, __gmp_binary_less, __gmp_cmp_function): Use __GMPXX_TMPQ_D. * tests/cxx/t-ops2.cc: Test __GMPXX_TMPQ_D on DBL_MIN, DBL_MAX. * gmpxx.h (__gmp_binary_multiplies, __gmp_binary_divides): Use __GMPXX_CONSTANT_TRUE. 2013-02-16 Marc Glisse * gmpxx.h: Include . 2013-02-16 Torbjorn Granlund * mpn/Makefile.am (TARG_DIST): Add arm64. * mpn/x86_64/x86_64-defs.m4 (PROTECT): Emit '.hidden' instead of '.protected" to please Sun's assembler, but also for semantic reasons. 2013-02-15 Torbjorn Granlund * configure.ac (arm64*-*-*): Match this. * mpn/arm64/aors_n.asm: New file. * mpn/arm64/addmul_1.asm: New file. * mpn/arm64/mul_1.asm: New file. 2013-02-15 Marc Glisse * gmpxx.h (__GMPXX_DEFINE_ARITHMETIC_CONSTRUCTORS, __GMPXX_DEFINE_ARITHMETIC_ASSIGNMENTS): New macros. (mpz_class, mpq_class, mpf_class) [init_ui, init_si, init_d, assign_ui, assign_si, assign_d]: New functions. (__gmp_expr::__gmp_expr, __gmp_expr::operator=): Replace with macros. (__GMPXX_CONSTANT_TRUE): New macro. 2013-02-15 Marco Bodrato * gmp-impl.h (NEG_CAST, ABS_CAST): Use __GMP_CAST. * mpz/fits_s.h: Use NEG_CAST. 2013-02-14 Marc Glisse * gmpxx.h (__gmp_binary_greater): Forward to __gmp_binary_less. (__gmp_binary_equal): Forward to itself after swapping operands. 2013-02-14 Marco Bodrato * mp_dv_tab.c (__gmp_digit_value_tab): Remove a line of unused values. * mpf/set_str.c: Update offset accordingly. * mpz/inp_str.c: Likewise. * mpz/set_str.c: Likewise. * gmp-h.in (mpq_cmp_ui): Optimise comparison with 1/1. * tests/mpq/t-cmp_ui.c: Test special comparisons: 0/1, 1/1. * mpz/clrbit.c: Reorganise branches. * mpz/setbit.c: Likewise. * mpz/combit.c: Same micro-optimisations as in set/clr. * mpz/aors_ui.h: No realloc if size was zero. * mpz/ior.c: Use macros: MPZ_REALLOC and MPN_INCR_U. * gmp-impl.h (NEG_CAST): New macro, used by ABS_CAST. * mpq/cmp_si.c: Use NEG_CAST. * mpz/cmp_si.c: Reorganise branches. 2013-02-13 Torbjorn Granlund * acinclude.m4 (GMP_ASM_X86_MULX, GMP_ASM_X86_ADOX): New feature tests. * configure.ac: Use new feature tests. * mpn/x86_64/haswell/mulx/mul_1.asm: File moved to cope with older assemblers. * configure.ac: Update haswell path to include "mulx". 2013-02-12 Torbjorn Granlund * configure.ac: Recognise haswell. * config.guess: Recognise haswell. * config.sub: Match haswell. * mpn/x86_64/haswell/mul_1.asm: New file, mainly for testing HNI. 2013-02-12 Marco Bodrato * gmp-impl.h (MPZ_PROVOKE_REALLOC): Remove unused macro. * gen-fac.c (gen_consts): Remove obsolete code, use swap instead of set. * mini-gmp/mini-gmp.c (fac_ui, bin_uiui): Use shorter and faster code. * mpn/generic/mulmod_bnm1.c: Reorganise branches. * mini-gmp/mini-gmp.c: Reduce branches. * mpz/bin_ui.c: Avoid a copy when n < 0. * mpz/mfac_uiui.c: Reduce memory usage. * mpz/primorial_ui.c: Use MPZ_NEWALLOC. * mpz/import.c: Use BITS_TO_LIMBS and MPZ_NEWALLOC. * mpz/inp_raw.c: Likewise. * mpz/rrandomb.c: Likewise. * mpz/urandomb.c: Likewise. * mpn/generic/random2.c: Likewise. * mpn/generic/brootinv.c: Micro-optimisation. * mpf/set_str.c: Don't chech base==0 when base is strictly positive. 2013-02-10 Torbjorn Granlund * Version 5.1.1 released. 2013-02-07 Marco Bodrato * tune/speed.h (SPEED_ROUTINE_MPN_MUL): Use operands from struct s. * tune/README: Document new parameter syntax mpn_mul.<#> . 2013-02-06 Niels Möller * tests/mpz/t-jac.c (check_large_quotients): Rewrote. Now uses a more efficient method for generating the test inputs. 2013-02-05 Torbjorn Granlund * tests/mpn/t-div.c: Limit random dbits to avoid an infinite loop. 2013-02-03 Torbjorn Granlund * tests/mpz/reuse.c: Fix typo causing the same negation condition to be applied to all operands. Fix condition for when to invoke mpz_remove. Make different-size random operands. 2013-02-02 Marco Bodrato * mpz/remove.c: Correct the sign in case of reuse. 2013-02-01 Torbjorn Granlund * gmp-impl.h (DIGITS_IN_BASE_PER_LIMB): Add a cast. (LIMBS_PER_DIGIT_IN_BASE): Likewise. * tests/refmpn.c (refmpn_mul): Use toom6h instead of toom44 for the largest operands. 2013-01-31 Torbjorn Granlund * mpn/generic/toom44_mul.c: Revert last change in favour of a simple change (thanks Marco!). * mpn/generic/toom4_sqr.c: Likewise. 2013-01-30 Torbjorn Granlund * mpn/generic/toom44_mul.c (MAYBE_mul_toom44): Take toom6h and toom8h into account, using new macro MUL_NEXTALG_THRESHOLD. * mpn/generic/toom4_sqr.c (MAYBE_sqr_toom4): Likewise. 2013-01-26 Marco Bodrato * mpz/remove.c: init+set=init_set, cast before shifting. * mpz/cmp_si.c: Use ABS_CAST. 2013-01-26 Torbjorn Granlund * tests/mpn/logic.c: Set things up to always test library logops, not gmp-impl.h's inlined variants. Test also mpn_com. * tests/mpn/t-mod_1.c: Test also mpn_mod_1s_3p. * mpn/generic/mod_1_3.c: Swap some lines to make it similar to mod_4.c. * tests/mpz/reuse.c: Fix typo in last change. 2013-01-23 Marco Bodrato * mini-gmp/mini-gmp.c (mpz_cmpabs_d, mpz_cmp_d): Simplify. (mpz_set_str): Behaviour more adherent to the real GMP. * mini-gmp/tests/t-str.c: Cast size_t to unsigned long, for printf. * mini-gmp/tests/t-import.c: Likewise. * mini-gmp/tests/t-comb.c: Remove an unused var. * mini-gmp/tests/t-div.c: Remove unused args passed to fprintf. * mini-gmp/tests/t-double.c: Use float immediates with float vars. 2013-01-22 Torbjorn Granlund * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*): Bump version info. * gmp-h.in: Bump version. * tests/mpz/reuse.c: Delete always zero 'failures' and code depending on it. Replace rotating progress with real measure. * Makefile.am (check-mini-gmp): Fix typo in last change. 2013-01-22 Niels Möller * mini-gmp/mini-gmp.c (mpz_cmp_d): Simplified, just sort out signs, then call mpz_cmpabs_d. * mini-gmp/tests/testutils.h: Include stdio.h and stdlib.h. (numberof): New define. * mini-gmp/tests/t-cmp_d.c: New file, copied from tests/mpz/t-cmp_d.c with minor changes. * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Added t-cmp_d, * mini-gmp/mini-gmp.c (mpz_cmpabs_d): New function. * mini-gmp/mini-gmp.h: Declare it. 2013-01-21 Niels Möller * mini-gmp/tests/t-str.c (testmain): Test mpz_out_str, using the tmpfile function for i/o. 2013-01-20 Torbjorn Granlund * Makefile.am (check-mini-gmp): Set also DYLD_LIBRARY_PATH for the benefit of Darwin. * tests/mpn/t-div.c: Test mpn_sb_div_qr_sec and mpn_sb_div_r_sec. (main): Separate divisor into normalised (dnp) and unnormalised (dup), pass appropriate variant to each function. (main): Make negative `test' index value mean divisor bits, for better small operands coverage. (main): Put random junk at qp[] instead of zeroing. * tests/mpz/t-remove.c: Back out last change which left `divisor_size' uninitialised; achieve change's aim with a parameter tweak. 2013-01-20 Marco Bodrato * mini-gmp/tests/testutils.c (testhalves): New function, test default memory functions. * mini-gmp/tests/testutils.h (testhalves): Declare it * mini-gmp/tests/t-logops.c: Use testhalves. * mini-gmp/mini-gmp.c (mpz_init_set_str): New function. * mini-gmp/mini-gmp.h (mpz_init_set_str): Declare it. * mini-gmp/tests/t-str.c: Test mpz_init_set_str. 2013-01-20 Torbjorn Granlund * tests/memory.c (PTRLIMB): New macro, used for conformant casting. 2013-01-19 Marco Bodrato * mini-gmp/tests/t-double.c (testmain): Get the current free function using mp_get_memory_functions. * mini-gmp/tests/t-str.c (testmain): Likewise. * mini-gmp/tests/testutils.h (tu_free): Remove declaration. * mini-gmp/tests/testutils.c (block_check, tu_free): Mark static. * tests/mpz/t-set_str.c: Check also failing conditions. * tests/mpz/t-remove.c: Test removal of 1. 2013-01-18 Niels Möller * mini-gmp/tests/t-str.c (test_small): New function, exercising parsing of whitespace and base prefixes. (testmain): Call it. * mini-gmp/tests/t-gcd.c (gcdext_valid_p): Fixed memory leak. * mini-gmp/tests/t-double.c (testmain): Call tu_free rather than free, for storage allocated by mpz_get_str. * mini-gmp/tests/t-str.c (testmain): Likewise. * mini-gmp/tests/testutils.c (block_init, block_check): New functions. (tu_alloc, tu_realloc, tu_free): New functions. (main): Use mp_set_memory_functions. * mini-gmp/tests/testutils.h (tu_free): Declare. * mini-gmp/tests/testutils.h: New file, declarations for test programs. * mini-gmp/tests/testutils.c (main): New file, with shared main function for all the test programs. Also includes mini-gmp.c. Calls testmain after initialization. All other test programs updated to define testmain rather than main. 2013-01-18 Marco Bodrato * mini-gmp/tests/t-signed.c: Slightly larger coverage. * mini-gmp/tests/t-double.c: Test also mpz_init_set_d. 2013-01-18 Torbjorn Granlund * mpn/generic/set_str.c (normalization_steps): Eliminate set-but-unused variable. * mini-gmp/tests/t-div.c: Test mpz_divisible_p and mpz_divisible_ui_p. * tests/tests.h (TESTS_REPS): Fix printf argument type clashes. * mini-gmp/tests/t-div.c: Test also mpz_mod, mpz_mod_ui. Compare mpz_divisible_p just to ceil, to save time. * mini-gmp/mini-gmp.c: Prefix some names with GMP_. 2013-01-16 Marco Bodrato * mini-gmp/tests/t-double.c: Test mpz_cmp_d. * mini-gmp/mini-gmp.c (mpz_cmp_d): Correct multiword comparison. * mini-gmp/mini-gmp.c (mpz_set_str): Handle the empty string. * mini-gmp/tests/t-str.c: Test base <= 0. 2013-01-15 Niels Möller * mini-gmp/tests/t-str.c (main): Use x->_mp_d rather than x[0]._mp_d. * mini-gmp/tests/t-invert.c (main): Likewise. * mini-gmp/tests/t-mul.c (main): Test mpn_mul_n and mpn_sqr. * mini-gmp/tests/hex-random.h (enum hex_random_op): New value OP_SQR. * mini-gmp/tests/mini-random.c (mini_random_op3): Renamed, from... (mini_random_op): ... old name. Updated callers. (mini_random_op2): New function. * mini-gmp/tests/hex-random.c (hex_random_op3): Renamed, from... (hex_random_op): ... old name. Updated callers. (hex_random_op2): New function. 2013-01-15 Marco Bodrato * mini-gmp/tests/t-logops.c: Improve popcount/hamdist testing. * mini-gmp/tests/t-signed.c: Test more cases. 2013-01-15 Torbjorn Granlund From Mike Frysinger: * configure.ac: Add x32 ABI for x86_64. 2013-01-14 Niels Möller * mini-gmp/tests/t-str.c (main): Added tests for mpn_get_str and mpn_set_str. 2013-01-14 Marco Bodrato * doc/gmp.texi (gmp_version): Remove "was used" repetition. (Upward compatibility): Mention mpn_bdivmod, GMP 4 -> GMP 5. 2013-01-13 Marc Glisse * doc/gmp.texi: Let mpn_sqrtrem reference mpn_perfect_square_p instead of mpz_perfect_square_p. 2013-01-11 Marco Bodrato * mini-gmp/tests/t-comb.c: New test program, testing both mpz_fac_ui and mpz_bin_uiui. * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Added t-comb. * mini-gmp/mini-gmp.c (mpz_mul_si): Simplify. (mpz_mul_ui, mpz_mul, mpz_div_qr): Replace init+REALLOC with init2. * mini-gmp/mini-gmp.c (NEG_CAST): New macro. (mpz_mul_si, mpz_set_si, mpz_cmp_si): Use NEG_CAST. * mini-gmp/mini-gmp.c (mpz_set_si, mpz_cmp_si): Simplify by using the _ui variant. * mini-gmp/tests/t-root.c: Use mpz_ui_pow_ui, when base fits an ui. * mini-gmp/tests/t-mul.c: Test also mpz_mul_si. * mini-gmp/tests/t-sub.c: Test also mpz_ui_sub. * mini-gmp/mini-gmp.c (mpz_fits_slong_p): Correct range. * mini-gmp/tests/t-signed.c: New test program, for get/set/cmp_si. * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Added t-signed. * mini-gmp/mini-gmp.c (mpz_hamdist): Handle different sizes. * mini-gmp/tests/t-logops.c: Test also popcount and hamdist. 2013-01-10 Marco Bodrato * mpz/export.c: Less restrictive ASSERTs. * mini-gmp/mini-gmp.c (mpz_export, mpz_import): Likewise. * mini-gmp/tests/t-import.c: Test also size=0 or count=0. 2013-01-10 Torbjorn Granlund * mini-gmp/tests/t-import.c (main): Don't drop off function end. * Makefile.am (check-mini-gmp): Set LD_LIBRARY_PATH to allow testing with dynamic main GMP build. 2013-01-09 Marco Bodrato * mini-gmp/mini-gmp.c (mpz_export): Support op=0 countp=NULL. 2013-01-08 Niels Möller * mini-gmp/tests/t-import.c: New test program, testing both mpz_import and mpz_export. * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Added t-import. * mini-gmp/tests/mini-random.c (mini_rrandomb_export): New function. * mini-gmp/tests/mini-random.h: Declare it. * mini-gmp/tests/hex-random.c (hex_rrandomb_export): New function. * mini-gmp/tests/hex-random.h: Declare it. * mini-gmp/mini-gmp.c (mpz_export): Compute accurate word count up front, to avoid generating any high zero words. 2013-01-07 Marco Bodrato * mini-gmp/README: Document base limitation for conversions. * mini-gmp/mini-gmp.c (mpz_set_str): Remove goto. (mpz_import, mpz_export): Correctly use order/endianness. 2013-01-05 Torbjorn Granlund * longlong.h (aarch64): Make add_ssaaaa and sub_ddmmss actually work. 2013-01-04 Marco Bodrato From shuax: * mini-gmp/mini-gmp.c (mpz_import): Reset limb after storing it. 2013-01-04 Torbjorn Granlund From Marko Lindqvist: * configure.ac: Use AC_CONFIG_HEADERS instead of the obsolete AM_CONFIG_HEADER. 2013-01-02 Marco Bodrato * tests/mpz/bit.c: Wider testing for mpz_combit. * tests/mpz/logic.c: Check the -2^n case. * mpz/ior.c: Fixed an allocation bug in the -2^n case. 2012-12-31 Torbjorn Granlund * mpn/generic/get_d.c: Minor reorg, add vax D code. * gmp-impl.h (double_extract): New union type for vax D floats. * tests/mpq/t-get_d.c (check_random): Limit exponents on vax. 2012-12-30 Marco Bodrato * tests/mpz/bit.c (check_clr_extend): Check _set shrink. 2012-12-29 Torbjorn Granlund * demos/calc/calc.c: Remove generated file from repo. * demos/calc/calc.h: Likewise. * demos/calc/calclex.c: Likewise. 2012-12-27 Torbjorn Granlund * mpn/generic/get_d.c: Complete rewrite of non-IEEE code. * tests/mpq/t-get_d.c (main): Suppress check_random for vax. 2012-12-25 Torbjorn Granlund * mpn/x86_64/bdiv_q_1.asm: Use LEA for binvert_limb_table. 2012-12-23 Torbjorn Granlund * tests/mpz/t-get_d.c (check_onebit): Decrease vax limit to avoid overflow in last, unused 'want' value. * config.guess: Recognise AMD family 22 as a future bobcat. 2012-12-21 Torbjorn Granlund * configure.ac: Rename configure.in. 2012-12-17 Torbjorn Granlund * Version 5.1.0 released. * configure.in (none-*-*): Allow this again, but print a warning. 2012-12-17 Marco Bodrato * mpz/n_pow_ui.c: Fix typos in an ASSERT. 2012-12-16 Torbjorn Granlund * mpn/generic/mu_div_qr.c (mpn_preinv_mu_div_qr): Explicitly use MPN_COPY_INCR for slightly overlapping copy. 2012-12-15 Marco Bodrato * tests/mpn/toom-sqr-shared.h: Skip ALLOCs if the test is skipped. 2012-12-13 Torbjorn Granlund * mpn/x86_64/dos64.m4 (PIC): Move definition early. (JMPENT): Remove PIC variant. * mpn/x86_64/darwin.m4 (JUMPTABSECT): Define to .text, instead of something sensible. 2012-12-12 Torbjorn Granlund * mpn/x86_64/x86_64-defs.m4 (JMPENT): New macro. * mpn/x86_64/dos64.m4: Likewise. * mpn/x86_64/darwin.m4: Likewise. * mpn/x86_64/mod_34lsub1.asm: Use JMPENT to properly support PIC. * mpn/x86_64/mullo_basecase.asm: Likewise. * mpn/x86_64/sqr_basecase.asm: Likewise. 2012-12-11 Torbjorn Granlund * mpn/x86_64/mod_34lsub1.asm: Try different jump table for the benefit of broken Apple linkers. 2012-12-09 Torbjorn Granlund * configure.in: Make GMP_NONSTD_ABI ABI specific. 2012-12-08 Torbjorn Granlund * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*): Bump version info. * gmp-h.in: Bump version. 2012-12-06 Marco Bodrato * tests/mpq/reuse.c: New test (adapted from mpf/reuse.c). * tests/mpq/Makefile.am (check_PROGRAMS): Add reuse. * mpz/abs.c: Use NEWALLOC. * mpz/neg.c: Likewise. * mpz/com.c: Reduce branches. 2012-12-05 Niels Möller * mpn/generic/brootinv.c (mpn_brootinv): Make valgrind happier, at the cost of a redundant MPN_ZERO. * mpz/jacobi.c (mpz_jacobi): Check for asize == 0 or bsize == 0 before using the low limbs. 2012-12-05 Torbjorn Granlund * mpn/generic/set_str.c (mpn_dc_set_str): Work around a valgrind issue. * mpz/powm_ui.c: Don't assume >= 2 limbs in mod argument. * tests/tests.h (TESTS_REPS): Handle float GMP_CHECK_REPFACTOR. * longlong.h: Refine cpp test for vax. * tests/mpn/t-get_d.c: Likewise. * tests/mpz/t-get_d.c: Likewise. * tests/mpz/t-cmp_d.c: Likewise. * tests/mpz/t-get_d.c: Likewise. * tests/mpq/t-get_d.c: Likewise. * tests/mpf/t-get_d.c: Likewise. 2012-11-30 Torbjorn Granlund * gen-fac.c (gen_consts): Correct printf types. * mpn/arm/v7a/cora15/gmp-mparam.h: New file. * configure.in (arm*-*-*): New compiler optional "tune". Pass value for selected processors. Add more specific path components. 2012-11-29 Torbjorn Granlund From Andoni Morales Alastruey: * longlong.h: Conditionalise ARM asm on !__thumb__. 2012-11-28 Torbjorn Granlund * config.guess (arm*-*-*): Support specific ARM processors. * config.sub: Match arm CPUs. * configure.in (arm*-*-*): Likewise. * mpz/powm.c: Move new_b out since it lives on through b. * configure.in (arm*-*-*): Pass -marm to deal with compilers defaulting to thumb code. 2012-11-26 Torbjorn Granlund * tests/cxx/t-ops2.cc (checkz): Reduce huge numbers to avoid vax overflow. 2012-11-25 Torbjorn Granlund * mpn/generic/get_d.c: Reinsert non-IEEE code. * mpn/vax/add_n.asm: New file. * mpn/vax/add_n.s: Remove. * mpn/vax/addmul_1.asm: New file. * mpn/vax/addmul_1.s: Remove. * mpn/vax/lshift.asm: New file. * mpn/vax/lshift.s: Remove. * mpn/vax/mul_1.asm: New file. * mpn/vax/mul_1.s: Remove. * mpn/vax/rshift.asm: New file. * mpn/vax/rshift.s: Remove. * mpn/vax/sub_n.asm: New file. * mpn/vax/sub_n.s: Remove. * mpn/vax/submul_1.asm: New file. * mpn/vax/submul_1.s: Remove. * mpn/vax/elf.m4: New file. * configure.in (vax*-*-*elf*): New case, grabbing vax/elf.m4. * tests/mpn/t-get_d.c (check_onebit): Get vax bounds right. (main): Switch off check_rand for vax. 2012-11-22 Niels Möller * mini-gmp/tests/run-tests: Copied latest version from GNU Nettle. Minor fix to the use of $EMULATOR, and proper copyright notice. 2012-11-16 Torbjorn Granlund * mpn/generic/powm_sec.c (redcify): Use mpn_sb_div_r_sec. * mpn/generic/sb_div_sec.c: New file. * mpn/generic/sbpi1_div_sec.c: New file. * configure.in (gmp_mpn_functions): Add new files. * gmp-impl.h: Declare new functions. 2012-11-12 Torbjorn Granlund * longlong.h: Add ARM64 support. * longlong.h: Add AVR support. * mpn/powerpc64/mode64/divrem_1.asm: Tune, simplify. * mpq/md_2exp.c: Use MPN_COPY_INCR, not MPN_COPY_DECR. * tests/mpq/t-md_2exp.c (check_random): New function. 2012-11-10 Torbjorn Granlund * mpn/generic/remove.c (mpn_bdiv_qr_wrap): Make static. 2012-11-04 Torbjorn Granlund * mpz/powm_ui.c: Rewrite. 2012-11-01 Niels Möller * mpn/generic/brootinv.c (mpn_brootinv): Input size in limbs rather than bits. Use single-precision iterations for the first limb. * mpn/generic/perfpow.c (is_kth_power): Update mpn_brootinv call. * tests/mpn/t-brootinv.c (main): Likewise. * tune/speed.h (SPEED_ROUTINE_MPN_BROOTINV): Likewise. * gmp-impl.h (mpn_brootinv): Updated prototype. * mpn/generic/hgcd2.c (mpn_hgcd2): Removed redundant loop exit tests in the single-precision loop. * mpz/combit.c (mpz_combit): Rewrite, optimizing for the common case. 2012-10-31 Niels Möller * tests/mpn/Makefile.am (check_PROGRAMS): Added t-brootinv. * tests/mpn/t-brootinv.c: New file * mpn/generic/broot.c (mpn_broot_invm1): Avoid a mullo_n in the loop, and do powering as a plain mpn_sqr followed by mpn_powlo. * tune/speed.c (routine): Added mpn_broot, mpn_broot_invm1, mpn_brootinv. * tune/common.c (speed_mpn_broot, speed_mpn_broot_invm1) (speed_mpn_brootinv): New functions. * tune/speed.h (SPEED_ROUTINE_MPN_BROOT) (SPEED_ROUTINE_MPN_BROOTINV): New macros. * mpn/generic/broot.c (mpn_broot_invm1): Made non-static (mainly for benchmarking). * gmp-impl.h (mpn_broot_invm1): Declare it. 2012-10-28 Torbjorn Granlund * configure.in (gmp_mpn_functions): Add new files. * gmp-impl.h: Declare new functions. * mpn/generic/perfpow.c: Overhaul. (binv_root, binv_sqroot): Remove. * mpn/generic/brootinv.c: New file, code from overhauled binv_root. * mpn/generic/bsqrtinv.c: New file, code from overhauled binv_sqroot. * mpn/generic/bsqrt.c: New file. * tests/mpn/t-broot.c: Add a forgotten TMP_MARK. 2012-10-28 Niels Möller * mpn/generic/broot.c (mpn_broot): New file and function. * configure.in (gmp_mpn_functions): Add broot. * gmp-impl.h (mpn_broot): Declare. * tests/mpn/t-broot.c: New testcase. * tests/mpn/Makefile.am (check_PROGRAMS): Added t-broot. 2012-10-27 Torbjorn Granlund * mpn/generic/remove.c: Get remainder allocation right. 2012-10-25 Torbjorn Granlund * longlong.h: De-support old POWER asm syntax. * tests/mpz/t-remove.c: Run more tests, but use a tad smaller operands. * mpn/generic/remove.c (mpn_bdiv_qr_wrap): New function. (mpn_remove): Call mpn_bdiv_qr_wrap. * mpz/remove.c: Enable suppressed mpn_remove call. 2012-10-17 Torbjorn Granlund * mpz/powm_ui.c (mpz_powm_ui): Deflect to mpz_powm for large exponent. 2012-09-10 Torbjorn Granlund * demos/factorize.c: Rewrite no more current form. Implement Lucas prime proving, and make its use the default. * demos/primes.h: New file. 2012-08-24 Torbjorn Granlund * demos/factorize.c: Overhaul. 2012-08-06 Marco Bodrato * doc/gmp.texi (mpn_neg): Correctly document returned type. * gmp-impl.h (_mpz_newalloc, log_n_max): mark with inline (spotted by Niels). 2012-07-28 Marc Glisse * gmpxx.h (std::common_type): New partial specializations with builtin types. * tests/cxx/t-cxx11.cc: Test it. 2012-07-21 Torbjorn Granlund * mpn/powerpc32/vmx/mod_34lsub1.asm: Fix r0 clobbering issue with "large" code affecting elf+darwin PIC. 2012-07-21 Marc Glisse * gmpxx.h (__GMPXX_CONSTANT): Disable for g++-3.4. 2012-06-26 Torbjorn Granlund * Makefile.am (LIBMP_LT_*): Remove these. 2012-06-26 Marc Glisse * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*): Update comment for 5.1.0. 2012-06-24 Marco Bodrato * configure.in (CALLING_CONVENTIONS_OBJS): Disable any use of assembly code with the --disable-assembly option. * mpz/oddfac_1.c: Use the ASSERT_CODE macro. * gen-trialdivtab.c (mpz_log2): Use mpz_sizeinbase (., 2). * gmp-impl.h (MPN_SIZEINBASE_16): Replace with MPN_SIZEINBASE_2EXP from mpz/export.c . * mpz/export.c (MPN_SIZEINBASE_2EXP): Removed. * mpn/generic/sizeinbase.c: Use MPN_SIZEINBASE. * mpz/nextprime.c: Use MPN_SIZEINBASE_2EXP to count bits. * mpn/generic/perfpow.c: Likewise. * mpn/generic/rootrem.c: Likewise. * mpz/get_d_2exp.c: Likewise. * mpn/generic/powm_sec.c: Likewise, nailify. * mpn/generic/powlo.c: Likewise. * mpn/generic/powm.c: Likewise. * mini-gmp/mini-gmp.c (mpz_div_r_2exp, mpz_div_q_2exp): Improve adjustment condition. 2012-06-23 Marc Glisse * gmpxx.h (numeric_limits): Make content public. * cxx/limits.cc: New file, proper declarations. * Makefile.am: List new file. * cxx/Makefile.am: Likewise. * cxx/t-misc.cc: Add minimal test for numeric_limits. 2012-06-09 Marc Glisse * gmpxx.h (__gmp_resolve_expr::srcptr_type): New typedef. (__gmp_temp): Wrapper for mp*_class, the constructor copies the precision of its second argument for mpf_t. (__gmp_expr::eval(p, prec)): Remove. (__gmp_expr::eval(p)): Use __gmp_temp. (__gmp_set_expr): Never pass prec to eval(). 2012-06-08 Marco Bodrato * gmp-impl.h (__GMP_WITHIN_CONFIGURE): Use the same #if as in gmp-h.in. (MPN_NORMALIZE_NOT_ZERO): Tighter ASSERT. (MPZ_NEWALLOC): New macro. * mpq: Use the new macro when possible. * mpz/bin_uiui.c: Likewise. * mpz/oddfac_1.c: Likewise. * mpz/prodlimbs.c: Likewise. * mini-gmp/mini-gmp.c (mpz_realloc): remove a branch. 2012-06-04 Torbjorn Granlund * mpn/powerpc64/aix.m4 (ASM_START): Claim machine type "any". 2012-06-03 Niels Möller * mpn/generic/gcdext.c (mpn_gcdext): Deleted code for handling impossible case u1 == 0, Simplified test for unlikely case u0 == 0. 2012-06-02 Torbjorn Granlund * mpn/arm/lshiftc.asm: New file. 2012-06-01 Torbjorn Granlund * mpn/arm/aorslsh1_n.asm: Use cmp/cmn instead of subs/adds in more places. * mpz/get_str.c: Don't strip leading zeros since current mpn_get_str won't generate any. Misc streamlining. * mpz/out_str.c: Analogous changes. * tests/mpz/io.c: Use a wider range of bases. * tests/mpz/t-cong.c (check_random): Rewrite random generation for exponentially distributed operand sizes. 2012-06-01 Marco Bodrato * mpq: Use more macros and MPZ_REALLOC return value when possible. * gmp-impl.h (LIMBS): Removed, was an alias for PTR. * mpz/combit.c: Use PTR and CNST_LIMB. * tests/mpn/t-bdiv.c: Test also mpn_bdiv_qr. * mpn/generic/bdiv_qr.c: Add an ASSERT. * mpn/generic/remove.c: Add a zero limb to use bdiv_qr... 2012-05-31 Marc Glisse * gmpxx.h (mpq_class::mpq_class): Handle mpq_class(0,1). * tests/cxx/t-constr.cc: Test it. 2012-05-30 Torbjorn Granlund * mpn/x86_64 (FUNC_ENTRY): New name for DOS64_ENTRY. * mpn/x86_64 (FUNC_EXIT): New name for DOS64_EXIT. 2012-05-29 Marco Bodrato * mpz/remove.c: Optimise branches. * mpn/generic/toom6h_mul.c: less branches in the LIKELY balanced path. * mpn/generic/toom8h_mul.c: Likewise. 2012-05-29 Torbjorn Granlund * mpn/arm/v5/mod_1_1.asm: New file. 2012-05-28 Niels Möller * mpn/generic/gcdext.c (compute_v): Simplified carry handling a bit, reduced stated scratch need from 2n+1 to 2n. Also comment and ASSERT improvements. 2012-05-27 Torbjorn Granlund * config.guess: Add new x86 CPUs. * mpn/x86/fat/fat.c: Likewise. * mpn/x86_64/fat/fat.c: Likewise. 2012-05-27 Marco Bodrato * mpn/x86_64/fat/fat.c: abort iff longmode-capable-bit is turned off. * mpn/generic/toom8h_mul.c: mark UNLIKELY branches. 2012-05-26 Torbjorn Granlund * mpz: Use MPZ_REALLOC return value when possible. 2012-05-25 Marco Bodrato * mini-gmp/tests/t-div.c: Test all _qr, _q, _r variants. * mini-gmp/tests/t-lcm.c: Test the _ui variant. * mini-gmp/mini-gmp.c (mpz_mod, mpz_mod_ui): New functions. * mini-gmp/mini-gmp.h (mpz_mod, mpz_mod_ui): Prototypes. * mpz/scan1.c: Simplify, and add a shortcut for scan1(z, 0). 2012-05-24 Torbjorn Granlund * mpz/n_pow_ui.c: Cast non-limb count_leading_zeros argument. 2012-05-24 Marco Bodrato * mpz/remove.c: Support negative divisor. * tests/mpz/t-remove.c: Test negative divisor. 2012-05-23 Torbjorn Granlund * tests/mpz/reuse.c: Major rewrite. 2012-05-23 Marco Bodrato * mpz/sqrt.c: Further simplify. * mpz/sqrtrem.c: Likewise. * Mark failing branches with UNLIKELY. Many files affected. 2012-05-22 Torbjorn Granlund * mpz/sqrt.c: Allocate less for overlapping operands, simplify. * mpz/sqrtrem.c: Likewise. 2012-05-21 Marco Bodrato * mpn/generic/toom8_sqr.c: Reduce branches for recursion. * mpn/generic/toom8h_mul.c: Likewise. * tests/mpn/t-toom8h.c: Don't use GMP_NUMB_BITS when not yet defined. 2012-05-20 Torbjorn Granlund * tests/mpz/t-gcd.c: Rewrite. 2012-05-19 Torbjorn Granlund * tests/mpz/t-gcd.c: Generate larger operands for better gcd code coverage; distribute size exponentially. 2012-05-17 Marco Bodrato * mpf/pow_ui.c: Simplify. * tests/mpf/reuse.c (dsi_func): Exercise pow_ui. * tests/mpf/t-set_ui.c (check_data): LONG_HIGHBIT -> ULONG_HIGHBIT. * tests/mpf/t-set.c (check_random): New check, both set and init_set. * tests/cxx/t-ops.cc (check_mpq): Check squaring. * tests/mpq/t-equal.c (check_various): Check different den-size. * mpn/generic/mullo_n.c: Disable MAYBE_ if WANT_FAT_BINARY. * mpz/cmpabs_d.c: Remove an unused branch. * tests/mpz/t-get_d_2exp.c (check_zero): New check. * tests/mpz/t-inp_str.c: A few more cases. * tests/mpz/t-cmp_d.c: More bases and symbols, a few cases. * mpz/rootrem.c: Correctly handle odd roots of negatives. * tests/mpz/t-root.c: Test it. 2012-05-16 Torbjorn Granlund * tests/mpf/t-eq.c (check_random): New function, meat from old main(). (check_data): New function. 2012-05-13 Torbjorn Granlund * mpn/arm/rsh1aors_n.asm: New file. * mpn/arm/v5/mod_1_2.asm: New file. 2012-05-11 Marc Glisse * gmpxx.h (explicit operator bool): New functions. * tests/cxx/t-cxx11.cc: Test the above. 2012-05-10 Marco Bodrato * gmp-impl.h (__gmpn_cpuvec_initialized): Was __gmpn_cpuvec.initialized * mpn/x86/fat/fat.c: Use separated _initialized variable. * mpn/x86_64/fat/fat.c: Likewise. * tests/mpn/t-fat.c: Likewise. * mpn/generic/toom2_sqr.c: Override global __gmpn_cpuvec_initialized. * mpn/generic/toom22_mul.c: Likewise. * mpn/generic/toom3_sqr.c: Likewise. * mpn/generic/toom33_mul.c: Likewise. 2012-05-09 Marco Bodrato * mini-gmp/mini-gmp.c: merge mpz_rootrem and mpz_sqrtrem. * mpn/generic/sqrtrem.c (invsqrttab): Reduce size removing common byte. * mpz/bin_uiui.c (mul3, mul4, mul8): Remove unneeded shifts. (MAXFACS): Redefine, using the shared (safer) log_n_max. 2012-05-08 Torbjorn Granlund * mpn/minithres/gmp-mparam.h (REDC_1_TO_REDC_N_THRESHOLD): Up to 9, for coherency with ASSERT in mpn/generic/redc_n.c. 2012-05-07 Marco Bodrato * mpn/minithres/gmp-mparam.h: Updated TOOM6 and FAC_DSC. * tests/mpn/toom-sqr-shared.h: Don't test if no range. * mpz/oddfac_1.c: Add ASSERTs to warn about small threshold. * tune/tuneup.c: Update minimal threshold for FAC_DSC. 2012-05-06 Torbjorn Granlund * mpn/arm/v6/sqr_basecase.asm: Simplify n=4 code. 2012-05-05 Marco Bodrato * mpn/generic/invert.c: Mark a branch UNLIKELY. * tune/tuneup.c (tune_fac_u): Update DSC_THRESHOLD minimum. * gmp-impl.h (FAC_???_THRESHOLD): Update default values. (ABOVE_THRESHOLD): New definition with __builtin_constant_p. * mpn/generic/toom22_mul.c: Disable MAYBE_ if WANT_FAT_BINARY. * mpn/generic/toom33_mul.c: Likewise. * mpn/generic/toom2_sqr.c: Likewise. * mpn/generic/toom3_sqr.c: Likewise. 2012-05-04 Torbjorn Granlund * tune/tuneup.c: Measure POWM_SEC_TABLE after the REDC thresholds. 2012-05-03 Torbjorn Granlund * mpn/generic/powm_sec.c: Use redc_2. (INNERLOOP): Use this mechanism, like plain powm.c. (WANT_CACHE_SECURITY): Remove, feature now unconditional. 2012-05-02 Torbjorn Granlund * mpz/bin_uiui.c: Make use of CNST_LIMB. 2012-05-02 Marco Bodrato * mpz/mfac_uiui.c: Support limb != ui. 2012-05-02 Torbjorn Granlund * mpn/arm/logops_n.asm: Work around register clobbering issue. * mpn/arm/aorscnd_n.asm: New file. 2012-05-01 Torbjorn Granlund * configure.in: Put arm dirs in path in proper prio order. * mpn/arm/logops_n.asm: New file. * mpz/2fac_ui.c: Fix assumed typo. * mpn/arm/v6/gmp-mparam.h: New file. * mpn/arm/v5/gcd_1.asm: Hack for undefined BMOD_1_TO_MOD_1_THRESHOLD. * mpn/arm/v6t2/gcd_1.asm: Likewise. 2012-04-30 Torbjorn Granlund * mpn/arm/v6/sqr_basecase.asm: New file. 2012-04-30 Marco Bodrato * mpn/generic/comb_tables.c: New file. * configure.in: Add it. * gen-fac.c: Define table limits. * gmp-impl.h: Declare tables. (log_n_max): New static function. * mpz/2fac_ui.c: Use shared tables. * mpz/bin_uiui.c: Likewise. * mpz/oddfac_1.c: Likewise. * mpz/primorial_ui.c: Likewise. * mpz/mfac_uiui.c: New file. * Makefile.am: Compile it. * mpz/Makefile.am (libmpz_la_SOURCES): Add mpz_mfac_uiui.c * gmp-h.in (mpz_mfac_uiui): Declare. * tests/mpz/t-mfac_uiui.c: New file. * tests/mpz/Makefile.am: Run it. * doc/gmp.texi: Document mpz_mfac_uiui, collapsing with other factorial functions. * tests/mpz/t-lcm.c: Test zero too. * mpz/prodlimbs.c: Simplify threshold (should be tuned, not guessed). 2012-04-29 Torbjorn Granlund * mpn/arm/aors_n.asm: Tune for more stable performance. * mpn/arm/aorslsh1_n.asm: New file. * mpn/arm/mod_34lsub1.asm: New file. * mpn/arm/v6t2/divrem_1.asm: New file. 2012-04-28 Torbjorn Granlund * mpn/thumb/add_n.asm: New file. * mpn/thumb/sub_n.asm: New file. * mpn/thumb/add_n.s: Remove broken code. * mpn/thumb/sub_n.s: Likewise. * mpn/arm/v6/addmul_1.asm: Rewrite for stable speed, smaller size. * mpn/arm/v6/mul_1.asm: Likewise. 2012-04-27 Torbjorn Granlund * configure.in: Search arm/v6t2 for arm7. * mpn/arm/v5/gcd_1.asm: New file. * mpn/arm/v6t2/gcd_1.asm: New file. * mpn/arm/mode1o.asm: New file. * mpn/arm/v6t2/mode1o.asm: New file. * mpn/arm/arm-defs.m4 (LEA): New define. * mpn/arm/invert_limb.asm: Use LEA. 2012-04-26 Marco Bodrato * mpz/bin_uiui.c (bc_bin_uiui): Nail support. * tests/cxx/t-ops2.cc: Test 0/3. * oddfac_1.c: assume n > 26. * tests/mpz/t-jac.c (mpn_jacobi_n): Enlarge tested sizes. 2012-04-24 Torbjorn Granlund * mpn/arm/v6/addmul_2.asm: New file. * mpn/arm/v6/mul_2.asm: New file. 2012-04-23 Torbjorn Granlund * mpn/arm/aorsmul_1.asm: Tweak loop control for a 6% speed increase. 2012-04-22 Torbjorn Granlund * configure.in: Recognise ARM sub-architectures. * configfsf.guess: Update to current FSF version. * configfsf.sub: Likewise. * mpn/arm/bdiv_dbm1c.asm: New file. * mpn/arm/v6/mul_1.asm: New file. * mpn/arm/v6/addmul_1.asm: New file. 2012-04-22 Marco Bodrato * gen-fac.c: Renamed, was gen-fac_ui.c . * Makefile.am: Renamed gen-fac.c and fac_table.h . * gmp-impl.h: #include "fac_table.h". * mpz/oddfac_1.c: Use generated constant. * mpz/bin_ui.c: Small optimisations. * tune/common.c (speed_mpz_bin_ui): New function. * tune/speed.h: Declare it. * tune/speed.c: Use it. 2012-04-21 Torbjorn Granlund * mpn/arm/mul_1.asm: Cleanup. * mpn/arm/copyi.asm: Cleanup, assume allocate-on-write cache. * mpn/arm/copyd.asm: Likewise. * mpn/arm/add_n.asm: Delete. * mpn/arm/sub_n.asm: Delete. * mpn/arm/aors_n.asm: New file, made from old files. * mpn/arm/addmul_1.asm: Delete. * mpn/arm/submul_1.asm: Delete. * mpn/arm/aorsmul_1.asm: New file, made from old files. * mpn/arm/com.asm: New file. * mpn/arm/lshift.asm: New file. * mpn/arm/rshift.asm: New file. 2012-04-20 Torbjorn Granlund * tests/mpq/io.c: New file. * tests/mpq/Makefile.am: Run it. * mpz/clrbit.c: Simplify along the lines of setbit.c. 2012-04-20 Marco Bodrato * mpz/setbit.c: Simplify. * gmp-impl.h (LOG2C): Define. * mpz/fac_ui.c (LOG2C): Remove. * mpz/2fac_ui.c (LOG2C): Remove. * mpz/oddfac_1.c (LOG2C): Remove. * mpn/generic/binvert.c (LOG2C): Remove. * mpn/generic/invertappr.c (LOG2C): Remove. * mpz/bin_uiui.c (mpz_goetgheluck_bin_uiui): Move declarations, and assume that n and k are not small. 2012-04-19 Torbjorn Granlund * tests/mpz/Makefile.am (check_PROGRAMS): Add t-remove. * tests/mpz/t-remove.c: Clear out mpz variables. * tests/mpz/t-cong.c (check_random): Use much larger numbers. (check_data): Check congruences mod 0. * tests/mpz/t-divis.c: Test divisibility by zero. * tests/mpz/reuse.c: Test mpz_mod. * mpz/setbit.c: Remove dead code. Use CNST_LIMB. * mpz/clrbit.c: Use CNST_LIMB. 2012-04-19 Marco Bodrato * primesieve.c: New file, with functions from mpz/oddfac_1.c . * mpz/oddfac_1.c (bitwise_primesieve): Re-moved. * Makefile.am (libgmp_la_SOURCES): Add primesieve.c . * gmp-impl.h (gmp_primesieve): Declare. * mpz/bin_uiui.c (mpz_goetgheluck_bin_uiui): New, factor-based implementation. * tests/mpz/t-bin.c: Extend tests, to cover _goetgheluck. * mpz/primorial_ui.c: New file. * mpz/Makefile.am (libmpz_la_SOURCES): Add mpz/primorial_ui.c * Makefile.am (MPZ_OBJECTS): Add mpz/primorial_ui$U.lo * gmp-h.in (mpz_primorial_ui): Declare. * tests/mpz/t-primorial_ui.c: New test for the new function. * tests/mpz/Makefile.am (check_PROGRAMS): Add t-primorial_ui. * doc/gmp.texi: Short documentation for the new function. 2012-04-17 Torbjorn Granlund * mpn/x86_64/coreisbr/aorsmul_1.asm: Fix some DOS64 issues. * mpn/x86_64/coreisbr/mul_1.asm: Likewise. * mpn/x86_64/fastsse/lshiftc-movdqu2.asm: Adhere to DOS64 register partitioning rules. * mpn/x86_64/fastsse/copyi-palignr.asm: Implement temporary workaround to overlap issue. 2012-04-17 Marco Bodrato * mpz/bin_uiui.c: Support small limbs (fallback on bin_ui). * tests/mpn/toom-sqr-shared.h: Use a restricted range. * tests/mpn/t-toom2-sqr.c: Specify correct range. * tests/mpn/t-toom3-sqr.c: Likewise. * tests/mpn/t-toom4-sqr.c: Likewise. * tests/mpn/t-toom6-sqr.c: Likewise. * tests/mpn/t-toom8-sqr.c: Likewise, but extended. * tests/mpn/Makefile.am (check_PROGRAMS): Add t-toom?-sqr tests. * mpn/generic/sbpi1_bdiv_q.c: Move ASSERTs, to support qp = np. 2012-04-17 Torbjorn Granlund * mpn/x86_64/copyd.asm: Rewrite. * mpn/x86_64/copyi.asm: Rewrite. 2012-04-16 Torbjorn Granlund * mpn/x86_64/fastsse/lshift-movdqu2.asm: Add DOS entry/exit sequences. * mpn/x86_64/fastsse/rshift-movdqu2.asm: Likewise. * mpn/x86_64/fastsse/lshiftc-movdqu2.asm: Likewise. * mpn/x86_64/x86_64-defs.m4 (palignr): New macro. (x86_opcode_regxmm, x86_opcode_regxmm_list): New, made from x86 mmx counterparts. (x86_lookup): Copy from x86/x86-defs.m4. * mpn/x86_64/fastsse/copyd-palignr.asm: Use palignr macro. * mpn/x86_64/fastsse/copyi-palignr.asm: Likewise. 2012-04-15 Marco Bodrato * tests/mpz/t-bin.c: Add more tests on small values. * mpz/bin_uiui.c (mpz_bdiv_bin_uiui): Smaller temporary areas. 2012-04-15 Torbjorn Granlund * mpn/x86_64/fastsse/copyd-palignr.asm: New file. * mpn/x86_64/fastsse/copyi-palignr.asm: New file. * mpn/x86_64/core2/copyd.asm: New file. * mpn/x86_64/core2/copyi.asm: New file. * mpn/x86_64/nano/copyd.asm: New file. * mpn/x86_64/nano/copyi.asm: New file. * mpn/x86_64/atom/copyd.asm: New file. * mpn/x86_64/atom/copyi.asm: New file. 2012-04-13 Marco Bodrato * mpz/bin_uiui.c: Rewrite (some parts are Torbjorn's). * gen-fac_ui.c: Generate new constants for bin_uiui. * mini-gmp/mini-gmp.h (mpz_fac_ui, mpz_bin_uiui): New definitions. * mini-gmp/mini-gmp.c (mpz_fac_ui, mpz_bin_uiui): Trivial implementation. * tests/mpz/t-fac_ui.c: Check Wilson's theorem on a big value. * mpn/generic/invert.c: Remove support for scratch == NULL. * tune/speed.h (SPEED_ROUTINE_MPN_MUPI_DIV_QR): Allocate scratch space for mpn_invert. * mpz/mul_i.h: Small clean-up. * tests/mpn/toom-sqr-shared.h: New file. * tests/mpn/t-toom2-sqr.c: New file. * tests/mpn/t-toom3-sqr.c: New file. * tests/mpn/t-toom4-sqr.c: New file. * tests/mpn/t-toom6-sqr.c: New file. * tests/mpn/t-toom8-sqr.c: New file. * tests/mpn/Makefile.am (EXTRA_DIST): Add toom-sqr-shared.h . * mpn/generic/toom62_mul.c: Use add_n, sub_n, when possible. 2012-04-12 Torbjorn Granlund * mpn/x86_64/fastsse/lshift-movdqu2.asm: New file. * mpn/x86_64/fastsse/rshift-movdqu2.asm: New file. * mpn/x86_64/fastsse/lshiftc-movdqu2.asm: New file. * mpn/x86_64/coreisbr/lshift.asm: New file. * mpn/x86_64/coreisbr/rshift.asm: New file. * mpn/x86_64/coreisbr/lshiftc.asm: New file. * mpn/x86_64/k10/lshift.asm: New file. * mpn/x86_64/k10/rshift.asm: New file. * mpn/x86_64/k10/lshiftc.asm: New file. * mpn/x86_64/fastsse/lshift.asm: Simplify to very basic form. 2012-04-11 Niels Möller * Makefile.am (check-mini-gmp): Pass -I../.. in EXTRA_CFLAGS, to locate gmp.h. 2012-04-11 Marco Bodrato * mini-gmp/mini-gmp.h (mpz_root, mpz_rootrem): define (correctly). * mini-gmp/mini-gmp.c (mpz_rootrem): Extended code from _root. (mpz_root): Use mpz_rootrem. (mpz_mul_ui): Correctly handle negative operands. * mini-gmp/tests/Makefile (CHECK_PROGRAMS): add t-root. * mini-gmp/tests/t-root.c: New file. * mini-gmp/tests/t-reuse.c: Enable root{,rem} tests. 2012-04-10 Marco Bodrato * gen-fac_ui.c (mpz_root): Remove. * mini-gmp/mini-gmp.c (mpz_root): New, support negative operands. * mini-gmp/mini-gmp.h (mpz_root): define. (mpz_out_str): Test also __STDIO_LOADED (for VMS). * mpz/2fac_ui.c: Cosmetic change. 2012-04-07 Torbjorn Granlund * mpn/ia64/gcd_1.asm: Rewrite inner loop to use ctz table. 2012-04-05 Torbjorn Granlund * mpn/powerpc64/p7/popcount.asm: Properly extend arg n for mode32. * mpn/powerpc64/p7/hamdist.asm: Likewise. 2012-04-04 Torbjorn Granlund * mpn/powerpc64/p7/popcount.asm: New file. * mpn/powerpc64/p7/hamdist.asm: New file. * longlong.h (ARM count_leading_zeros): Enable for more arch versions. * mpn/x86_64/gcd_1.asm: Make room for DOS64 regparm shadow area. * mpn/x86_64/core2/gcd_1.asm: Likewise. 2012-04-03 Torbjorn Granlund * mpn/x86_64/coreisbr/aorrlsh_n.asm: Make it actually work for DOS64. 2012-04-02 Marco Bodrato * mpz/oddfac_1.c: Initialize size for ASSERT. 2012-04-02 Torbjorn Granlund * gmp-h.in (_GMP_H_HAVE_FILE): Test also __STDIO_LOADED (for VMS). * gmp-impl.h (doprnt_format_t, etc): Remove bogus __GMP_DECLSPECs. 2012-03-30 Marco Bodrato * mpn/x86_64/sqr_basecase.asm: Speed-up for small cases. 2012-03-29 Torbjorn Granlund * mpn/sparc64/gcd_1.asm: New file. 2012-03-27 Torbjorn Granlund * config.guess: Fix typo in coreisbr recognition. 2012-03-26 Marco Bodrato * mpn/x86_64/gcd_1.asm: Reduce latency. * mpn/x86_64/mul_basecase.asm: Save one jump. * mpz/iset_ui.c: Don't realloc. 2012-03-20 Marco Bodrato * mp_clz_tab.c: Add __clz_tab[128]. * longlong.h (count_trailing_zeros): Use it in pure C variant. 2012-03-20 Torbjorn Granlund * configure.in (x86 fat_path): Add many missing directories. * mpn/x86/fat/fat.c (__gmpn_cpuvec_init): Rewrite. (fake_cpuid_table): Add many more CPUs. * mpn/x86_64/fat/fat.c (__gmpn_cpuvec_init): Minor spacing cleanup. 2012-03-19 Torbjorn Granlund * mpn/x86/x86-defs.m4 (CALL, PIC_WITH_EBX): New macros. * mpn/x86/darwin.m4: Likewise. * mpn/x86/k7/gcd_1.asm: Use new macros to support PIC. * mpn/x86/p6/gcd_1.asm: Likewise. 2012-03-19 Marco Bodrato * gen-fac_ui.c: Generate more constants (possible mini-mpz_root). * mpz/oddfac_1.c: Improve ASSERTs. (log_n_max): Use precomputed table. * longlong.h (_PROTO): Remove. 2012-03-18 Torbjorn Granlund * longlong.h (count_trailing_zeros): Write better pure C default variant. * mpn/x86/p6/gcd_1.asm: Remove forgotten x86_64 reference. * mpn/x86/p6/gmp-mparam.h: Update, to get BMOD_1_TO_MOD_1_THRESHOLD defined for fat binaries. 2012-03-17 Torbjorn Granlund * mpn/x86/k7/gcd_1.asm: Rewrite. * mpn/x86/p6/gcd_1.asm: New file. * mpn/x86_64/core2/gcd_1.asm: Conditionally suppress reduction calls. * mpn/x86_64/gcd_1.asm: Rewrite. 2012-03-15 Torbjorn Granlund * mpn/generic/gcd_1.c: Parameterise zerotab code. * mpn/x86_64/nano/gcd_1.asm: New file, grabbing core2 asm file. * mpn/x86_64/core2/gcd_1.asm: Speed up loop code, simplify non-loop code. 2012-03-13 Torbjorn Granlund * mpn/x86_64/core2/gcd_1.asm: Add hack to support fat builds. * mpn/x86_64/core2/gcd_1.asm: Shorten critical path. 2012-03-12 Torbjorn Granlund * mpn/x86_64/core2/gcd_1.asm: New file. * mpn/x86_64/k10/gcd_1.asm: New file, grabbing core2 asm file. * mpn/x86_64/bd1/gcd_1.asm: Likewise. * mpn/x86_64/bobcat/sqr_basecase.asm: New file. * mpn/x86_64/bobcat/mul_basecase.asm: Minor tuning. 2012-03-10 Torbjorn Granlund * configure.in (fat_functions): Add addlsh1_n, addlsh2_n, addmul_2, mullo_basecase, redc_1, redc_2, sublsh1_n. * gmp-impl.h (struct cpuvec_t): Add fields for new fat functions. * gmp-impl.h: Adjust corresponding declarations. * mpn/generic/redc_2.c (mpn_addmul_2): Make static. * mpn/x86_64/fat/fat_entry.asm (FAT_INIT): Expand before fat_init to reduce branch offsets. Pass plain 0,1,3... in %al since we'd else run out of 8-bit range. * mpn/x86_64/fat/fat_entry.asm (fat_init): Scale passed index value. * mpn/x86/fat/fat_entry.asm (fat_init): Use movzbl for expanding index value. * mpn/x86_64/x86_64-defs.m4 (CPUVEC_FUNCS_LIST): Add new fat functions. * mpn/x86/x86-defs.m4 (CPUVEC_FUNCS_LIST): Likewise. * mpn/x86_64/fat/fat.c (__gmpn_cpuvec): Likewise. * mpn/x86/fat/fat.c (__gmpn_cpuvec): Likewise. * mpn/x86_64/fat/redc_2.c: New file. * mpn/x86/fat/mullo_basecase.c: New file. * mpn/x86/fat/redc_1.c: New file. * mpn/x86/fat/redc_2.c: New file. * tests/mpn/t-fat.c: Test mullo_basecase. 2012-03-08 Torbjorn Granlund * mpn/x86_64/coreisbr/addmul_2.asm: Port to DOS64. 2012-02-29 Marc Glisse * gmpxx.h: Ignore partial C++11 support in g++-4.6. * tests/cxx/t-cxx11.cc: Likewise. * gmpxx.h (operator""): New functions. * tests/cxx/t-cxx11.cc: Test the above. * doc/gmp.texi: Document the above. 2012-03-08 Marco Bodrato * acinclude.m4 (GMP_H_ANSI): Remove. * configure.in: Don't use GMP_H_ANSI. * gmp-h.in (__GMP_HAVE_PROTOTYPES): Remove. 2012-03-08 Torbjorn Granlund * mpn/x86_64/fat/fat.c (fake_cpuid_table): Recognise "bulldozer". (__gmpn_cpuvec_init): Overhaul to match configure.in. * configure.in: Adjust bulldozer path_64. 2012-03-07 Torbjorn Granlund * configure.in (x86_64 fat_path): List recently added AMD directories. * mpn/x86_64/bobcat/copyi.asm: New file. * mpn/x86_64/bobcat/copyd.asm: New file. * config.guess: Handle AMD 11h correctly. * tune/tuneup.c (tune_redc): Better handle situation where redc_2 is never faster. 2012-03-06 Torbjorn Granlund * mpn/x86_64/bobcat/mul_basecase.asm: New file. 2012-03-04 Torbjorn Granlund * mpn/x86_64/bobcat/mul_1.asm: New file. * mpn/x86_64/bobcat/aorsmul_1.asm: New file. 2012-03-04 Marco Bodrato * mpz/invert.c: Remove mod 0 branch. * tests/mpz/t-invert.c: Avoid testing mod 0. * doc/gmp.texi (mpz_invert): Specify mod 0 is not handled. * gmp-h.in (__gmp_signed, __gmp_const): Remove. (__GMP_HAVE_TOKEN_PASTE, __GMP_HAVE_CONST): Remove. * gmp-impl.h: Strip __GMP_HAVE_TOKEN_PASTE and __GMP_HAVE_CONST. * demos/expr/: Strip __gmp_const usage from all files. * tests/mpz/t-powm.c (allsizes_seen): Require unsigned*. 2012-03-03 Torbjorn Granlund * mpn/x86_64/k8/gmp-mparam.h: New file. * mpn/x86_64/k10/gmp-mparam.h: New file. * mpn/generic/hgcd_step.c (mpn_hgcd_step): Remove unused variables. * mpn/generic/hgcd_jacobi.c (hgcd_jacobi_step): Likewise. * mpn/generic/hgcd_reduce.c (hgcd_matrix_apply): Likewise. * mpn/generic/mu_bdiv_qr.c: Likewise. * mpz/jacobi.c: Likewise. * mpz/mod.c: Likewise. * mpn/generic/toom42_mul.c: Remove unread variable. * mpn/generic/set_str.c (mpn_set_str_compute_powtab): Likewise. * mpn/generic/rootrem.c (mpn_rootrem_internal): Likewise. * tests/refmpn.c (refmpn_mul): Likewise. * mpn/generic/hgcd_appr.c (mpn_hgcd_appr): Propagate mask computation into ASSERT, remove variable. * gmp-h.in (__GMP_PROTO): Remove. * Strip __GMP_PROTO usage from all files. * Strip prototype parameter names from all files. 2012-03-01 Marco Bodrato * doc/gmp.texi (mpz_invert): Correctly document result range. * tests/mpz/t-invert.c: Small range correction. 2012-03-01 Torbjorn Granlund * mpn/x86_64/mullo_basecase.asm: New file. 2012-02-29 Marc Glisse * gmpxx.h (std::numeric_limits): New partial specialization. 2012-02-29 Niels Möller * mini-gmp/tests/t-reuse.c: New test case, based on tests/mpz/reuse.c. * mini-gmp/mini-gmp.c (mpz_cdiv_r_ui): New function. (mpz_fdiv_r_ui): New function. (mpz_tdiv_r_ui): New function. (mpz_powm_ui): New function. (mpz_pow_ui): New function. (mpz_ui_pow_ui): Use mpz_pow_ui. (mpz_gcdext): Fixed input/output overlap, for the case of one input being zero. (mpz_sqrtrem): Fix for the case r NULL, U zero. * Makefile.am (check-mini-gmp): Use $(MAKE). (clean-mini-gmp): New target. (clean-local, distclean-local): New automake targets. Depend on clean-mini-gmp. 2012-02-28 Niels Möller * Makefile.am (check-mini-gmp): New target, for running the mini-gmp testsuite. * mini-gmp/tests/Makefile (srcdir, MINI_GMP_DIR): New make variables. These can be overridden when using a separate build directory. (EXTRA_CFLAGS): Renamed, was OPTFLAGS. * mini-gmp/mini-gmp.c (mpz_abs_add): Don't cache limb pointers over MPZ_REALLOC, since that breaks in-place operation. Bug spotted by Torbjörn. (mpz_and, mpz_ior, mpz_xor): Likewise. (mpz_cmp): Fixed comparison of negative numbers. 2012-02-27 Torbjorn Granlund * mpn/x86_64/fastsse/lshiftc.asm: New file. * mpn/x86_64/fastsse/com.asm: New file. * mpn/x86_64/bd1/popcount.asm: New file. * mpn/x86_64/bd1/hamdist.asm: New file. * mpn/x86_64/fastsse/copyi.asm: New file. * mpn/x86_64/fastsse/copyd.asm: New file. * mpn/x86_64/fastsse/lshift.asm: New file. 2012-02-26 Torbjorn Granlund * mpn/x86_64/coreisbr/addmul_2.asm: New file. * tests/devel/try.c (param_init): Don't require addmul_N to handle overlap. * mpn/x86_64/bd1/mul_1.asm: New file. * mpn/x86_64/bd1/aorsmul_1.asm: New file. 2012-02-26 Marco Bodrato * mpz/2fac_ui.c: New file: implements n!!. * Makefile.am (MPZ_OBJECTS): Add mpz/2fac_ui. * gmp-h.in: Declare mpz_2fac_ui. * tests/mpz/t-fac.c: Test mpz_2fac_ui. * doc/gmp.texi: Document mpz_2fac_ui. * mpz/Makefile.am (libmpz_la_SOURCES): Add 2fac_ui.c. * mpz/oddfac_1.c (mpz_oddfac_1): Use umul_ppmm when size = 2. 2012-02-26 Niels Möller * mini-gmp: New subdirectory. For use by GMP bootstrap, and as a fallback for applications needing bignums but not high performance. * bootstrap.c: New file, replacing dumbmp.c. Uses mini-gmp for the standard GMP functions, and then defines the few functions particular for the bootstrap. * dumbmp.c: Deleted file. A few functions moved to bootstrap.c. * gen-bases.c: Include bootstrap.c, not dumbmp.c. * gen-fac_ui.c: Likewise. * gen-trialdivtab.c: Likewise. * gen-fib.c: Include bootstrap.c, not dumbmp.c. Use assert rather than ASSERT. Deleted casts of xmalloc return value. * gen-psqr.c: Likewise. (COLLAPSE_ELEMENT): Use memmove rather than mem_copyi. * Makefile.am: Replaced all uses of dumbmp.c by bootstrap.c. (EXTRA_DIST, dist-hook): Arrange for distribution of the mini-gmp files. 2012-02-24 Marco Bodrato * mpz/invert.c: Use ABSIZ, MPZ_EQUAL_1_P. * mpz/abs.c: Collapse MPZ_REALLOC(x,.) and PTR(x). * mpz/aors_ui.h: Likewise. * mpz/com.c: Likewise. * mpz/neg.c: Likewise. * mpz/invert.c: Reply "no-inverse" when modulus is zero. * tests/mpz/t-invert.c: Add more checks. * doc/gmp.texi (mpz_invert): Inverse can not be zero. 2012-02-24 Torbjorn Granlund * tests/mpn/logic.c: New file. * tests/mpn/Makefile.am (check_PROGRAMS): Add logic. * tests/mpz/t-invert.c: New file. * tests/mpz/Makefile.am (check_PROGRAMS): Add t-invert. 2012-02-24 Marc Glisse * tests/mpq/t-cmp.c: Move NUM and DEN macros... * tests/mpq/t-cmp_ui.c: Likewise... * gmp-impl.h: ... to here. * mpq/abs.c: Use NUM, DEN, SIZ, ALLOC, PTR, MPZ_REALLOC. * mpq/aors.c: Likewise. * mpq/canonicalize.c: Likewise. * mpq/clear.c: Likewise. * mpq/cmp.c: Likewise. * mpq/cmp_si.c: Likewise. * mpq/cmp_ui.c: Likewise. * mpq/div.c: Likewise. * mpq/equal.c: Likewise. * mpq/get_d.c: Likewise. * mpq/get_den.c: Likewise. * mpq/get_num.c: Likewise. * mpq/get_str.c: Likewise. * mpq/init.c: Likewise. * mpq/inp_str.c: Likewise. * mpq/inv.c: Likewise. * mpq/md_2exp.c: Likewise. * mpq/mul.c: Likewise. * mpq/neg.c: Likewise. * mpq/set.c: Likewise. * mpq/set_d.c: Likewise. * mpq/set_den.c: Likewise. * mpq/set_f.c: Likewise. * mpq/set_num.c: Likewise. * mpq/set_si.c: Likewise. * mpq/set_str.c: Likewise. * mpq/set_ui.c: Likewise. * mpq/set_z.c: Likewise. * mpq/swap.c: Likewise. * tests/mpq/t-inv.c: New test file. * tests/mpq/Makefile.am: Add the above. * gmpxx.h (__gmp_set_expr): Use mpq_set_z. * mpq/md_2exp.c: Collapse MPZ_REALLOC(x,.) and PTR(x). * mpq/set_d.c: Likewise. * mpq/set_f.c: Likewise. 2012-02-24 Niels Möller * mpn/x86_64/core2/aorsmul_1.asm: Added mpn_addmul_1c and mpn_submul_1c entry points. 2012-02-23 Marc Glisse * mpz/abs.c: Use ALLOC, SIZ, ABSIZ, PTR, MPZ_REALLOC. * mpz/aors_ui.h: Likewise. * mpz/array_init.c: Likewise. * mpz/cdiv_q.c: Likewise. * mpz/cdiv_qr.c: Likewise. * mpz/cdiv_r.c: Likewise. * mpz/clear.c: Likewise. * mpz/clrbit.c: Likewise. * mpz/cmp_si.c: Likewise. * mpz/com.c: Likewise. * mpz/fdiv_q.c: Likewise. * mpz/fdiv_qr.c: Likewise. * mpz/fdiv_r.c: Likewise. * mpz/get_si.c: Likewise. * mpz/get_str.c: Likewise. * mpz/init.c: Likewise. * mpz/inp_str.c: Likewise. * mpz/iset.c: Likewise. * mpz/iset_d.c: Likewise. * mpz/iset_si.c: Likewise. * mpz/iset_str.c: Likewise. * mpz/iset_ui.c: Likewise. * mpz/mod.c: Likewise. * mpz/neg.c: Likewise. * mpz/out_str.c: Likewise. * mpz/random2.c: Likewise. * mpz/set_si.c: Likewise. * mpz/set_str.c: Likewise. * mpz/set_ui.c: Likewise. * mpz/setbit.c: Likewise. * mpz/sqrt.c: Likewise. * mpz/swap.c: Likewise. * mpz/tdiv_r_2exp.c: Likewise. * tests/cxx/t-ops.cc: Test mpz_abs reallocation. 2012-02-23 Torbjorn Granlund * mpn/x86_64/core2/rsh1aors_n.asm: Complete rewrite. * mpn/x86_64/coreisbr/rsh1aors_n.asm: Move old core2 code here. * mpn/x86_64/redc_1.asm: Make it work for DOS64 (broken in last edit). 2012-02-20 Marco Bodrato * mpn/generic/toom_interpolate_8pts.c: Compute carry iif non-trivial. * mpz/gcdext.c: Adapt to relaxed mpn_gcdext's input requirements. * mpz/and.c: Use mpn_ logic everywhere. Reduce branches. * mpz/ior.c: Likewise. * mpz/xor.c: Likewise. 2012-02-20 Torbjorn Granlund * mpn/x86_64/coreisbr/mul_1.asm: New file. * mpn/x86_64/coreisbr/aorsmul_1.asm: New file. * mpn/x86_64/mod_34lsub1.asm: Avoid ",pt" branch hint since many assemblers don't support it. 2012-02-19 Torbjorn Granlund * mpn/generic/redc_1.c: Put back mpn_add_n call, return its carry. Reintroduce previously removed RP argument. * mpn/x86_64/redc_1.asm: Likewise. * mpn/generic/redc_2.c: Remove mpn_sub_n call, return carry from mpn_add_n call. * gmp-impl.h (mpn_redc_1, mpn_redc_2): Now return an mp_limb_t. * tune/speed.h (SPEED_ROUTINE_REDC_1): Adopt to pass RP argument. * tests/refmpn.c (refmpn_redc_1): Adopt to new redc_1 interface. * mpn/generic/powm.c (MPN_REDC_1): Pass rp parameter to mpn_redc_1. * mpn/generic/powm_sec.c (MPN_REDC_1_SEC): Likewise. * mpn/generic/powm.c (MPN_REDC_2): New macro, use for mpn_redc_2. 2012-02-18 Marc Glisse * gmpxx.h (std::common_type): New partial specialization in C++11. * tests/cxx/t-cxx11.cc: Test it. * gmpxx.h: Don't declare long double functions that are never defined. * gmpxx.h (__gmp_binary_expr): Let things happen in place: q=q*q+z*z becomes tmp=z*z, q=q*q, q+=tmp. * tests/cxx/t-binary.cc: More variable reuse tests. 2012-02-17 Marc Glisse * gmp-h.in (__GMP_WITHIN_GMP): Test with #ifdef instead of #if, for the benefit of applications using gcc -Wundef. (__GMP_WITHIN_GMPXX): Likewise. 2012-02-16 Marc Glisse * gmpxx.h (__gmp_binary_expr): Let things happen in place: e=a*b-c*d becomes tmp=c*d, e=a*b, e-=tmp. * tests/cxx/t-binary.cc: More variable reuse tests. 2012-02-15 Niels Möller * tune/tuneup.c (mul_toom43_to_toom54_threshold): New global. (tune_mul): Added tuning of MUL_TOOM43_TO_TOOM54_THRESHOLD. * tune/speed.h (SPEED_ROUTINE_MPN_TOOM43_FOR_TOOM54_MUL): New macro. (SPEED_ROUTINE_MPN_TOOM54_FOR_TOOM43_MUL): New macro. Prototypes for corresponding functions. * tune/common.c (speed_mpn_toom43_for_toom54_mul): New function. (speed_mpn_toom54_for_toom43_mul): New function. * gmp-impl.h (MPN_TOOM43_MUL_MINSIZE): Corrected constant. (MPN_TOOM53_MUL_MINSIZE): Likewise. (MPN_TOOM54_MUL_MINSIZE): New constant. (mpn_toom54_mul): Added prototype. (MUL_TOOM43_TO_TOOM54_THRESHOLD): New threshold. Default value and tuning setup. 2012-02-14 Niels Möller * mpn/generic/toom54_mul.c: New file, originally contributed by Marco. * gmp-impl.h (mpn_toom54_mul_itch): New function. * configure.in (gmp_mpn_functions): Added toom54_mul. * tests/mpn/t-toom54.c: New file. * tests/mpn/Makefile.am (check_PROGRAMS): Added t-toom54. 2012-02-13 Niels Möller * configure.in: Display summary of options. 2012-02-11 Torbjorn Granlund * tests/tests.h (TESTS_REPS): Print any non-standard repetitions. 2012-02-11 Marco Bodrato * doc/gmp.texi (Factorial): Shortly describe current algorithm. (Multiplication Algorithms): Add Toom[68]'n'half, (too) shortly. * gmp-impl.h (ASSERT_ALWAYS): Consider failures UNLIKELY. 2012-02-10 Niels Möller * tests/mpz/t-gcd.c (gcdext_valid_p): Enforce slightly stricter bound for cofactors. * mpn/generic/gcdext_lehmer.c (mpn_gcdext_hook): Corrected handling of unlikely (maybe impossible?) case u1n < un. Related to the 2012-02-05 bugfix of gcdext_subdiv_step.c in the gmp-5.0 repo. 2012-02-09 Marco Bodrato * gmp-impl.h (mpn_toom3*_itch): Support any recursion depth. * tests/refmpn.c (refmpn_mul): Restore tight allocations. * mpz/oddfac_1.c (mpz_oddfac_1): Get ready for n!! * gmp-impl.h (mpz_oddfac_1): Update signature. * mpz/fac_ui.c (mpz_fac_ui): Update call to mpz_oddfac_1. 2012-02-09 Marc Glisse * gmp-impl.h (ABS_CAST): New macro. * mpf/cmp_si.c: Use ABS_CAST. * mpf/get_si.c: Use ABS_CAST. * mpf/iset_si.c: Use ABS_CAST. * mpf/set_si.c: Use ABS_CAST. * mpq/set_si.c: Use ABS_CAST. * mpz/cmp_si.c: Use ABS_CAST. * mpz/get_si.c: Use ABS_CAST. * mpz/iset_si.c: Use ABS_CAST. * mpz/mul_i.h: Use ABS_CAST. * mpz/set_si.c: Use ABS_CAST. 2012-02-08 Torbjorn Granlund * mpn/powerpc32/divrem_2.asm: Fix off-by-one condition in invert_limb code. 2012-02-08 Niels Möller * doc/gmp.texi (mpz_gcdext): Clarified corner cases in cofactor canonicalization. 2012-02-07 Niels Möller * mpn/generic/gcdext.c (mpn_gcdext): Fixed assert, related to the special case A = (2k+1) G, B = 2 G. Fix copied from gmp-5.0 repo. 2012-02-06 Niels Möller * mpn/generic/hgcd_matrix.c (hgcd_matrix_update_q): Fixed carry handling bug. Fix copied from gmp-5.0 repo, where the function is found in hgcd.c. * tests/mpz/t-gcd.c (main): Use mpz_rrandomb for test operands, not mpz_urandomb. Change copied from gmp-5.0 repo. * tests/mpn/t-hgcd.c (main): Likewise. 2012-02-04 Marco Bodrato * tests/refmpn.c (refmpn_mul): More conservative allocations. 2012-02-03 Torbjorn Granlund * mpn/x86_64/bd1/gmp-mparam.h: New file. * longlong.h (udiv_qrnnd from sdiv_qrnnd): Declare udiv_w_sdiv. * mpn/generic/udiv_w_sdiv.c: Use c89 function header. 2012-02-03 Marco Bodrato * mpz/fac_ui.c: mpz_oddfac_1 removed, with many related functions. * mpz/oddfac_1.c: New file, mpz_oddfac_1 implementation. * gmp-impl.h: mpz_oddfac_1 declaration. * Makefile.am (MPZ_OBJECTS): add mpz/oddfac_1$U.lo . * mpz/Makefile.am (libmpz_la_SOURCES): add oddfac_1.c . * tune/Makefile.am (fac_ui.c): include mpz/oddfac_1.c . 2012-02-02 Marco Bodrato * mpn/generic/toom_interpolate_16pts.c: Correct an unlikely 32-bit bug. 2012-02-02 Torbjorn Granlund * mpn/generic/toom63_mul.c: Allow s+t==n by adjusting an ASSERT. * mpn/generic/toom_interpolate_8pts.c: Perform final incr iff s+t!=n. * tests/mpn/t-toom6h.c (MIN_BN): Make more consistent with ASSERT in tested function. 2012-02-01 Torbjorn Granlund * tests/mpn/t-mul.c: New file. * tests/mpn/Makefile.am: Compile it. 2012-02-01 Marc Glisse * gmpxx.h: Remove check for g++ older than 2.91. 2012-02-01 Niels Möller * mpn/generic/mul.c: Added diagram on where toom functions can be called. 2012-02-01 Marc Glisse * gmpxx.h (__gmp_unary_expr): Make the constructor explicit. (__gmp_expr(__gmp_expr&&)): New move constructors. (__gmp_expr::operator=(__gmp_expr&&)): New move assignments. (swap): Mark as noexcept. (__GMPXX_USE_CXX11): New macro. (__GMPXX_NOEXCEPT): New macro. * tests/cxx/t-cxx11.cc: New file. * tests/cxx/Makefile.am: Added t-cxx11. 2012-01-31 Torbjorn Granlund * mpn/generic/powm_sec.c (SQR_BASECASE_LIM): New name for SQR_BASECASE_MAX. (SQR_BASECASE_LIM, fat variant): Define to read __gmpn_cpuvec. (SQR_BASECASE_LIM, native variant): Define to SQR_TOOM2_THRESHOLD straight, without arithmetic. (mpn_local_sqr): Use BELOW_THRESHOLD as per Marco's suggestion. 2012-01-30 Torbjorn Granlund * tests/mpz/t-powm.c: Ensure all sizes are seen. 2012-01-30 Marc Glisse * gmpxx.h (__gmp_binary_expr): Let things happen in place: d=a+b+c when d != c. * tests/cxx/t-binary.cc: Test variable reuse: c=a+b+c. 2012-01-28 Marc Glisse * gmpxx.h: Don't compute -LONG_MIN. * doc/gmp.texi (gmp_randclass::get_z_bits): Use mp_bitcnt_t. * gmpxx.h: Replace unsigned long with mp_bitcnt_t. 2012-01-27 Torbjorn Granlund * Upgrade to libtool 2.4.2. 2012-01-26 Marco Bodrato * tests/mpz/t-fac_ui.c: Increase default test cases. * mpz/prodlimbs.c: New file, mpz_prodlimbs implementation. * gmp-impl.h: mpz_prodlimbs declaration. * Makefile.am (MPZ_OBJECTS): add mpz/prodlimbs$U.lo . * mpz/Makefile.am (libmpz_la_SOURCES): add prodlimbs.c . (fac_ui.h): remove target (moved up one directory). * mpz/fac_ui.c: mpz_prodlimbs removed, micro-optimisations. 2012-01-25 Torbjorn Granlund * tune/tuneup.c: Remove unused tuneup variables. 2012-01-20 Marco Bodrato * mpz/fac_ui.c: Reduce branches in basecases. 2012-01-18 Marc Glisse * doc/gmp.texi (mpf_class::mpf_class): Use mp_bitcnt_t. 2012-01-17 Torbjorn Granlund * configure.in: Add ultrasparc T4 support. * demos/isprime.c (main): Run 25 millerrabin tests. 2012-01-16 Marco Bodrato * mpz/fac_ui.c (SIEVE_SEED): Define value for small limb size. (mpz_oddswing_1): Reduce the number of divisions. (mpz_oddfac_1): Reduce memory usage. * mpn/minithres/gmp-mparam.h: Correct minimum for FAC_DSC_. * tune/tuneup.c (tune_fac_ui): Likewise. 2012-01-15 Niels Möller * mpz/scan0.c (mpz_scan0): Use ~(mp_bitcnt_t) 0, rather than ULONG_MAX, when returning "infinity". * mpz/scan1.c (mpz_scan1): Likewise. 2012-01-12 Torbjorn Granlund * tests/t-popc.c: Test longer bit strings. 2012-01-12 Marco Bodrato * mpz/divexact.c: Tight realloc, delayed if variables are reused. * mpz/lcm.c: Smaller temp space, avoid goto. * gmp-impl.h (popc_limb): avoid double & (for 8-bits limb). 2012-01-10 Marco Bodrato * mpn/minithres/gmp-mparam.h: New FAC_ODD_ and FAC_DSC_ thresholds. * tune/tuneup.c (tune_fac_ui): Correct minimum for FAC_DSC_. 2012-01-07 Torbjorn Granlund * mpz/mul_2exp.c: Rewrite. * mpz/tdiv_q_2exp.c: Rewrite. 2012-01-05 Marco Bodrato * gen-fac_ui.c: Remove currently unused constants; add new odd double factorial table. * mpz/fac_ui.c (RECURSIVE_PROD_THRESHOLD): Increase default. (mpz_oddfac_1): New function: a merge of _bc_odd and _dsc_odd. (mpz_prodlimbs): More in-place computations. * tune/tuneup.c (tune_fac_ui): min_is_always for FAC_ODD_. 2012-01-02 Marco Bodrato * tune/tuneup.c (tune_fac_ui): Compute FAC_DSC before FAC_ODD. 2011-12-31 Torbjorn Granlund * Makefile.am (fac_ui.h): Put file in top-level dir, not in mpz. 2011-12-31 Marco Bodrato * tune/Makefile.am (fac_ui.c): New target. (nodist_tuneup_SOURCES,CLEANFILES): Add fac_ui.c. * tune/tuneup.c (mpz_fac_ui_tune): Declare prototype. (fac_odd_threshold,fac_dsc_threshold): New global variables. (speed_mpz_fac_ui_tune,tune_fac_ui): New functions. (all): Call tune_fac_ui. * gmp-impl.h (FAC_ODD_THRESHOLD,FAC_DSC_THRESHOLD): New thresholds: default values, and setup for tuning. (FAC_DSC_THRESHOLD_LIMIT): Define (when tuning). * mpz/fac_ui.c (FAC_ODD_THRESHOLD,FAC_DSC_THRESHOLD): Default values removed. 2011-12-30 Torbjorn Granlund * mpz/hamdist.c: Fix typo in a return statement. * mpn/generic/powm_sec.c (SQR_BASECASE_MAX): Set safely from SQR_TOOM2_THRESHOLD. 2011-12-17 Torbjorn Granlund * tests/mpz/t-perfpow.c: Decrease default # of tests. 2011-12-16 Torbjorn Granlund * tests/refmpn.c (AORS_1): Fix typo in variable type. 2011-12-10 Torbjorn Granlund * mpn/generic/sbpi1_bdiv_q.c: Delay quotient limb stores in order to allow quotient and dividend to completely overlap. * mpn/generic/sbpi1_bdiv_qr.c: Likewise. 2011-12-10 Marco Bodrato * mpz/fac_ui.c: fac_bc_ui inlined in fac_ui. 2011-12-08 Torbjorn Granlund * mpn/generic/powm_sec.c: Handle fat binaries better. * mpz/fac_ui.c (mpz_bc_fac_1): Fix typo in allocation size. * mpn/x86/fat/com.c: New file. * mpn/x86_64/pentium4/aors_n.asm: Make it actually work for DOS64. * mpn/x86_64/pentium4/rsh1aors_n.asm: Conditionalise jump on DOS64 to avoid overhead for standard ABIs. * mpn/x86_64/gcd_1.asm: Support DOS64. 2011-12-07 Torbjorn Granlund * configure.in: Fix typo making HAVE_NATIVE_mpn_X fail for fat functions. * mpn/x86_64/fat/fat.c (__gmpn_cpuvec_init): Add a missing break. 2011-12-07 Marco Bodrato * gen-fac_ui.c: Generate two more tables: odd factorial, swing. * mpz/fac_ui.c: Rewrite. 2011-12-06 Niels Möller * mpn/generic/hgcd.c (mpn_hgcd): Use hgcd_reduce for first recursive call. 2011-12-06 Torbjorn Granlund * tune/mod_1_1-1.c: Redefine the mpn_ functions, not __gmpn_ (for the benefit of fat builds). * tune/mod_1_1-2.c: Likewise. 2011-12-05 Torbjorn Granlund * mpn/x86/fat/lshiftc.c: New file. * mpn/x86/fat/mod_1_1.c: New file. * mpn/x86/fat/mod_1_2.c: New file. * mpn/x86/fat/mod_1_4.c: New file. * mpn/x86/fat/diveby3.c: Remove no longer fat function. * mpn/x86_64/fat/diveby3.c: Likewise. * mpn/x86_64/fat/gcd_1.c: Remove since always provided as asm. * mpn/x86_64/fat/mode1o.c: Likewise. * configure.in (fat_functions): Update to more relevant function set. Add special handling for mod_1_N_cps functions. * gmp-impl.h (struct cpuvec_t) : Corresponding changes. Also add vrious declarations for new functions. * mpn/x86/x86-defs.m4 (CPUVEC_FUNCS_LIST): Corresponding changes. * mpn/x86_64/x86_64-defs.m4 (CPUVEC_FUNCS_LIST): Corresponding changes. * mpn/x86/fat/fat.c (__gmpn_cpuvec): Corresponding changes. * mpn/x86_64/fat/fat.c (__gmpn_cpuvec): Corresponding changes. * mpn/x86_64: Port most remaining x86_64 files to DOS64. * mpn/x86_64/coreisbr/aors_n.asm: Add forgotten DOS64_EXIT. * mpn/x86_64/x86_64-defs.m4 (LEA): Handle non-PIC code. * mpn/x86_64/darwin.m4 (LEA): Likewise. 2011-12-04 Torbjorn Granlund * mpn/x86_64/fat/fat.c (MAKE_FMS): Rewrite to handle modern CPUs. * mpn/x86/fat/fat.c (MAKE_FMS): Likewise. * mpn/x86_64/darwin.m4 (PROTECT): Define to potentially useful value. 2011-12-02 Torbjorn Granlund * mpn/x86_64/invert_limb_table.asm: Use PROTECT. * mpn/x86_64/invert_limb.asm: Likewise. * mpn/x86_64/darwin.m4 (PROTECT, IFELF): New defines. * mpn/x86_64/dos64.m4 (PROTECT, IFELF): New defines. * mpn/x86_64/x86_64-defs.m4 (PROTECT, IFELF): New defines. 2011-12-01 Torbjorn Granlund * mpn/x86_64/fat/fat.c: Copy fake cpuid code from x86/fat/fat.c. * mpn/x86_64 (STD64, IFSTD): New names for ELF64, IFELF (since these denote all standard calling conventions). * mpn/x86_64: Add DOS64 ABI support to more files. * mpn/x86_64/mod_1_1.asm: Finish DOS64 support. * mpn/x86_64/mod_1_2.asm: Likewise. * mpn/x86_64/mod_1_4.asm: Likewise. * configure.in: Add GMP_NONSTD_ABI also for fat builds. * mpn/x86_64/fat/fat_entry.asm: Rewrite to support DOS64. * mpn/x86_64/dos64.m4 (IFDOS, IFSTD): New defines. * mpn/x86_64/x86_64-defs (IFDOS, IFSTD): New defines. * mpn/x86_64/dive_1.asm: Add DOS64 ABI support. * mpn/x86_64/mode1o.asm: Likewise. * mpn/x86_64/mod_34lsub1.asm: Enable for DOS64. * mpn/x86_64/invert_limb.asm: Wrap .protected decl. * gmp-impl.h (DECL_divexact_1): Fix typo in return type. * mpn/x86_64/dos64.m4 (LEA): New define. (PIC): Define. 2011-11-29 Torbjorn Granlund * mpn/x86_64: Add DOS64 ABI support to most files. 2011-11-28 Torbjorn Granlund * mpn/x86_64/mul_basecase.asm: Support ABI DOS64. * mpn/x86_64/sqr_basecase.asm: Support ABI DOS64. * mpn/x86_64/aorsmul_1.asm: Support ABI DOS64. * mpn/x86_64/mul_1.asm: Support ABI DOS64. * mpn/x86_64/x86_64-defs.m4 (DOS64_ENTRY, DOS64_EXIT): New, empty defs. * mpn/x86_64/dos64.m4: New file. * mpn/asm-defs.m4 (ABI_SUPPORT): New dummy macro. * configure.in (64-bit mingw/cygwin): Define HOST_DOS64,GMP_NONSTD_ABI. No longer clear out path_64. (mpn code selection loop): Handle GMP_NONSTD_ABI. * mpn/generic/udiv_w_sdiv.c: Use CNST_LIMB for some constants. 2011-11-25 Torbjorn Granlund * x86/*: Many new gmp-mparam.h file for 64-bit CPUs in 32-bit mode. * configure.in: Overhaul x86/x86_64 support, merging three case statements into one. 2011-11-24 Torbjorn Granlund * doc/gmp.texi (Formatted Output Strings): Clarify rules for mpf_t precision. * mpn/powerpc32/p7/gmp-mparam.h: New file. * tune/tuneup.c (tune_mu_div, tune_mu_bdiv): Up min_size to karatsuba's threshold. 2011-11-22 Torbjorn Granlund * mpn/powerpc64/mode64/p6/aorsmul_1.asm: New file. * configure.in: Don't fail fat builds under 64-bit DOS. * mpn/powerpc64/mode64/aors_n.asm: Align loop for slightly better power5 performance. 2011-11-21 Torbjorn Granlund * gmp-h.in (__GNU_MP_RELEASE): Renamed from typo name. 2011-11-20 Torbjorn Granlund * configure.in: Split x86 CPUs into more subtypes for more accurate passing of gcc flags. * mpn/powerpc32/p3-p7/aors_n.asm: New file. * configure.in: Pass -m32 for powerpc64 with abi=32, using via _maybe mechanism. * configure.in: Support powerpc32/p3-p7 directory for affected CPUs. 2011-11-17 Torbjorn Granlund * tune/speed.c (routine): Add mpn_tabselect. * tune/common.c (speed_mpn_tabselect): New function. * tune/speed.h (SPEED_ROUTINE_MPN_COPY_CALL): New macro, made from old SPEED_ROUTINE_MPN_COPY. (SPEED_ROUTINE_MPN_COPY): Just invoke SPEED_ROUTINE_MPN_COPY_CALL. (SPEED_ROUTINE_MPN_TABSELECT): New macro. 2011-11-17 Niels Möller * tune/tuneup.c (tune_hgcd_appr): Increase stop_since_change. 2011-11-16 Torbjorn Granlund * mpn/powerpc32/tabselect.asm: New file. * mpn/powerpc64/mode64/aorscnd_n.asm: New file. 2011-11-15 Niels Möller * tune/speed.h (speed_mpn_hgcd_appr_lehmer): New prototype. (mpn_hgcd_lehmer_itch): Likewise. (mpn_hgcd_appr_lehmer): Likewise. (mpn_hgcd_appr_lehmer_itch): Likewise. (MPN_HGCD_LEHMER_ITCH): Deleted macro. * tune/speed.c (routine): Added mpn_hgcd_appr_lehmer. * tune/common.c (speed_mpn_hgcd_lehmer): Use mpn_hgcd_lehmer_itch rather than similarly named macro. (speed_mpn_hgcd_appr_lehmer): New function. * tune/Makefile.am (libspeed_la_SOURCES): Added hgcd_appr_lehmer.c. * tune/hgcd_appr_lehmer.c: New file. * tune/tuneup.c (tune_hgcd_appr): Increased min_size to 50; some machines got small thresholds which appear to be bogus. 2011-11-15 Torbjorn Granlund * mpn/generic/powm_sec.c (mpn_local_sqr): Remove forgotten TMP_* calls. (redcify): Likewise. (mpn_powm_sec): Likewise. * mpn/generic/powm_sec.c (mpn_powm_sec): Rework scratch usage (mpn_powm_sec_itch): Rewrite. * mpn/generic/powm_sec.c (mpn_powm_sec): Use mpn_tabselect also in initialisation. * configure.in: Amend 2011-11-03 gcc_cflags change. * mpn/powerpc64/tabselect.asm: New file. * mpn/x86_64/tabselect.asm: New file. * mpn/x86/tabselect.asm: New file. * mpn/ia64/tabselect.asm: New file. * mpn/asm-defs.m4 (define_mpn): Add tabselect. * configure.in (gmp_mpn_functions): Add tabselect. (HAVE_NATIVE): Add entries for addncd_n, subcnd_n, tabselect. * mpn/generic/powm_sec.c: Remove mpn_tabselect implementation. * mpn/generic/tabselect.c: New file with removed code. 2011-11-13 Torbjorn Granlund * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add powm_sec.c. * mpn/generic/powm_sec.c (win_size): Use POWM_SEC_TABLE (POWM_SEC_TABLE): Define default. * tune/tuneup.c (tune_powm_sec): New function computing POWM_SEC_TABLE. (all): Call new function. * mpn/generic/powm_sec.c (win_size): Define only when TUNE_PROGRAM_BUILD is not set. 2011-11-13 Niels Möller * tune/tuneup.c (tune_hgcd_appr): Use default min_size. (tune_hgcd_reduce): Increase max_size and step_factor, to 7000 and 0.04, respectively. 2011-11-11 Torbjorn Granlund * mpn/powerpc64/mode64/sqr_diag_addlsh1.asm: Remove. 2011-11-11 Niels Möller * tune/hgcd_reduce_2.c: New file. * tune/hgcd_reduce_1.c: New file. * tune/tuneup.c (hgcd_appr_threshold): New threshold variable. (hgcd_reduce_threshold): Likewise. (tune_hgcd_appr): New function. (tune_hgcd_reduce): New function. (all): Call tune_hgcd_appr and tune_hgcd_reduce. * tune/speed.h (speed_mpn_hgcd_reduce): Declaration. (speed_mpn_hgcd_reduce_[12]): Likewise. (mpn_hgcd_reduce_[12]): Likewise. (SPEED_ROUTINE_MPN_HGCD_REDUCE_CALL): New macro. * tune/speed.c (routine): Added mpn_hgcd_reduce, mpn_hgcd_reduce_1, and mpn_hgcd_reduce_2. * tune/common.c (speed_mpn_hgcd_reduce): New function. (speed_mpn_hgcd_reduce_[12]): Likewise. * tune/Makefile.am (libspeed_la_SOURCES): Added hgcd_reduce_1.c hgcd_reduce_2.c. (TUNE_MPN_SRCS_BASIC): Added hgcd_appr.c and hgcd_reduce.c. * mpn/generic/hgcd_appr.c (submul, hgcd_matrix_apply): Deleted functions, earlier copied to hgcd_reduce.c. (mpn_hgcd_appr): Use hgcd_reduce. 2011-11-09 Torbjorn Granlund * mpn/powerpc64/mode64/sqr_basecase.asm: New file. * mpn/x86_64/aorscnd_n.asm: New file. * tune/speed.c (routine): Add measuring of mpn_addcnd_n, mpn_subcnd_n. * tune/common.c (speed_mpn_addcnd_n,speed_mpn_subcnd_n): New functions. * tune/speed.h: Declare them. * tests/devel/try.c: Add tests for mpn_addcnd_n and mpn_subcnd_n. * tests/refmpn.c (refmpn_addcnd_n, refmpn_subcnd_n): New functions. * tests/tests.h: Declare them. * configure.in (gmp_mpn_functions): Add addcnd_n and subcnd_n. 2011-11-07 Torbjorn Granlund * mpn/generic/redc_1.c: Just reduce U operand using Hensel norm, but not fully canonically; leave add_n and conditional sub_n to caller. Therefore omit R argument. * mpn/generic/redc_1_sec.c: Remove. * gmp-impl.h (mpn_redc_1): Update declaration. (mpn_redc_1_sec): Remove declaration. * configure.in (gmp_mpn_functions): Remove redc_1. * mpn/x86_64/redc_1.asm: Adopt to new defined functionality/interface. * tune/speed.h (SPEED_ROUTINE_REDC_1): Likewise. * tests/refmpn.c (refmpn_redc_1): Likewise; also call refmpn_addmul_1 instead of mpn_addmul_1. * mpn/generic/powm.c (MPN_REDC_1): New macro, use for mpn_redc_1. * mpn/generic/powm_sec.c (MPN_REDC_1_SEC): New macro, use for mpn_redc_1_sec. 2011-11-03 Torbjorn Granlund * dumbmp.c (mpz_sub): Abort for non-handled case. * mpn/powerpc64/mode64/lshiftc.asm: Move file from here... * mpn/powerpc64/lshiftc.asm: ...to here, with trivial modifications. * configure.in: Pass -m32 in more cases, using _maybe mechanism. Inherit default gcc_cflags in more places. * mpn/powerpc64/mode64/p7/gmp-mparam.h: New file. 2011-11-02 Torbjorn Granlund * mpn/s390_64/invert_limb.asm: Slight optimisation. * configure.in (s390): Set gcc_32_cflags_maybe. * mpn/s390_32/gmp-mparam.h: Put in proper data. * mpn/s390_32/esame/gmp-mparam.h: New file. * mpn/x86_64/bobcat/gmp-mparam.h: New file. * mpn/s390_32/lshift.asm: New file. * mpn/s390_32/rshift.asm: New file. * mpn/s390_32/lshiftc.asm: New file. 2011-10-31 Torbjorn Granlund * mpn/powerpc64/sqr_diagonal.asm: Move from here... * mpn/powerpc64/mode32/sqr_diagonal.asm: ...to here. * mpn/powerpc64/mode64/sqr_diag_addlsh1.asm: New file. * mpn/s390_64/sqr_basecase.asm: Rewrite sqr_diag_addlsh1 code. * mpn/s390_32/esame/sqr_basecase.asm: Likewise. 2011-10-29 Torbjorn Granlund * mpn/s390_64/lshift.asm: Complete rewrite. * mpn/s390_64/rshift.asm: Likewise. * mpn/s390_64/lshiftc.asm: New file. 2011-10-28 Torbjorn Granlund * mpn/s390_32/esame/aors_n.asm: New file, with rewritten add/sub code. 2011-10-27 Torbjorn Granlund From Per Olofsson: * gmp-impl.h (BSWAP_LIMB): Rename variable to avoid BSWAP_LIMB_FETCH clash. * mpn/s390_32/esame/mul_basecase.asm: New file. * mpn/s390_32/esame/sqr_basecase.asm: New file. * mpn/s390_32/logops_n.asm: New file. * mpn/s390_64/logops_n.asm: Fix rp=up code. Remove a leftover insn. 2011-10-26 Niels Möller * gmp-impl.h (mpn_hgcd_reduce, mpn_hgcd_reduce_itch): Added prototypes. (HGCD_APPR_THRESHOLD): Set up threshold for tuning. (HGCD_REDUCE_THRESHOLD): Likewise. * configure.in (gmp_mpn_functions): Added hgcd_reduce. * mpn/generic/hgcd_reduce.c: New file. 2011-10-24 Torbjorn Granlund * mpn/x86_64/sqr_basecase.asm: Put intermediate result into R, don't allocate any stack space. 2011-10-23 Torbjorn Granlund * mpn/s390_64/logops_n.asm: Use nc, oc, xc when possible. * tune/common.c (speed_mpn_and_n, speed_mpn_andn_n, etc): Pass correct input args. * mpn/s390_64/mod_34lsub1.asm: Use llgfr for zero extensions. * mpn/s390_64/mul_basecase.asm: New file. * mpn/s390_64/sqr_basecase.asm: New file. * mpn/s390_64/sqr_diag_addlsh1.asm: Removed, lives on in sqr_basecase. * mpn/s390_64/bdiv_dbm1c.asm: Shave off 1 c/l. * mpn/s390_64/aorrlsh1_n.asm: New file, developed from aorslsh1_n.asm. * mpn/s390_64/sublsh1_n.asm: New file. * mpn/s390_64/aorslsh1_n.asm: Remove file. 2011-10-22 Torbjorn Granlund * mpn/s390_64/logops_n.asm: New file. * mpn/s390_64/aors_n.asm: New file, with rewritten add/sub code. 2011-10-20 Torbjorn Granlund * tune/speed.h (SPEED_ROUTINE_MPN_SQR_DIAL_ADDLSH1_CALL): New macro. * tune/common.c (speed_mpn_sqr_diag_addlsh1): New function. * tune/speed.c (routine): Measure mpn_sqr_diag_addlsh1. * mpn/s390_64/sqr_diag_addlsh1.asm: Rewrite like s390_32/esame code. * mpn/s390_32/esame/sqr_diag_addlsh1.asm: Save just needed registers. 2011-10-19 Torbjorn Granlund * mpn/s390_32/esame/add_n.asm: Rewrite, similar to s390_64 code. * mpn/s390_32/esame/add_n.asm: Likewise. 2011-10-17 Torbjorn Granlund * mpn/s390_32/esame/aorslsh1_n.asm: New file. 2011-10-16 Torbjorn Granlund * mpn/s390_32/esame/sqr_diag_addlsh1.asm: New file. * mpn/s390_32/copyi.asm: New file. * mpn/s390_32/copyd.asm: New file. * mpn/s390_64/copyd.asm: Optimise. * mpn/s390_64/copyi.asm: Rewrite along the lines of glibc memcpy. * mpn/s390_64/aorslsh1_n.asm: New file. * mpn/s390_64/mod_34lsub1.asm: New file. * mpn/s390_64/sqr_diag_addlsh1.asm: New file. 2011-10-15 Torbjorn Granlund * configure.in (s390): Rewrite support to handle known CPUs. * config.guess: Recognise s390 CPUs. * config.sub: Match s390 CPUs. * acinclude.m4 (S390_PATTERN, S390X_PATTERN): New defines. 2011-10-14 Torbjorn Granlund From Per Olofsson: * mpn/generic/popham.c: Add __GMP_NOTHROW to make it match gmp.h. * mpn/generic/gcd_1.c: Separate declarations and initialisers for the benefit of C++. * configure.in: AC_DEFINE HAVE_HOST_CPU_s390_zarch. * longlong.h (s390): Use it. (s390 umul_ppmm): Fix typo in pure C variant. 2011-10-13 Torbjorn Granlund * longlong.h (s390): Put back an accidentally deleted #else. * configure.in (s390): Unset extra_functions for s390x. 2011-10-12 Torbjorn Granlund * mpn/s390_64/lshift.asm: Reduce register usage. * mpn/s390_64/rshift.asm: Likewise. * longlong.h (s390 umul_ppmm): With new-enough gcc, avoid asm. From Andreas Krebbel: * longlong.h (s390 umul_ppmm): Support 32-bit limbs with gcc using 64-bit registers. (s390 udiv_qrnnd): Likewise. 2011-10-11 Torbjorn Granlund * configure.in (s390x): Pass -mzarch to gcc in 32-bit mode. * longlong.h (s390x): Add __CLOBBER_CC for relevant asm patterns. * mpn/generic/mod_1_1.c (s390x add_mssaaaa): Likewise. * mpn/s390_64/copyd.asm: New file. 2011-10-10 Niels Möller * mpn/generic/hgcd_appr.c: Deleted debugging code. * tests/mpn/t-hgcd_appr.c (main): Added -v flag. (hgcd_appr_valid_p): Increased margin of non-minimality for divide-and-conquer algorithm. Display bit counts only if -v is used. * mpn/generic/hgcd_appr.c (submul): New (static) function. (hgcd_matrix_apply): New function. (mpn_hgcd_appr_itch): Account for divide-and-conquer algorithm. (mpn_hgcd_appr): Implemented divide-and-conquer. 2011-10-10 Torbjorn Granlund * mpn/generic/mod_1_1.c (add_mssaaaa): Add s390x variant. Put arm code inside __GNUC__. * tune/time.c (STCK): Use proper memory constraint. From Marco Trudel: * tests/mpz/t-scan.c (check_ref): Fix loop end bound. 2011-10-10 Niels Möller * gmp-impl.h: (HGCD_APPR_THRESHOLD): New threshold. * mpn/generic/hgcd_appr.c (mpn_hgcd_appr): Interface change. Destroy inputs, let caller make working copies if needed. (mpn_hgcd_appr_itch): Reduced scratch need. * gmp-impl.h: Updated mpn_hgcd_appr prototype. * tests/mpn/t-hgcd_appr.c (one_test): Make working copies for hgcd_appr. * tune/common.c (speed_mpn_hgcd_appr): Use SPEED_ROUTINE_MPN_HGCD_CALL. * tune/speed.h (SPEED_ROUTINE_MPN_HGCD_APPR_CALL): Deleted. 2011-10-09 Torbjorn Granlund * mpn/s390_64/copyi.asm: New file. * mpn/s390_64/lshift.asm: New file. * mpn/s390_64/rshift.asm: New file. * mpn/s390_64/add_n.asm: Rewrite using lmg/stmg. * mpn/s390_64/sub_n.asm: Likewise. * mpn/s390_64/invert_limb.asm: Save a callee-saves register less. * tune/time.c (getrusage_backwards_p): Properly cast printed values. * longlong.h (s390x): Put back UDItype casts to make gcc reloading use right more for constants. (s390x count_leading_zeros): Disable until we support z10 specifically. (s390x add_ssaaaa): Remove algsi/slgsi until we support z10. 2011-10-09 Niels Möller * mpn/generic/hgcd_matrix.c (mpn_hgcd_matrix_adjust): Declare matrix argument const. 2011-10-08 Niels Möller * tests/mpn/t-hgcd_appr.c (hgcd_appr_valid_p): Adjusted the allowed margin of non-minimality for hgcd_appr. * mpn/generic/hgcd_appr.c (mpn_hgcd_appr): Fixed handling of extra_bits, starting at zero, to ensure that we don't produce too small remainders. Added a final reduction loop when we we otherwise terminate with extra_bits > 0, to make the returned remainders closer to minimal. 2011-10-07 Torbjorn Granlund * longlong.h (s390): Add 32-bit zarch umul_ppmm and udiv_qrnnd. (s390): Overhaul 32-bit and 64-bit code. 2011-10-07 Niels Möller * tune/speed.h (speed_mpn_hgcd_appr): New prototype. (SPEED_ROUTINE_MPN_HGCD_APPR_CALL): New macro. * tune/common.c (speed_mpn_hgcd_appr): New function. * tune/speed.c (routine): Added mpn_hgcd_appr. * tests/mpn/t-hgcd_appr.c: New file. * tests/mpn/Makefile.am (check_PROGRAMS): Added t-hgcd_appr. * configure.in (gmp_mpn_functions): Added hgcd_step and hgcd_appr. * gmp-impl.h: Added prototypes for mpn_hgcd_step, mpn_hgcd_appr_itch and mpn_hgcd_appr. * mpn/generic/hgcd_appr.c: New file. * mpn/generic/hgcd_step.c: New file, extracted from hgcd.c. (mpn_hgcd_step): Renamed, from... * mpn/generic/hgcd.c (hgcd_step): ...old name. Renamed and moved to hgcd_step.c. (hgcd_hook): Also moved to hgcd_step.c. (mpn_hgcd): Updated for hgcd_step renaming. 2011-10-06 Torbjorn Granlund * mpn/s390_64/invert_limb.asm: New file. 2011-10-04 Torbjorn Granlund * mpn/s390_64/submul_1.asm: New file. * mpn/s390_32/esame/submul_1.asm: New file. * mpn/generic/mulmid.c (mpn_mulmid): Move a TMP_DECL to block start. * mpn/Makefile.am (TARG_DIST): Add s390_32 and s390_64, remove s390 and z8000x. * doc/gmp.texi (Custom Allocation): Rephrase a paragraph. * demos/factorize.c: Run 25 Miller-Rabin tests. * mpz/nextprime.c: Run 25 mpz_millerrabin tests (was 10). 2011-10-03 Torbjorn Granlund * configure.in: Support s390x. * longlong.h: Add support for 64-bit s390x. * mpn/s390_64: New directory. * mpn/s390_64/add_n.asm: New file. * mpn/s390_64/sub_n.asm: New file. * mpn/s390_64/mul_1.asm: New file. * mpn/s390_64/addmul_1.asm: New file. * mpn/s390_64/bdiv_dbm1c.asm: New file. * mpn/s390_64/gmp-mparam.h: New file, taken from x86_64. * mpn/s390_32: Directory renamed from mpn/s390. * mpn/s390_32/gmp-mparam.h: New file, taken from x86_64. * mpn/s390_32/esame/add_n.asm: New file. * mpn/s390_32/esame/sub_n.asm: New file. * mpn/s390_32/esame/mul_1.asm: New file. * mpn/s390_32/esame/addmul_1.asm: New file. * mpn/s390_32/esame/bdiv_dbm1c.asm: New file. 2011-10-03 Niels Möller * tests/mpn/Makefile.am (check_PROGRAMS): Added t-mulmid. * tests/mpn/t-mulmid.c: New file. mulmid-related assembly for x86_64, from David Harvey: * mpn/asm-defs.m4 (define_mpn): Added [add,sub]_err[1,2,3]_n and mulmid_basecase. Also use m4_not_for_expansion on the corresponding OPERATION_* symbols. * mpn/x86_64/aors_err1_n.asm: New file. * mpn/x86_64/aors_err2_n.asm: Likewise. * mpn/x86_64/aors_err3_n.asm: Likewise. * mpn/x86_64/mulmid_basecase.asm: Likewise. * mpn/x86_64/core2/aors_err1_n.asm: Likewise. * mpn/x86_64/gmp-mparam.h (MULMID_TOOM42_THRESHOLD): New value. * mpn/x86_64/core2/gmp-mparam.h (MULMID_TOOM42_THRESHOLD): Likewise. Tuning of mulmid, from David Harvey: * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Added mulmid.c mulmid_n.c toom42_mulmid.c. * tune/speed.h: Prototypes for mulmid-related functions. (struct speed_params): Increased max number of sources to 5. (SPEED_ROUTINE_MPN_BINARY_ERR_N_CALL): New macro. (SPEED_ROUTINE_MPN_BINARY_ERR1_N): Likewise. (SPEED_ROUTINE_MPN_BINARY_ERR2_N): Likewise. (SPEED_ROUTINE_MPN_BINARY_ERR3_N): Likewise. (SPEED_ROUTINE_MPN_MULMID): Likewise. (SPEED_ROUTINE_MPN_MULMID_N): Likewise. (SPEED_ROUTINE_MPN_TOOM42_MULMID): Likewise. * tune/common.c (mpn_[add,sub]_err[1,2,3]_n): New functions. (speed_mpn_mulmid_basecase): New function. (speed_mpn_mulmid): New function. (speed_mpn_mulmid_n): New function. (speed_mpn_toom42_mulmid): New function. * tune/speed.c (routine): Added mpn_[add,sub]_err[1,2,3]_n, mpn_mulmid_basecase, mpn_toom42_mulmid, mpn_mulmid_n, and mpn_mulmid. * tune/tuneup.c (mulmid_toom42_threshold): New threshold variable. (tune_mulmid): New function. (all): Call tune_mulmid. Testing of mulmid, from David Harvey: * tests/refmpn.c (AORS_ERR1_N): New macro. (refmpn_add_err1_n, refmpn_sub_err1_n): New functions. (AORS_ERR2_N): New macro. (refmpn_add_err2_n, refmpn_sub_err2_n): New functions. (AORS_ERR3_N): New macro. (refmpn_add_err3_n, refmpn_sub_err3_n): New functions. (refmpn_mulmid_basecase): New function. (refmpn_toom42_mulmid): New function, wrapper for refmpn_mulmid_basecase. (refmpn_mulmid_n): Likewise. (refmpn_mulmid): Likewise. * tests/tests.h: Prototypes for new functions. * tests/devel/try.c (NUM_SOURCES): Increased to 5. (struct try_t): Use NUM_SOURCES and NUM_DESTS constants. (SIZE_4, SIZE_6, SIZE_DIFF_PLUS_3, SIZE_ODD): New constants. (OVERLAP_NOT_DST2): New flag. (param_init): New mulmid-related operation types. (mpn_toom42_mulmid_fun): New function. (choice_array): Added mulmid-related entries. (overlap_array): Extended for larger NUM_SOURCES. (OVERLAP_COUNT): Handle OVERLAP_NOT_DST2. (call): Support mulmid-related functions. (pointer_setup): Handle SIZE_4, SIZE_6, and SIZE_DIFF_PLUS_3. (SIZE_ITERATION): Handle SIZE_ODD. (SIZE2_FIRST): Handle SIZE_CEIL_HALF. (SIZE2_LAST): Likewise. Implementation of mulmid, from David Harvey: * mpn/generic/add_err1_n.c (mpn_add_err1_n): New file and function. * mpn/generic/add_err2_n.c (mpn_add_err2_n): Likewise. * mpn/generic/add_err3_n.c (mpn_add_err3_n): Likewise. * mpn/generic/sub_err1_n.c (mpn_sub_err1_n): Likewise. * mpn/generic/sub_err2_n.c (mpn_sub_err2_n): Likewise. * mpn/generic/sub_err3_n.c (mpn_sub_err3_n): Likewise. * mpn/generic/mulmid_basecase.c (mpn_mulmid_basecase): Likewise. * mpn/generic/mulmid_n.c (mpn_mulmid_n): Likewise. * mpn/generic/toom42_mulmid.c (mpn_toom42_mulmid): Likewise. * configure.in (gmp_mpn_functions): Added mulmid-related functions. (GMP_MULFUNC_CHOICES): Handle aors_err1_n, aors_err2_n, and aors_err3_n. * gmp-impl.h: Added prototypes for mulmid functions. (MPN_TOOM42_MULMID_MINSIZE): New constant. (MULMID_TOOM42_THRESHOLD): New threshold. (mpn_toom42_mulmid_itch): New macro. 2011-10-03 Niels Möller * tune/tune-gcd-p.c (main): Fixed broken loop conditions. 2011-09-26 Torbjorn Granlund * mpn/sh/sh2/submul_1.asm: Make this old submul_1 implementation actually compute intended function. * longlong.h (SH): Recognise predefs for all SH processors as defined by current gcc versions. 2011-09-25 Torbjorn Granlund * mpn/sh: Migrate files to '.asm'. * configure.in: Recognise sh3 and sh4. 2011-09-21 Marc Glisse * gmpxx.h (mpz_class::swap): New function. (mpq_class::swap): Likewise. (mpf_class::swap): Likewise. (swap): New function. * tests/cxx/t-assign.cc: Test the above. * doc/gmp.texi (swap): Document the above. 2011-08-21 Marc Glisse * tests/cxx/t-ops2.cc: check mul-div by 2. * gmpxx.h (__GMPXX_CONSTANT): New macro (__builtin_constant_p). (__gmp_binary_lshift): Move before multiplication. Optimize x << 0. (__gmp_binary_rshift): Move before division. Optimize x >> 0. (__gmp_binary_plus): Optimize x + 0. Rewrite rational + integer. (__gmp_binary_minus): Optimize x - 0 and 0 - x. Rewrite rational - integer. (__gmp_binary_multiplies): Optimize x * 2^n. (__gmp_binary_divides): Optimize x / 2^n. (__gmp_binary_*): Deduplicate code for symmetric operations. 2011-08-18 Torbjorn Granlund * printf/doprntf.c (__gmp_doprnt_mpf): For DOPRNT_CONV_FIXED, ask for one more digit. 2011-08-17 Torbjorn Granlund * mpf/sub.c: Fix typo in copy condition. Delay an allocation. 2011-08-12 Torbjorn Granlund * gmp-impl.h (LIMBS_PER_DIGIT_IN_BASE): Fix typo. 2011-08-10 Torbjorn Granlund * gmp-impl.h (DIGITS_IN_BASEGT2_FROM_BITS): New. (DIGITS_IN_BASE_FROM_BITS): Compute more accurate result. (MPN_SIZEINBASE): Use DIGITS_IN_BASEGT2_FROM_BITS. * tests/rand/t-lc2exp.c (check_bigc): Call abort after reporting error. 2011-08-09 Torbjorn Granlund * mpz/out_str.c (mpz_out_str): Reinsert accidentally deleted str_size adjustment. * gmp-impl.h (DIGITS_IN_BASE_FROM_BITS): Simplify, also avoiding overflow for base 2. 2011-08-07 Torbjorn Granlund * gmp-impl.h (struct bases): Add log2b and logb2 field, remove chars_per_limb_exactly field. (DIGITS_IN_BASE_FROM_BITS): New. (DIGITS_IN_BASE_PER_LIMB): New. (LIMBS_PER_DIGIT_IN_BASE): New. * gen-bases.c: Generate log2b and logb2 fields; do not generate chars_per_limb_exactly field. * mpf/get_str.c mpf/out_str.c mpf/set_str.c mpn/generic/get_str.c mpn/generic/sizeinbase.c mpq/get_str.c mpz/inp_str.c mpz/out_str.c mpz/set_str.c printf/doprntf.c tune/speed.h tune/tuneup.c: Use new macros. 2011-08-04 Torbjorn Granlund * dumbmp.c (mpz_root): Reinsert accidentally removed line. 2011-08-03 Torbjorn Granlund * dumbmp.c (mpz_tdiv_qr): Correctly handle dividend value being equal to divisor value. (mpz_root): Create reasonable starting approximation. (mpz_sqrt): New function. (mpz_mul_2exp): Add faster block shifting code, disabled for now. 2011-07-15 Torbjorn Granlund * mpn/arm/invert_limb.asm: Swap around some registers to silence 'as' warnings. 2011-07-14 Torbjorn Granlund * mpn/generic/dcpi1_bdiv_q.c (mpn_dcpi1_bdiv_q): Get mpn_sub_1 size argument right. 2011-07-04 Torbjorn Granlund * tests/misc/t-locale.c: Disable test for mingw. * configure.in (x86_64 *-*-mingw*): Handle also cygwin here; clear out extra_functions_64. 2011-07-02 Torbjorn Granlund * config.guess: Don't print newline in x86 cpuid function. Rewrite x86-64 cpu recognition asm code to work under Windoze. 2011-06-16 Torbjorn Granlund * acinclude.m4 (GMP_ASM_RODATA): Fix typo in 2011-04-20 change. * configure.in: Surround tr ranges with [] for portability. 2011-05-25 Niels Möller * tune/tune-gcd-p.c (search): New function to search for minimum. (main): Replaced slow linear search. 2011-05-24 Niels Möller * tune/Makefile.am (EXTRA_PROGRAMS): Added tune-gcd-p. Also added related automake variables. * mpn/Makefile.am (tune-gcd-p): Deleted target. * tune/tune-gcd-p.c: New file, extracted from mpn/generic/gcd.c and updated. * mpn/generic/gcd.c: Deleted the corresponding code, including main function. 2011-05-23 Niels Möller * mpz/jacobi.c (mpz_jacobi): Simplified by swapping operands when needed, to get asize >= bsize. Use the reciprocity law generalized to work when one operand is even. 2011-05-22 Niels Möller * mpz/jacobi.c (mpz_jacobi): Another bugfix for the asize == 1 case. Sometimes, powers of two in b were taken into account twice. 2011-05-21 Niels Möller * mpz/jacobi.c (mpz_jacobi): The handling of asize == 1 was broken. Rewrote it. * tests/mpz/t-jac.c (mpz_nextprime_step): Sanity check that prime candidate and step has no common factor. (check_data): Added some test cases related to the asize == 1 case in mpz_jacobi. 2011-05-20 Niels Möller * gmp-impl.h: Jacobi-related prototypes. * configure.in (gmp_mpn_functions): Added jacobi_2, jacobi, hgcd2_jacobi, hgcd_jacobi, and removed jacobi_lehmer. * mpz/jacobi.c (STRIP_TWOS): Deleted macro. (mpz_jacobi): Partially rewritten, to no longer makes the A operand odd. Use new mpn_jacobi_n. * mpn/generic/jacobi_lehmer.c: Deleted file. * mpn/generic/jacobi.c (mpn_jacobi_n): New subquadratic jacobi implementation. Supersedes jacobi_lehmer.c. * mpn/generic/hgcd_jacobi.c (mpn_hgcd_jacobi): New file and function. A copy of mpn_hgcd, using mpn_hgcd2_jacobi, and with calls to mpn_jacobi_update when appropriate. * mpn/generic/jacobi_2.c (mpn_jacobi_2): New file. Extracted from jacobi_lehmer.c. * mpn/generic/hgcd2_jacobi.c (mpn_hgcd2_jacobi): Likewise. * mpn/generic/hgcd.c (hgcd_hook): Avoid using NULL. 2011-05-19 Niels Möller * tune/hgcd_lehmer.c (__gmpn_hgcd_itch): Don't rename symbols for the functions moved to hgcd_matrix.c. * configure.in (gmp_mpn_functions): Added hgcd_matrix. * mpn/generic/hgcd.c (hgcd_matrix_update_1): Deleted. Several other helper functions moved to hgcd_matrix.c, see below. (hgcd_hook): New function. (hgcd_step): Simplified, using mpn_gcd_subdiv_step and hgcd_hook. * mpn/generic/hgcd_matrix.c: New file. (mpn_hgcd_matrix_init): Moved here, from hgcd.c. (mpn_hgcd_matrix_update_q): Likewise. (mpn_hgcd_matrix_mul_1): Likewise. (mpn_hgcd_matrix_mul): Likewise. (mpn_hgcd_matrix_adjust): Likewise. * mpn/generic/gcd_subdiv_step.c (mpn_gcd_subdiv_step): New argument s, for use by hgcd. * gmp-impl.h (mpn_gcd_subdiv_step): Update declaration. * mpn/generic/gcd.c (mpn_gcd): Pass s = 0 to mpn_gcd_subdiv_step. * mpn/generic/gcdext.c (mpn_gcdext): Likewise. Also added an ASSERT. * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Likewise. (mpn_gcdext_hook): Added some ASSERTs. * mpn/generic/jacobi_lehmer.c (mpn_jacobi_lehmer): Likewise. 2011-05-17 Niels Möller * doc/gmp.texi (mpn_gcd, mpn_gcdext): Document input requirements: Must have un >= vn > 0, and V normalized. * mpn/generic/gcdext.c (mpn_gcdext): Added ASSERT for input normalization. * mpn/generic/gcd.c (mpn_gcd): Added ASSERTs for input requirements. 2011-05-15 Marc Glisse * gmpxx.h (operator<<): Dedup. * tests/cxx/t-iostream.cc: Test on compound types. * gmpxx.h (__gmp_binary_expr): Let things happen in place: c=(a+b)/2. 2011-05-10 Marc Glisse * gmpxx.h (__gmp_unary_expr): Let things happen in place: c=-(a+b). (operator>>): Clean the commenting out. * tests/cxx/t-iostream.cc: New file. * tests/cxx/Makefile.am: Added t-iostream. 2011-05-10 Niels Möller * doc/gmp.texi (mpz_gcd): Document that gcd(0,0) = 0. (mpz_gcdext): Document range for cofactors. 2011-05-09 Niels Möller * mpz/gcdext.c (mpz_gcdext): Increased sp allocation to bsize+1 limbs. * doc/gmp.texi (mpn_gcdext): Fixed documentation of allocation requirements; one extra limb is still needed for S. 2011-05-09 Torbjorn Granlund * mpn/x86/fat/gmp-mparam.h (BMOD_1_TO_MOD_1_THRESHOLD): Define. * mpn/x86_64/fat/gmp-mparam.h (BMOD_1_TO_MOD_1_THRESHOLD): Define. 2011-05-08 Marc Glisse * gmpxx.h: Replace unsigned long with mp_bitcnt_t in many places. * doc/gmp.texi: Likewise. 2011-05-06 Marc Glisse * gmpxx.h (mpz_class): Make constructor from mp[qf]_class explicit. (mpq_class): Make constructor from mpf_class explicit. * doc/gmp.texi: Document the above. * NEWS: Likewise, and mention the EOF istream fix. * tests/cxx/t-mix.cc: New file. * tests/cxx/Makefile.am: Added t-mix. * tests/cxx/t-assign.cc: Minor tweak. * tests/cxx/t-misc.cc: Likewise. * gmpxx.h (__gmp_resolve_temp): Remove. (__gmp_set_expr): Remove some overloads. (mpq_class): mpz_init_set the numerator and denominator instead of mpq_init + mpq_set. (mpz_class): Dedup the string constructors. (mpq_class): Likewise. * tests/cxx/t-ops3.cc: New file. * tests/cxx/Makefile.am: Added t-ops3. 2011-05-05 Torbjorn Granlund * mpz/gcdext.c: Correct sgn computation. Use MPZ_REALLOC. 2011-05-05 Marc Glisse * mpn/x86_64/fat/fat.c: Update for Sandy Bridge. * config.guess: warning to keep it in sync with fat.c. 2011-05-05 Torbjorn Granlund * mpn/x86_64/fat/fat_entry.asm (PIC_OR_DARWIN): New symbol. Use it to work around Darwin problems. 2011-05-04 Niels Möller * mpz/gcdext.c (mpz_gcdext): Reduced temporary allocations. Use mpz_divexact when computing the second cofactor. 2011-05-03 David Harvey * configure.in: make invert_limb_table work correctly with --disable-assembly (from Niels Möller) 2011-05-02 Marc Glisse * .bootstrap: libtoolize doesn't need -c. * configfsf.guess: Update to version of 2011-02-02. * configfsf.sub: Update to version of 2011-03-23. 2011-05-02 Niels Möller * mpz/gcdext.c (mpz_gcdext): Don't allocate extra limbs at the end of mpn_gcdext parameters. * doc/gmp.texi (mpn_gcdext): Updated doc. 2011-05-01 Niels Möller * mpn/generic/div_qr_2u_pi1.c (mpn_div_qr_2u_pi1): Fixed ASSERT. 2011-04-30 Marc Glisse * gmp-h.in (mpz_cdiv_q_2exp): Use mp_bitcnt_t to match the definition and the documentation. (mpz_remove): Likewise. (mpf_eq): Likewise. * ltmain.sh: Remove. * .bootstrap: Let libtoolize generate ltmain.sh. * tests/cxx/t-ops2.cc: Add a couple tests. * tests/cxx/t-rand.cc: Likewise. * doc/gmp.texi (mpf_urandomb): Explicit the fact that it does not change the precision. * gmp-h.in (__GMP_EXTERN_INLINE): Recent g++ uses gnu_inline. 2011-04-28 Torbjorn Granlund * configure.in (x86_64): Support bobcat specifically. (x86): Match bobcat and bulldozer, handle like k10. 2011-04-28 David Harvey * README.HG: update autotools version numbers. 2011-04-27 Torbjorn Granlund * tune/speed.h (speed_cyclecounter): Always use PIC variant when compiled with Apple's GCC. * mpn/x86/darwin.m4 (LEA): Complete rewrite. (m4append): New macro. 2011-04-26 Torbjorn Granlund * mpn/sparc32/sparc-defs.m4 (changecom): Don't redefine '!' as it interferes with expressions. 2011-04-20 Torbjorn Granlund * acinclude.m4 (GMP_ASM_RODATA): Make 'foo' larger to avoid clang problems. 2011-04-12 Niels Möller * mpn/x86_64/invert_limb.asm [PIC]: Declare mpn_invert_limb_table as .protected. 2011-04-11 Torbjorn Granlund * mpn/x86/k7/invert_limb.asm: Use deflit for Darwin bug workaround. Undo 2011-03-28 change. * mpn/asm-defs.m4 (define_mpn): Use deflit. 2011-04-10 Niels Möller * mpn/asm-defs.m4 (define_mpn): Added invert_limb_table. * configure.in: Add invert_limb_table to extra_functions_64 on x86_64. * mpn/x86_64/invert_limb.asm: Changed references from approx_tab mpn_invert_limb_table. * mpn/x86_64/invert_limb_table.asm (mpn_invert_limb_table): New file. Extracted approximation table from invert_limb.asm, renamed and made global. 2011-03-30 Niels Möller * mpn/x86_64/div_qr_2u_pi1.asm: New file. * configure.in (gmp_mpn_functions): Add div_qr_2u_pi1. * gmp-impl.h (mpn_div_qr_2u_pi1): Declare. * mpn/generic/div_qr_2u_pi1.c (mpn_div_qr_2u_pi1): Moved to separate file, from... * mpn/generic/div_qr_2.c: ... old location. * mpn/generic/div_qr_2n_pi1.c: Renamed file, from... * mpn/generic/div_qr_2_pi1_norm.c: ...old name. * mpn/x86_64/div_qr_2n_pi1.asm: Renamed file, from... * mpn/x86_64/div_qr_2_pi1_norm.asm: ...old name. * gmp-impl.h (mpn_div_qr_2n_pi1): Use new name in declaration. * tune/speed.h (speed_mpn_div_qr_2n): Likewise. (speed_mpn_div_qr_2u): Likewise. * tune/tuneup.c (tune_div_qr_2): Use new name speed_mpn_div_qr_2n. * tune/speed.c (routine): Use new names mpn_div_qr_2n and mpn_div_qr_2u, also on the command line. * tune/common.c (speed_mpn_div_qr_2n): Renamed, from... (speed_mpn_div_qr_2_norm): ... old name. (speed_mpn_div_qr_2u): Renamed, from... (speed_mpn_div_qr_2_unnorm): ... old name. * mpn/generic/div_qr_2_pi1_norm.c (mpn_div_qr_2n_pi1): Renamed, from... (mpn_div_qr_2_pi1_norm): ...old name. * mpn/x86_64/div_qr_2_pi1_norm.asm: Likewise. * mpn/generic/div_qr_2.c (mpn_div_qr_2n_pi2): Renamed, from... (mpn_div_qr_2_pi2_norm): ... old name. (mpn_div_qr_2u_pi1): Renamed, from... (mpn_div_qr_2_pi1_unnorm): ... old name. (mpn_div_qr_2): Call functions using new names. * mpn/asm-defs.m4: Renamed div_qr_2-functions to new names. 2011-03-29 Niels Möller * mpn/x86_64/div_qr_2_pi1_norm.asm: Updated to use a separate rp argument. * gmp-impl.h (mpn_div_qr_2_pi1_norm): Updated declaration. * gmp-h.in (mpn_div_qr_2): Likewise. * tests/mpn/t-div.c (main): Adapted to new mpn_div_qr2 interface. * tune/speed.h (SPEED_ROUTINE_MPN_DIV_QR_2): Likewise. * mpn/generic/div_qr_2.c (mpn_div_qr_2_pi2_norm): Added rp argument. Don't clobber the input dividend. (mpn_div_qr_2_pi1_unnorm): Likewise. (mpn_div_qr_2): Likewise. * mpn/generic/div_qr_2_pi1_norm.c (mpn_div_qr_2_pi1_norm): Likewise. 2011-03-29 Niels Möller * mpn/x86/k7/invert_limb.asm: Use mov rather than push and pop. Earlier load of divisor from stack. 2011-03-28 Torbjorn Granlund * mpn/x86/k7/invert_limb.asm: Protect movzwl register parameters from being interpreted as m4 macro parameters. 2011-03-22 Niels Möller * mpn/x86_64/div_qr_2_pi1_norm.asm: Copied optimized inner loop from divrem_2.asm. * mpn/x86_64/div_qr_2_pi1_norm.asm: First working, but poorly optimized, implementation. * mpn/asm-defs.m4 (define_mpn): Added div_qr_2_pi[12]_*norm. * mpn/generic/div_qr_2_pi1_norm.c (mpn_div_qr_2_pi1_norm): Moved to separate file, from... * mpn/generic/div_qr_2.c: ... old location. * gmp-impl.h (mpn_div_qr_2_pi1_norm): Declare. * configure.in (gmp_mpn_functions): Added div_qr_2_pi1_norm. 2011-03-22 Torbjorn Granlund * configure.in (powerpc): Reinsert lost AIX cpu_path 32-bit handling. Reinsert lost linux/bsd cpu_path handling. * mpn/generic/mod_1_1.c: Disable powerpc asm for _LONG_LONG_LIMB. * mpn/generic/div_qr_2.c: Likewise. * mpn/generic/div_qr_2.c: Use asm just for gcc. Make powerpc add_sssaaaa work for 32-bit case, and use less strict constraints. 2011-03-21 Niels Möller * tune/tuneup.c (div_qr_2_pi2_threshold): New global variable. (tune_div_qr_2): New function. (all): Call tune_div_qr_2. * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Added div_qr_2.c. * gmp-impl.h (DIV_QR_2_PI2_THRESHOLD): Setup for tuning. New 4/2 division loop, based on Torbjörn's work: * mpn/generic/div_qr_2.c (add_sssaaaa, add_csaac): New macros. (udiv_qr_4by2): New macro. (invert_4by2): New function. (mpn_div_qr_2_pi2_norm): New function. (DIV_QR_2_PI2_THRESHOLD): New threshold. (mpn_div_qr_2_pi1_norm): Renamed, from... (mpn_div_qr_2_norm): ... old name. (mpn_div_qr_2_pi1_unnorm): Renamed, from... (mpn_div_qr_2_unnorm): ... old name. (mpn_div_qr_2): Use mpn_div_qr_2_pi2_norm for large enough normalized divisors. * gmp-impl.h (udiv_qr_3by2): Avoid a copy. 2011-03-21 Torbjorn Granlund * configure.in (hppa): Under linux, treat 64-bit processors as if they were 32-bit processors. * mpn/generic/addcnd_n.c: New file. * mpn/asm-defs.m4 (define_mpn): Add addcnd_n and subcnd_n. * configure.in (gmp_mpn_functions): Add addcnd_n. * gmp-impl.h (mpn_addcnd_n): Declare. * mpn/generic/subcnd_n.c: Combine nails and non-nails functions. * gmp-impl.h (invert_pi1): Prepend _ to local variables, protect parameters within () where necessary. * mpn/asm-defs.m4 (define_mpn): Add div_qr_2. * configure.in (gmp_mpn_functions): Reinsert mercurial-bug-removed line. 2011-03-20 Torbjorn Granlund * configure.in (powerpc): Add cpu_path for all three ABIs. Rename "aix64" to "mode64" for consistency. 2011-03-16 Marc Glisse * gmpxx.h (__gmp_binary_not_equal): Remove, use !__gmp_binary_equal. (__gmp_binary_less_equal): Remove, use !__gmp_binary_greater. (__gmp_binary_greater_equal): Remove, use !__gmp_binary_less. * tests/cxx/t-ops2.cc: Typo. 2011-03-20 Niels Möller * tune/common.c (speed_mpn_div_qr_2_norm): New function. (speed_mpn_div_qr_2_unnorm): New function. * tune/speed.c (routine): Recognize above functions. * tune/speed.h: Declarations for above functions. (SPEED_ROUTINE_MPN_DIV_QR_2): New macro. * tests/mpn/t-div.c (main): Added tests for mpn_divrem_2 and mpn_div_qr_2. * mpn/generic/div_qr_2.c (mpn_div_qr_2): New file and function. Intended to eventually replace divrem_2. * configure.in (gmp_mpn_functions): Add div_qr_2. 2011-03-16 Marc Glisse * gmpxx.h (__gmp_set_expr): Remove broken declarations. 2011-03-19 Torbjorn Granlund * mpz/fac_ui.c (mpz_fac_ui): Use MPZ_REALLOC for standard, conditional reallocation. 2011-03-19 Niels Möller * mpn/generic/divrem_2.c (mpn_divrem_2): Fixed comment and assert regarding q and n overlap. 2011-03-16 Marc Glisse * gmpxx.h (__mpz_set_ui_safe): New inline function. (__mpz_set_si_safe): Likewise. (__GMPXX_TMPZ_UI): Use the new function. (__GMPXX_TMPZ_SI): Likewise. (__GMPXX_TMPQ_UI): Likewise. (__GMPXX_TMPQ_SI): Likewise. * tests/cxx/t-ops2.cc: test converting 0 to stack mpq_t. 2011-03-15 Marc Glisse * gmpxx.h (__GMPXX_TMPQ_UI): New macro. (__GMPXX_TMPQ_SI): New macro. (struct __gmp_binary_multiplies): Rewrite, using the new macros. (struct __gmp_binary_divides): Likewise. * gmpxx.h (__GMPZ_ULI_LIMBS): Rewrite. * tests/cxx/t-ops2.cc: test converting ULONG_MIN to stack mpq_t. 2011-03-15 Marco Bodrato * mpn/generic/toom_interpolate_16pts.c: Remove ambiguity. 2011-03-14 Torbjorn Granlund * tune/tuneup.c (tune_mul): Set tuning min size considering print skew. * doc/gmp.texi: Make reference to "Formatted I/O" chapters from type specific I/O sections. * mpn/alpha/add_n.asm: Add _nc entry point. * mpn/alpha/sub_n.asm: Likewise. * mpn/mips64/add_n.asm: Likewise. * mpn/mips64/sub_n.asm: Likewise. * mpn/sparc64/ultrasparc1234/add_n.asm: Likewise. * mpn/sparc64/ultrasparc1234/sub_n: Likewise. 2011-03-13 Marc Glisse * tests/cxx/t-ops2.cc: New file. * tests/cxx/Makefile.am: Added t-ops2. 2011-03-13 Torbjorn Granlund * mpn/generic/toom32_mul.c (mpn_toom32_mul): Make 'hi' be limb-sized for better code. * gmp-impl.h (MPN_IORD_U): Handle x86_64 as well as x86_32. Generate no code for incrementing by constant 0. 2011-03-12 Marc Glisse * gmpxx.h: Rename __GMPXX_TMP_* to __GMPXX_TMPZ_*. Use in more places. 2011-03-12 Torbjorn Granlund * mpn/powerpc64/rshift.asm: Accept/return values correctly also for 32-bit ABI. * mpn/powerpc64/lshift.asm: Likewise. * tune/powerpc.asm: Use powerpc syntax, not power syntax. * tune/common.c (speed_udiv_qrnnd_preinv1, etc): Remove. * tune/speed.c (routine): Remove udiv_qrnnd_preinv1, etc. 2011-03-12 Marc Glisse * tests/cxx/t-istream.cc: Restrict mpq test in t-istream -s. * gmpxx.h: Remove leftover #undefs. 2011-03-11 Torbjorn Granlund * gmp-impl.h (udiv_qrnnd_preinv1, udiv_qrnnd_preinv2, udiv_qrnnd_preinv2gen): Remove obsolete macros. (udiv_qrnnd_preinv): New name for udiv_qrnnd_preinv3. 2011-03-11 Marco Bodrato * gmp-impl.h: Declare many mpn_{sub,add}lsh*_n_ip[12] functions/macros. * mpn/generic/toom_interpolate_5pts.c: Use mpn_sublsh1_n_ip1. * tests/devel/try.c: Tests for {add,sub}lsh*_n_ip[12]. * tests/refmpn.c: New reference for mpn_{add,sub}lsh*_n_ip[12]. * tests/tests.h: Declarations for reference functions above. * tune/common.c: New speed_mpn_{add,sub}lsh*_n_ip[12] functions. * tune/speed.h: Prototypes for functions above. * tune/speed.c: Support for mpn_{add,sub}lsh*_n_ip[12]. * mpn/x86/k7/sublsh1_n.asm: Replaced generic sublsh1 code with faster _ip1. * mpn/x86/atom/sublsh1_n.asm: Changed PROLOGUE accordingly. * configure.in: Define HAVE_NATIVE_mpn_addlsh*_n*_ip[12]. * mpn/asm-defs.m4: Declare mpn_addlsh*_n*_ip[12]. 2011-03-10 Marc Glisse * tests/cxx/t-istream.cc: Explicit conversion to streampos. 2011-03-10 Torbjorn Granlund * mpn/x86/atom/sse2/mul_basecase.asm: Suppress wind-down rp updates. * Move new aorrlsh_n.asm to new k8 dir. Revert mpn/x86_64/aorrlsh_n.asm. * configure.in: Setup path for new k8 directory. 2011-03-10 Marco Bodrato * mpn/x86/pentium4/sse2/bdiv_dbm1c.asm: New file, was in atom. * mpn/x86/atom/sse2/bdiv_dbm1c.asm: Grab file above. 2011-03-09 Torbjorn Granlund * mpn/x86_64/aorrlsh_n.asm: Complete rewrite. * mpn/x86_64/core2/aorrlsh_n.asm: New file, grabbing another asm file. 2011-03-09 Marc Glisse * tests/cxx/t-ostream.cc: Use bool instead of int. * tests/cxx/t-istream.cc: Likewise. * tests/cxx/t-misc.cc: Likewise. * cxx/ismpznw.cc: Don't clear eofbit. * cxx/ismpq.cc: Likewise. * cxx/ismpf.cc: Likewise. * tests/cxx/t-istream.cc: Test accordingly. 2011-03-09 Marco Bodrato * mpn/x86/atom/sse2/bdiv_dbm1c.asm: New file. 2011-03-09 Marc Glisse * doc/gmp.texi: Remove void return type from constructors. Document explicit constructors. Document mpf_class::mpf_class(mpf_t). 2011-03-07 Marco Bodrato * mpn/x86/atom/sse2/sqr_basecase.asm: Postponed pushes. Cleaned outer loop exit. 2011-03-07 Torbjorn Granlund * mpn/x86_64/gcd_1.asm: Workaround Oracle assembler bug. * mpn/x86/atom/sse2/mul_basecase.asm: Replace addmul_1 loops. Tweak outer loop rp updates. 2011-03-06 Torbjorn Granlund * mpn/x86/atom/sse2/sqr_basecase.asm: New file. 2011-03-05 Torbjorn Granlund * mpn/x86_64/bdiv_dbm1c.asm: Write proper feed-in code. 2011-03-04 Torbjorn Granlund * mpn/x86_64/addmul_2.asm: Rewrite for linear performance. 2011-03-03 Torbjorn Granlund * mpn/generic/mod_1_1.c (add_mssaaaa): Canonicalise layout. Add arm variant. Enable sparc64 code and powerpc code (the latter for 32-bit and 64-bit). * mpn/generic/sqrtrem.c (mpn_dc_sqrtrem): Use mpn_addlsh1_n. * gmp-impl.h (mpn_addlsh_nc, mpn_rsblsh_nc): Declare. * mpn/asm-defs.m4: Likewise. * mpn/x86_64/coreisbr/aorrlsh_n.asm: Disable mpn_rsblsh_n due to carry-in issues. * mpn/x86_64/coreinhm/aorrlsh_n.asm: Likewise. * mpn/x86_64/coreisbr/aorrlsh2_n.asm: Likewise. 2011-03-03 Niels Möller * mpn/generic/mod_1_1.c (add_mssaaaa): For x86 and x86_64, treat m as in output operand only. Added sparc32 implementation. Also added #if:ed out attempts at sparc64 and powerpc64. * tune/tuneup.c (tune_mod_1): Record result of MOD_1_1P_METHOD measurement for use by mpn_mod_1_tune. And omit measurement if mpn_mod_1_1p is native assembly code. * mpn/generic/mod_1.c (mpn_mod_1_1p) [TUNE_PROGRAM_BUILD]: Macro to check mod_1_1p_method and call the right function. (mpn_mod_1_1p_cps) [TUNE_PROGRAM_BUILD]: Likewise. * gmp-impl.h (MOD_1_1P_METHOD) [TUNE_PROGRAM_BUILD]: Define macro. (mod_1_1p_method) [TUNE_PROGRAM_BUILD]: Declare variable. 2011-03-02 Torbjorn Granlund * mpn/x86_64/coreinhm/aorrlsh_n.asm: New file. * mpn/x86_64/coreisbr/aorrlsh_n.asm: New file. 2011-03-01 Niels Möller * mpn/x86_64/mod_1_1.asm (mpn_mod_1_1p_cps): Eliminated a neg and two mov instructions. * mpn/x86/k7/mod_1_1.asm (mpn_mod_1_1p_cps): Simplified computation, analogous to recent x86_64/mod_1_1.asm changes. (mpn_mod_1_1p): Corresponding changes. Don't shift b. * mpn/sparc64/mod_1_4.c (mpn_mod_1s_4p_cps): Use udiv_rnnd_preinv rather than udiv_rnd_preinv. (mpn_mod_1s_4p): Likewise. 2011-03-01 Torbjorn Granlund * mpn/x86/pentium4/sse2/mul_1.asm: Swap entry insns to share more code between entry points. * mpn/x86/pentium4/sse2/addmul_1.asm: Likewise. * mpz/divegcd.c: Rewrite, as per Marc Glisse's suggestion. Also fix problem with passing a longlong limb to a _ui function. * gmp-impl.h (udiv_qrnnd_preinv3): Cast truth value to mask's type. (udiv_rnnd_preinv): Likewise. * mpn/generic/mod_1_1.c (mpn_mod_1_1p): Likewise. 2011-02-28 Niels Möller * mpn/generic/mod_1_1.c (add_mssaaaa): Typo fix, define add_mssaaaa, not add_sssaaaa. * tune/tuneup.c (tune_mod_1): Measure mpn_mod_1_1_1 and mpn_mod_1_1_2, to set MOD_1_1P_METHOD. * tune/speed.c (routine): Added mpn_mod_1_1_1 and mpn_mod_1_1_2. * tune/speed.h: Declare speed_mpn_mod_1_1_1, speed_mpn_mod_1_1_2, mpn_mod_1_1p_1, mpn_mod_1_1p_2, mpn_mod_1_1p_cps_1, and mpn_mod_1_1p_cps_2. * tune/common.c (speed_mpn_mod_1_1_1): New function. (speed_mpn_mod_1_1_2): New function. * tune/Makefile.am (libspeed_la_SOURCES): Added mod_1_1-1.c mod_1_1-2.c. * tune/mod_1_1-1.c: New file. * tune/mod_1_1-2.c: New file. * mpn/generic/mod_1_1.c: Implemented an algorithm with fewer multiplications, configured via MOD_1_1P_METHOD. * mpn/x86_64/mod_1_1.asm (mpn_mod_1_1p_cps): Simplified computation of B2modb, use B^2 mod (normalized b). (mpn_mod_1_1p): Corresponding changes. Don't shift b. * mpn/generic/mod_1_1.c (mpn_mod_1_1p_cps): Use udiv_rnnd_preinv rather than udiv_rnd_preinv. (mpn_mod_1_1p): Likewise. * mpn/generic/mod_1_4.c: Analogous changes. * mpn/generic/mod_1_3.c: Analogous changes. * mpn/generic/mod_1_2.c: Analogous changes. * mpn/generic/mod_1.c: Analogous changes. * mpn/generic/pre_mod_1.c: Analogous changes. * gmp-impl.h (udiv_qrnnd_preinv3): Eliminated unpredictable branch using masking logic. Further optimization of the nl == constant 0 case, similar to udiv_rnd_preinv. (udiv_rnnd_preinv): Likewise. (udiv_rnd_preinv): Deleted, use udiv_rnnd_preinv with nl == 0 instead. * tests/mpn/t-divrem_1.c (check_data): Added testcase to exercise the nl == constant 0 special case in udiv_qrnnd_preinv3. 2011-02-28 Torbjorn Granlund * mpn/generic/rootrem.c (mpn_rootrem): Combine two similar scalar divisions. Misc minor cleanup. * mpn/x86/atom/sse2/aorsmul_1.asm: Shorten software pipeline. * mpn/x86/atom/mul_basecase.asm: Remove file no longer used. * mpn/generic/rootrem.c (mpn_rootrem_internal): Delay O(log(U)) allocations until they are known to be needed. 2011-02-27 Marco Bodrato * mpn/x86/atom/sse2/mul_1.asm: New code. 2011-02-27 Niels Möller * gmp-impl.h (udiv_rnnd_preinv): New macro. 2011-02-27 Torbjorn Granlund * mpn/x86/atom/sse2/mul_basecase.asm: New file. 2011-02-26 Marco Bodrato * mpn/x86/atom/sse2/aorsmul_1.asm: Optimise non-loop code. 2011-02-26 Torbjorn Granlund * mpn/powerpc64/mode64/aorsmul_1.asm: Add MULFUNC_PROLOGUE. * mpn/m68k/mc68020/aorsmul_1.asm: Likewise. * mpn/powerpc64/mode64/aorsmul_1.asm: Add missing MULFUNC_PROLOGUE. * mpn/m68k/mc68020/aorsmul_1.asm: Likewise. 2011-02-25 Torbjorn Granlund * mpn/x86/atom/sse2/aorsmul_1.asm: New file. * mpn/x86/atom/aorsmul_1.asm: File removed. 2011-02-25 Marco Bodrato * mpn/x86/atom/sse2/divrem_1.asm: New file (was in x86/atom). * mpn/x86/atom/sse2/mul_1.asm: Likewise. * mpn/x86/atom/sse2/popcount.asm: Likewise. * mpn/x86/atom/divrem_1.asm: ReMoved (in sse2/ now). * mpn/x86/atom/mul_1.asm: Likewise. * mpn/x86/atom/popcount.asm: Likewise. * configure.in: Set up mmx path for atom. * mpn/x86/atom/mmx/copyd.asm: New file (was in x86/atom). * mpn/x86/atom/mmx/copyi.asm: Likewise. * mpn/x86/atom/mmx/hamdist.asm: Likewise. * mpn/x86/atom/copyd.asm: ReMoved (in mmx/ now). * mpn/x86/atom/copyi.asm: Likewise. * mpn/x86/atom/hamdist.asm: Likewise. 2011-02-24 Torbjorn Granlund * mpn/x86/atom/sse2/mod_1_1.asm: New file. * mpn/x86/atom/sse2/mod_1_4.asm: New file. * configure.in: Set up sse2 path for atom. * mpn/x86/p6/sse2/mod_1_1.asm: New file. * mpn/x86/p6/sse2/mod_1_4.asm: Fix typo in MULFUNC_PROLOGUE. 2011-02-24 Niels Möller * mpn/x86/k7/mod_1_1.asm (mpn_mod_1_1p): Rewrite using the same algorithm as the x86_64 version. 2011-02-23 Marco Bodrato * mpn/x86/atom/logops_n.asm: New file (same loop as aors_n). 2011-02-23 Niels Möller * mpn/x86_64/mod_1_1.asm (mpn_mod_1_1p): Shaved off one instruction and one register in the inner loop. Rearranged registers slightly, and no longer needs the callee-save register %r12. 2011-02-22 Torbjorn Granlund * configure.in: Export SHLD_SLOW and SHRD_SLOW to config.m4, also fixing typo in exporting code. * mpn/x86_64/nano/gmp-mparam.h (SHLD_SLOW, SHRD_SLOW): Define. * mpn/x86_64/atom/gmp-mparam.h (SHLD_SLOW, SHRD_SLOW): Define. 2011-02-22 Niels Möller * mpn/x86_64/mod_1_1.asm (mpn_mod_1_1p): Rewrite. 2011-02-22 Marco Bodrato * mpn/x86/atom/lshiftc.asm: New file (a copy of lshift.asm with a handful of neg added). 2011-02-21 Torbjorn Granlund * mpn/x86/aors_n.asm: Move _nc entry to after main code. Align loop and _n entry for claimed performance. Normalise mnemonic usage. * mpn/x86/atom/aorrlsh1_n.asm: New file (code from rsblsh_1, slightly slower for addlsh_1 for large operands, but much faster for small). * mpn/x86/atom/addlsh1_n.asm: Remove. * mpn/x86/atom/rsblsh1_n.asm: Remove. 2011-02-20 Marc Glisse * mpq/aors.c: Rewrite to remove redundant division. 2011-02-20 Torbjorn Granlund * mpn/x86/atom/lshift.asm: New file. * mpn/x86/atom/rshift.asm: Normalise mnemonic usage. * gmp-impl.h (mpn_divexact_by7): Relax inclusion condition. * mpz/divegcd.c (mpz_divexact_by5): New conditionally enabled function. (mpz_divexact_by3): Wrap inside appropriate conditions. (mpz_divexact_gcd): Rewrite. * mpn/x86/bdiv_dbm1c.asm: Save a jump. 2011-02-20 Marco Bodrato * mpn/x86/atom/aorslshC_n.asm: New file. * mpn/x86/atom/sublsh2_n.asm: New file. * mpn/x86/atom/aors_n.asm: New code. * mpn/x86/atom/rshift.asm: Atom64 code adapted to 32-bit. * mpn/x86/atom/lshift.asm: Likewise. 2011-02-19 Torbjorn Granlund * mpn/x86_64/atom/rsh1aors_n.asm: New file. * mpn/x86_64/atom/lshift.asm: New file. * mpn/x86_64/atom/rshift.asm: New file. * mpn/x86_64/atom/lshiftc.asm: New file. 2011-02-17 Marco Bodrato * mpn/x86/atom/aorsmul_1.asm: Small improvements for small sizes. * mpn/x86/atom/aorrlshC_n.asm: Tiny size improvements. 2011-02-16 Torbjorn Granlund * configure.in: Fix k8/k10 32-bit path setup problem. 2011-02-16 Marco Bodrato * mpn/x86/atom/aorsmul_1.asm: Revive an old k7/aorsmul. 2011-02-14 Marco Bodrato * gmp-impl.h (mpn_sublsh_n): Declare. * mpn/asm-defs.m4: Likewise. * mpn/x86/atom/aorrlshC_n.asm: New file (was k7). * mpn/x86/k7/aorrlshC_n.asm: ReMoved. * mpn/x86/atom/aorrlsh2_n.asm: Grab atom/aorrlshC_n.asm. * mpn/x86/atom/rsblsh1_n.asm: Grab atom/aorrlshC_n.asm. 2011-02-13 Torbjorn Granlund * mpn/x86_64/atom/aorrlsh2_n.asm: New file. 2011-02-12 Torbjorn Granlund * mpn/x86_64/aorrlsh_n.asm: Minor tweaks, update c/l numbers. * mpn/x86_64/atom/sublsh1_n.asm: New file. * mpn/x86_64/atom/aorrlsh1_n.asm: New file. 2011-02-11 Torbjorn Granlund * mpn/powerpc64/mode64/mod_1_1.asm: Fix Darwin syntax issues. 2011-02-10 Torbjorn Granlund * mpn/powerpc64/mode64/mod_1_4.asm: Tune away a cycle for 970. 2011-02-11 Marco Bodrato * mpn/x86/k7/addlsh1_n.asm: Faster core loop (Torbjorn's). * configure.in: Add HAVE_NATIVE_{add,sub,rsb}lsh{,1,2}_nc. * tests/tests.h: refmpn_{add,sub,rsb}lsh{,1,2}_nc prototypes. * tests/refmpn.c: New refmpn_{add,sub,rsb}lsh{,1,2}_nc. * tests/devel/try.c: Tests for mpn_{add,sub,rsb}lsh{,1,2}_nc. * mpn/x86/k7/aorrlshC_n.asm: New file. * mpn/x86/atom/aorrlsh2_n.asm: Grab k7/aorrlshC_n.asm. * mpn/x86/atom/rsblsh1_n.asm: Grab k7/aorrlshC_n.asm. 2011-02-06 Marco Bodrato * mpn/x86/k7/addlsh1_n.asm: New file. * mpn/x86/k7/sublsh1_n.asm: New file. * mpn/x86/atom/addlsh1_n.asm: Grab k7/addlsh1_n.asm. * mpn/x86/atom/sublsh1_n.asm: Grab k7/sublsh1_n.asm. 2011-02-05 Torbjorn Granlund * gmp-impl.h (mpn_addlsh1_nc, mpn_addlsh2_nc, mpn_sublsh1_nc, mpn_sublsh2_nc, mpn_rsblsh1_nc, mpn_rsblsh2_nc): Declare. * mpn/asm-defs.m4: Likewise. * mpn/x86_64/coreisbr/aorrlshC_n.asm: New file. * mpn/x86_64/coreisbr/aorrlsh1_n.asm: New file. * mpn/x86_64/coreisbr/aorrlsh2_n.asm: New file. * mpn/x86_64/coreisbr/aors_n.asm: New file, based on old atom/aors_n.asm. * mpn/x86_64/atom/aors_n.asm: Grab coreisbr/aors_n.asm. 2011-02-05 Marco Bodrato * gmp-impl.h (mpn_toom6_mul_n_itch): Handle threshold == zero. (mpn_toom8_mul_n_itch): Likewise. (MPN_TOOM6H_MIN, MPN_TOOM8H_MIN): Define. * tests/mpn/t-toom6h.c: No tests below MPN_TOOM6H_MIN. * tests/mpn/t-toom8h.c: No tests below MPN_TOOM8H_MIN. * mpz/lucnum_ui.c: Use mpn_addlsh2_n. 2011-02-04 Torbjorn Granlund * mpn/x86_64/atom/rsh1aors_n.asm: Add a MULFUNC_PROLOGUE. * mpn/x86_64/atom/dive_1.asm: Likewise. * mpn/x86_64/atom/popcount.asm: Likewise. * mpn/x86_64/core2/popcount.asm: Likewise. * mpn/x86_64/coreinhm/hamdist.asm: Likewise. * mpn/x86_64/coreinhm/popcount.asm: Likewise. * mpn/x86_64/nano/popcount.asm: Likewise. * mpn/x86_64/pentium4/popcount.asm: Likewise. 2011-02-04 Marco Bodrato * mpn/x86/atom/mode1o.asm: New file, grabbing another asm file. * mpn/x86/atom/mul_1.asm: Claim mul_1c. 2011-02-02 Niels Möller * tune/speed.h (SPEED_ROUTINE_MPN_HGCD_CALL): Fixed one speed_operand_dst call. 2011-02-01 Torbjorn Granlund * tune/speed.h (struct speed_params): Allow for 4 dst operands. * tune/common.c (TOLERANCE): Increase from 0.5% to 1%. * tune/speed.h (SPEED_ROUTINE_MPN_HGCD_CALL): New macro, mainly based on old speed_mpn_hgcd, but with speed_operand_src calls (as suggested by Niels). * tune/common.c (speed_mpn_hgcd): Invoke SPEED_ROUTINE_MPN_HGCD_CALL. (speed_mpn_hgcd_lehmer): Likewise. * configure.in: Set up 32-bit x86 paths for new corei* CPU strings. 2011-01-31 Torbjorn Granlund * config.guess: Recognise new Intel processors. * config.guess: Support 'coreinhm' and 'coreisbr'. * config.sub: Likewise. * configure.in: Likewise. 2011-01-30 Torbjorn Granlund * configure.in: Support x86/geode. * mpn/x86/geode/gmp-mparam.h: New file. 2011-01-29 Marco Bodrato * mpn/x86/atom/addlsh1_n.asm: Removed. * mpn/x86/atom/rsh1add_n.asm: Likewise. 2011-01-28 Torbjorn Granlund * mpn/alpha/ev6/slot.pl: Add some missing insns. 2011-01-28 Marco Bodrato * mpn/x86/atom/copyd.asm: New file, grabbing another asm file. * mpn/x86/atom/copyi.asm: Likewise. * mpn/x86/atom/aors_n.asm: Likewise. * mpn/x86/atom/addlsh1_n.asm: Likewise. * mpn/x86/atom/aorsmul_1.asm: Likewise. * mpn/x86/atom/bdiv_q_1.asm: Likewise. * mpn/x86/atom/dive_1.asm: Likewise. * mpn/x86/atom/divrem_1.asm: Likewise. * mpn/x86/atom/hamdist.asm: Likewise. * mpn/x86/atom/logops_n.asm: Likewise. * mpn/x86/atom/lshift.asm: Likewise. * mpn/x86/atom/mod_34lsub1.asm: Likewise. * mpn/x86/atom/mul_1.asm: Likewise. * mpn/x86/atom/mul_basecase.asm: Likewise. * mpn/x86/atom/popcount.asm: Likewise. * mpn/x86/atom/rsh1add_n.asm: Likewise. * mpn/x86/atom/rshift.asm: Likewise. * mpn/x86/atom/sqr_basecase.asm: Likewise. 2011-01-27 Torbjorn Granlund * mpn/x86_64/atom/rsh1aors_n.asm: New file, grabbing another asm file. * mpn/x86_64/atom/popcount.asm: Likewise. * mpn/x86_64/atom/dive_1.asm: Likewise. * mpn/x86_64/nano/popcount.asm: Likewise. 2011-01-26 Torbjorn Granlund * mpn/alpha/invert_limb.asm: Complete rewrite. 2011-01-25 Torbjorn Granlund * mpn/powerpc32/invert_limb.asm: New file. 2011-01-25 Marco Bodrato * mpn/x86/pentium4/sse2/bdiv_q_1.asm: New file. * mpn/x86/k7/bdiv_q_1.asm: New file. 2011-01-24 Torbjorn Granlund * tune/tuneup.c (tune_mul_n, tune_sqr): Loop, re-measuring thresholds until no tiny ranges remain. 2011-01-23 Torbjorn Granlund * mpn/ia64/mul_2.asm: Tweak to 1.5 c/l, less overhead. * mpn/ia64/addmul_2.asm: Rewrite, adding mpn_addmul_2s entry point. 2011-01-22 Torbjorn Granlund * mpn/ia64/aors_n.asm: Fix some incorrect bundle types. * mpn/ia64/sqr_diagonal.asm: Remove. * mpn/ia64/sqr_diag_addlsh1.asm: New file. * mpn/ia64/ia64-defs.m4: Define some shorter convenience mnemonics. * mpn/generic/sqr_basecase.c (MPN_SQR_DIAG_ADDLSH1): New macro, using new function mpn_sqr_diag_addlsh1 or defining its equivalent. * gmp-impl.h (mpn_addmul_2s): Declare. (mpn_sqr_diag_addlsh1): Declare. * mpn/asm-defs.m4 (define_mpn): Add addmul_2s and sqr_diag_addlsh1. * configure.in: Add HAVE_NATIVEs for mpn_sqr_diag_addlsh1 and mpn_addmul_2s. (gmp_mpn_functions_optional): Add sqr_diag_addlsh1. 2011-01-21 Marco Bodrato * tests/devel/try.c: Initial support for mpn_bdiv_q_1. * mpn/x86/pentium/bdiv_q_1.asm: New file. * mpn/x86/p6/bdiv_q_1.asm: New file. 2011-01-20 Torbjorn Granlund * tune/speed.c (run_gnuplot): Update to current gnuplot syntax. * mpn/powerpc64/mode64/aorsmul_1.asm: Trim away 0.5 c/l for submul_1 for POWER5. 2011-01-19 Torbjorn Granlund * mpn/x86_64/core2/rsh1aors_n.asm: New file. 2011-01-18 Marco Bodrato * mpn/x86/bdiv_q_1.asm: New file (same core alg. as dive_1). 2011-01-15 Marco Bodrato * mpn/generic/divexact.c: Avoid COPY if not needed. 2011-01-14 Torbjorn Granlund * gmp-impl.h (struct cpuvec_t): Add field bmod_1_to_mod_1_threshold. * configure.in (fat_thresholds): Add BMOD_1_TO_MOD_1_THRESHOLD. 2011-01-13 Marco Bodrato * mpz/mul.c: Remove redundant size computation. 2011-01-08 Torbjorn Granlund * tests/devel/try.c (types enum): Add TYPE_MUL_5 and TYPE_MUL_6. (param_init): Support new types. (choice_array): Support testing of mpn_mul_5 and mpn_mul_6. (call): Support new routines. * tests/refmpn.c (refmpn_mul_5, refmpn_mul_6): New functions. * tests/tests.h (refmpn_mul_5, refmpn_mul_6): Declare. Remove parameter names from some other functions. * gmp-impl.h (mpn_mul_5, mpn_mul_6): Declare. * mpn/asm-defs.m4: Likewise, also declare mpn_addmul_5, mpn_addmul_6, mpn_addmul_7, and mpn_addmul_8. * configure.in (gmp_mpn_functions_optional): Add mul_5 and mul_6. * tune/speed.c (routine): Add measuring of mpn_mul_5 and mpn_mul_6. * tune/common.c (speed_mpn_mul_5, speed_mpn_mul_6): New functions. * tune/speed.h: Declare new functions. 2011-01-03 Marco Bodrato * mpz/aors.h: Remove #ifdef BERKELEY_MP, and cleanup. * mpz/cmp.c: Likewise. * mpz/gcd.c: Likewise. * mpz/mul.c: Likewise. * mpz/powm.c: Likewise. * mpz/set.c: Likewise. * mpz/sqrtrem.c: Likewise. * mpz/tdiv_qr.c: Likewise. 2010-12-28 Torbjorn Granlund * mpn/minithres/gmp-mparam.h: Update with several recent thresholds. 2010-12-19 Torbjorn Granlund * mpn/x86/k7/mod_1_1.asm: Canonicalise cmov forms. * mpn/x86/k7/mod_1_4.asm: Likewise. * mpn/x86/pentium4/sse2/mod_1_1.asm: Likewise. * mpn/x86/pentium4/sse2/mod_1_4.asm: Likewise. * mpn/x86_64/core2/divrem_1.asm: Likewise. * mpn/x86_64/divrem_1.asm: Likewise. * mpn/x86_64/mod_1_1.asm: Likewise. * mpn/x86_64/mod_1_2.asm: Likewise. * mpn/x86_64/mod_1_4.asm: Likewise. * mpn/x86/k7/gcd_1.asm: Rewrite. Remove slow 'div' loop. Call mpn_mod_1 for operands with mode than BMOD_1_TO_MOD_1_THRESHOLD limbs. Misc cleanups. 2010-12-18 Torbjorn Granlund * mpn/x86_64/gcd_1.asm: Call mpn_mod_1 for operands with mode than BMOD_1_TO_MOD_1_THRESHOLD limbs. * configure.in: Generalise code for putting THRESHOLDs in config.m4. Add BMOD_1_TO_MOD_1_THRESHOLD to list. * mpn/x86_64/core2/divrem_1.asm: Tweak slightly, correct cycle counts. * mpn/x86_64/addmul_2.asm: Remove constant index. * mpn/x86_64/lshiftc.asm: Likewise. * mpn/x86_64/pentium4/lshift.asm: Likewise. * mpn/x86_64/pentium4/lshiftc.asm: Likewise. * mpn/x86_64/pentium4/rshift.asm: Likewise. 2010-12-16 Torbjorn Granlund * mpn/x86_64/mod_34lsub1.asm: Complete rewrite. * mpn/x86_64/pentium4/mod_34lsub1.asm: New file, old mpn/x86_64/mod_34lsub1.asm. 2010-12-15 Torbjorn Granlund * mpn/powerpc64/vmx/popcount.asm: Rewrite to use vperm count table. 2010-12-14 Torbjorn Granlund * mp-h.in: Remove. * configure.in: Remove mp-h.in from AC_OUTPUT invocation. 2010-12-13 Torbjorn Granlund * mpz/mod.c: Rewrite. * mpn/x86_64/corei/popcount.asm: New file. * mpn/x86_64/corei/hamdist.asm: New file. * mpn/x86_64/k10/hamdist.asm: New file. * configure.in: Amend last change for lame /bin/sh. 2010-12-12 Torbjorn Granlund * configure.in: Comment out M4=m4-not-needed. * mpn/x86_64/k10/popcount.asm: New file. * configure.in: Setup special path for k10 and later AMD CPUs. Remove special x86_64'k8' path, since directory is non-existent. 2010-12-11 Torbjorn Granlund * mpn/sparc32/ultrasparct1: New directory. * mpn/sparc32/ultrasparct1/add_n.asm: New file. * mpn/sparc32/ultrasparct1/sub_n.asm: New file. * mpn/sparc32/ultrasparct1/mul_1.asm: New file. * mpn/sparc32/ultrasparct1/addmul_1.asm: New file. * mpn/sparc32/ultrasparct1/submul_1.asm: New file. * mpn/sparc32/ultrasparct1/sqr_diagonal.asm: New file. * config.guess: Support Ultrasparc T2 and T3. * config.sub: Likewise. * configure.in: Likewise. * config.guess: Generalise BSD Sparc recognition by allowing any caps (needed for OpenBSD which spells things innovatively). 2010-12-01 Torbjorn Granlund * config.guess: Match new AMD processors, allow finer distinctions among old ones. * acinclude.m4 (X86_64_PATTERN): Likewise. * config.sub: Likewise. * configure.in: Rudimentarily support new AMD processors. * configure.in (--enable_assembly): New option. (target none-*-*): Disable, give error. 2010-11-29 Torbjorn Granlund * mpn/x86/x86-defs.m4 (LEA): Support non-PIC code. * mpn/x86/darwin.m4 (LEA): Likewise. * tests/amd64call.asm: Rewrite for code size, and to match calls and returns. * tests/x86call.asm: Rewrite for code size, to support PIC, and to match calls and returns. * tests/x86check.c: Rewrite. 2010-11-22 Torbjorn Granlund * mpz/get_str.c: Make all bases either work or return an error. * mpz/out_str.c: Likewise. * mpq/get_str.c: Likewise. * mpf/get_str.c: Likewise. 2010-11-14 Torbjorn Granlund * tests/misc/t-printf.c: Add explicit casts for type conversions. * mpn/generic/toom62_mul.c: Likewise. 2010-11-13 Torbjorn Granlund * mpn/generic/get_d.c: Misc cleanup. Fail with a syntax error for non-IEEE fp formats. * tests/devel/try.c (malloc_region): Add explicit casts for type conversions. * acinclude.m4 (GMP_ASM_RODATA): Make test code snippet C++ compatible. (GMP_C_DOUBLE_FORMAT): Likewise. (GMP_FUNC_VSNPRINTF): Likewise. * config.guess (x86): Make test C snippet C++ compatible. 2010-11-12 Torbjorn Granlund * Makefile.am: Remove mpbsd. * configure.in: Remove mpbsd. * doc/configuration: Remove mpbsd mentions. * doc/gmp.texi: Remove mpbsd docs. * tests/Makefile.am: Remove mpbsd. * libmp.sym: Remove. * mpbsd: Remove directory and files. * tests/mpbsd: Remove directory and files. 2010-11-11 Torbjorn Granlund * mpn/x86_64/atom/aors_n.asm: Don't rely on ZF after 'bt' insn. Use 64-bit 'test' to support operands of 2^32 limbs and more. * rand: New directory, move rand*.c and randmt.h here. * rand/Makefile.am: New file. * Makefile.am (SUBDIRS): Add rand. (RANDOM_OBJECTS): New variable. (libgmp_la_SOURCES): Remove random objects. (libgmp_la_DEPENDENCIES): Add RANDOM_OBJECTS. * configure.in (AC_OUTPUT): Add rand/Makefile. * ansi2knr.1: File removed. * ansi2knr.c: File removed. 2010-11-10 Torbjorn Granlund Make it possible to compile GMP with g++: * gmp-impl.h: Declare __gmp_digit_value_tab here. * mpbsd/min.c: ...not here. * mpbsd/xtom.c: ...nor here. * mpf/set_str.c: ...nor here. * mpz/inp_str.c: ...nor here. * mpz/set_str.c: ...nor here. * mpn/generic/toom43_mul.c: Add casts for logical operations on enums. * mpn/generic/toom44_mul.c: Likewise. * mpn/generic/toom4_sqr.c: Likewise. * mpn/generic/toom52_mul.c: Likewise. * mpn/generic/toom53_mul.c: Likewise. * mpn/generic/toom62_mul.c: Likewise. * mpz/clrbit.c: Clean up typing using MPZ_REALLOC. * mpz/setbit.c: Likewise. * mpz/powm.c: Avoid variable name 'new'. * randlc2x.c: Add explicit casts for type conversions. * tests/misc/t-printf.c: Likewise. * tests/misc/t-scanf.c: Likewise. * tests/misc.c: Likewise. * tests/mpz/convert.c: Likewise. * tests/refmpn.c: Likewise. * tests/tests.h: Unconditionally use for now. * tests/memory.c: Include "tests.h. * mp_get_fns.c: Add a __GMP_NOTHROW for coherency with prototype. * mp_set_fns.c: Likewise. * mpf/cmp.c: Likewise. * mpf/cmp_si.c: Likewise. * mpf/cmp_ui.c: Likewise. * mpf/fits_s.h: Likewise. * mpf/fits_u.h: Likewise. * mpf/get_dfl_prec.c: Likewise. * mpf/get_prc.c: Likewise. * mpf/get_si.c: Likewise. * mpf/get_ui.c: Likewise. * mpf/int_p.c: Likewise. * mpf/set_dfl_prec.c: Likewise. * mpf/set_prc_raw.c: Likewise. * mpf/size.c: Likewise. * mpf/swap.c: Likewise. * mpq/equal.c: Likewise. * mpq/swap.c: Likewise. * mpz/cmp.c: Likewise. * mpz/cmp_si.c: Likewise. * mpz/cmp_ui.c: Likewise. * mpz/cmpabs.c: Likewise. * mpz/cmpabs_ui.c: Likewise. * mpz/cong_2exp.c: Likewise. * mpz/divis_2exp.c: Likewise. * mpz/fits_s.h: Likewise. * mpz/get_si.c: Likewise. * mpz/hamdist.c: Likewise. * mpz/scan0.c: Likewise. * mpz/scan1.c: Likewise. * mpz/sizeinbase.c: Likewise. * mpz/swap.c: Likewise. * mpz/tstbit.c: Likewise. * tal-reent.c: Likewise. 2010-11-09 Torbjorn Granlund * configure.in: Get rid of K&R support. * Makefile.am: Likewise. * mpn/Makefile.am: Likewise. * doc/configuration: Update docs wrt K&R support. * doc/gmp.texi: Likewise. * configure.in (AC_INIT): Amend bug reporting address with manual reference. 2010-11-06 Torbjorn Granlund * config.guess: If cpuid says we have 32bit-only x86 but configfsf.guess return x86_64, return the latter. * mpn/x86_64/aors_n.asm: Rewrite not to rely on ZF after 'bt' insn. 2010-10-09 Torbjorn Granlund * mpn/generic/trialdiv.c: Update documentation. 2010-10-04 Torbjorn Granlund * mpn/x86_64/gcd_1.asm: Use m4_lshift to avoid << operator. * mpn/x86_64/aorrlshC_n.asm: Likewise. * mpn/x86_64/pentium4/aorslshC_n.asm: Likewise. * mpn/x86/k7/gcd_1.asm: Likewise. 2010-08-20 Niels Möller Suggested by Ozkan Sezer: * configure.in: If $M4 is already set in the environment, don't touch it. Fixed the case that no assembler files are used, and GMP_PROG_M4 is omitted. 2010-08-08 Torbjorn Granlund * mpn/x86_64/fat/fat.c: Recognise many more processors. 2010-06-30 Torbjorn Granlund * mpn/x86_64/divrem_2.asm: Tune. 2010-06-19 Niels Möller * tune/speed.h (SPEED_ROUTINE_MPN_MOD_1_1): Pass normalized divisor to the benchmarked function. 2010-06-15 Torbjorn Granlund * mpn/x86_64/mod_1_1.asm (mpn_mod_1_1p_cps): Rewrite. * mpn/x86_64/mod_1_2.asm (mpn_mod_1s_2p_cps): Rewrite. * mpn/x86_64/mod_1_4.asm (mpn_mod_1s_4p_cps): Rewrite. * gmp-impl.h (udiv_rnd_preinv): Simplify. * mpn/x86/k7/mod_1_1.asm: New file. * mpn/x86/pentium4/sse2/mod_1_1.asm (mpn_mod_1_1p_cps): Rewrite. * mpn/x86/k7/mod_1_4.asm (mpn_mod_1s_4p_cps): Rewrite. * mpn/x86/pentium4/sse2/mod_1_4.asm (mpn_mod_1s_4p_cps): Rewrite. * mpn/generic/mod_1_1.c (mpn_mod_1_1p_cps): Store results as they are computed. * mpn/generic/mod_1_2.c (mpn_mod_1s_2p_cps): Likewise. * mpn/generic/mod_1_4.c (mpn_mod_1s_4p_cps): Likewise. * mpn/x86/k7/invert_limb.asm: Moved from mpn/x86/invert_limb.asm. 2010-06-15 Niels Möller * tests/mpn/Makefile.am (check_PROGRAMS): Added t-mod_1. * tests/mpn/t-mod_1.c: New file. 2010-05-25 Torbjorn Granlund * mpn/generic/mu_div_qr.c (mpn_preinv_mu_div_qr_itch): Trim out space for inverse, since that is passed in already. 2010-05-24 Torbjorn Granlund * mpn/generic/mu_div_qr.c (mpn_preinv_mu_div_qr_itch): New function. * gmp-impl.h: Declare it. * tune/common.c (speed_mpn_mupi_div_qr): Use new itch function. * tune/speed.h (SPEED_ROUTINE_MPN_MUPI_DIV_QR): Pass parameters right for new itch function. * mpn/powerpc32/lshiftc.asm: New file. 2010-05-22 Torbjorn Granlund * tune/tuneup.c (tune_mod_1): Revert to version of 2010-05-06. 2010-05-17 Torbjorn Granlund * configure.in (ia64): Get 32-bit sizeof test right. * tune/tuneup.c (tune_mod_1): Undo unintensional change to tuning of PREINV_MOD_1_TO_MOD_1_THRESHOLD. 2010-05-16 Torbjorn Granlund * mpn/sparc64/mod_1.c: Rewrite. * mpn/sparc64/sparc64.h (umul_ppmm_s): New macro. * mpn/sparc64/mod_1_4.c: New file. * mpn/generic/divrem_1.c: Minor cleanup. * mpn/generic/mod_1.c: Likewise. * mpn/generic/mod_1_1.c: Likewise. * mpn/generic/mod_1_2.c: Likewise. * mpn/generic/mod_1_3.c: Likewise. * mpn/generic/mod_1_4.c: Likewise. * configure.in (ia64-hpux): Do sizeof tests for 32-bit and 64-bit ABI. * tune/tuneup.c (tune_mod_1): Completely finish MOD_1_N tuning before tuning MOD_1U_TO_MOD_1_1_THRESHOLD. 2010-05-14 Torbjorn Granlund * mpn/generic/redc_2.c: Use asm code just for GNU C. 2010-05-13 Torbjorn Granlund * mpn/sparc64/ultrasparc1234: New directory. Move all code that uses floating-point into this directory. * configure.in: Point to ultrasparc1234 for appropriate CPUs. * mpn/sparc64/ultrasparct1/add_n.asm: New file. * mpn/sparc64/ultrasparct1/addlsh2_n.asm: New file. * mpn/sparc64/ultrasparct1/addmul_1.asm: New file. * mpn/sparc64/ultrasparct1/lshift.asm: New file. * mpn/sparc64/ultrasparct1/mul_1.asm: New file. * mpn/sparc64/ultrasparct1/rsblsh2_n.asm: New file. * mpn/sparc64/ultrasparct1/rshift.asm: New file. * mpn/sparc64/ultrasparct1/sublsh1_n.asm: New file. * mpn/sparc64/ultrasparct1/sublshC_n.asm: New file. * mpn/sparc64/ultrasparct1/addlsh1_n.asm: New file. * mpn/sparc64/ultrasparct1/addlshC_n.asm: New file. * mpn/sparc64/ultrasparct1/lshiftc.asm: New file. * mpn/sparc64/ultrasparct1/rsblsh1_n.asm: New file. * mpn/sparc64/ultrasparct1/rsblshC_n.asm: New file. * mpn/sparc64/ultrasparct1/sub_n.asm: New file. * mpn/sparc64/ultrasparct1/sublsh2_n.asm: New file. * mpn/sparc64/ultrasparct1/submul_1.asm: New file. * mpn/sparc64/ultrasparct1/gmp-mparam.h: New file. * configure.in: Give ultrasparct1 and ultrasparct2 special code path. * mpn/x86_64/pentium4/gmp-mparam.h: Disable mpn_addlsh_n, mpn_rsblsh_n. 2010-05-12 Niels Möller * mpz/jacobi.c (mpz_jacobi): Fixed off-by-one error in use of scratch space. * tune/common.c (speed_mpz_powm_sec): New function. * tune/speed.h: Declare speed_mpz_powm_sec. * tune/speed.c (routine): Added speed_mpz_powm_sec. * tune/common.c (speed_mpn_addlsh_n, speed_mpn_sublsh_n) (speed_mpn_rsblsh_n): New functions. * tune/speed.h: Declare new functions. * tune/speed.c (routine): Add new functions. 2010-05-12 Torbjorn Granlund * mpn/x86_64/mod_1_4.asm: Tune for more processors. * mpn/x86_64/pentium4/lshiftc.asm: New file. 2010-05-11 Niels Möller * mpz/jacobi.c (mpz_jacobi): Deleted old implementation. Reorganized new implementation, to handle small inputs efficiently. * tests/mpz/t-jac.c (check_large_quotients): Reduced test sizes. (check_data): One more input pair related to a fixed bug. (main): Enable check_large_quotients. 2010-05-10 Torbjorn Granlund * mpn/x86_64/aorrlsh2_n.asm: Fix typo. 2010-05-09 Torbjorn Granlund * mpn/x86_64/aorrlshC_n.asm: New file based on aorrlsh2_n.asm. * mpn/x86_64/aorrlsh2_n.asm: Now just include aorrlshC_n.asm. * mpn/x86_64/core2/aorrlsh1_n.asm: New file, include ../aorrlshC_n.asm. * mpn/x86_64/core2/aorrlsh2_n.asm: Likewise. * mpn/x86_64/core2/sublshC_n.asm: New file based on aorslsh1_n.asm. * mpn/x86_64/core2/aorslsh1_n.asm: Remove. * mpn/x86_64/core2/sublsh1_n.asm: Just include sublshC_n.asm. * mpn/x86_64/core2/sublsh2_n.asm: Likewise. 2010-05-08 Torbjorn Granlund * mpn/x86_64/atom/gmp-mparam.h: Disable mpn_rsh1add_n, mpn_rsh1sub_n. * mpn/x86_64/pentium4/aorslshC_n.asm: New file based on aorslsh1_n.asm. * mpn/x86_64/pentium4/aorslsh1_n.asm: Now just include aorslshC_n.asm. * mpn/x86_64/pentium4/aorslsh2_n.asm: New file. 2010-05-07 Torbjorn Granlund * mpn/sparc64: Support operands of >= 2^32 limbs. * mpn/sparc64/lshiftc.asm: New file. * mpn/ia64/divrem_2.asm: Complete rewrite. 2010-05-06 Torbjorn Granlund * tune/tuneup.c (all): Don't call tune_divrem_2. * mpn/generic/divrem_2.c: Complete rewrite. * tune/tuneup.c (tune_mod_1): Fix typo. 2010-05-05 Torbjorn Granlund * mpn/x86_64/mod_1_1.asm (mpn_mod_1_1p): Use macro register names. (mpn_mod_1_1p_cps): Rewrite. * mpn/generic/mod_1_1.c (mpn_mod_1_1p_cps): Micro-optimise. * longlong.h: Undo 2009-03-01 change for powerpc64, it gives poor code. * mpn/x86/pentium4/sse2/mod_1_1.asm: New file. * mpn/powerpc64/mode64/mod_1_1.asm: New file. * tune/tuneup.c (tune_mod_1): Use more typical divisor, for the benefit of machines with early-out multipliers. 2010-05-04 Torbjorn Granlund * tune/tuneup.c (tune_mod_1): Fix typo. * mpn/generic/mod_1_1.c: Undo last change. * mpn/x86_64/mod_1_1.asm: Likewise. 2010-05-03 Niels Möller * mpn/generic/jacobi_lehmer.c (jacobi_hook): New function. (mpn_jacobi_subdiv_step): Deleted function. (mpn_jacobi_lehmer): Use general mpn_gcd_subdiv_step. * mpn/generic/gcd_subdiv_step.c (mpn_gcd_subdiv_step): Reorganized to use a single hook function. * mpn/generic/gcdext.c (mpn_gcdext): Adapted to new hook interface. * mpn/generic/gcdext_lehmer.c (mpn_gcdext_hook): New unified hook function. * mpn/generic/gcd.c (gcd_hook): Renamed from gcd_done, and adapted to new hook interface. * gmp-impl.h (gcd_subdiv_step_hook): New typedef, now a function type, not a struct. (mpn_gcdext_hook): Declare. 2010-05-03 Torbjorn Granlund * mpn/generic/mod_1_1.c: Avoid multiply for 2 limb feed-in. * mpn/generic/mod_1_2.c: Likewise. * mpn/generic/mod_1_3.c: Likewise. * mpn/generic/mod_1_4.c: Likewise. * mpn/x86_64/mod_1_1.asm: Likewise. * mpn/x86_64/mod_1_2.asm: Likewise. * mpn/x86_64/mod_1_4.asm: Likewise. * mpn/x86/k7/mod_1_4.asm: Likewise. * mpn/x86/pentium4/sse2/mod_1_4.asm: Likewise. * mpn/alpha/ev6/mod_1_4.asm: Likewise. * tune/tuneup.c (tune_mod_1): Measure MOD_1_1_TO_MOD_1_2_THRESHOLD and MOD_1_2_TO_MOD_1_4_THRESHOLD before MOD_1U_TO_MOD_1_1_THRESHOLD for correctness. * mpn/powerpc64/sqr_diagonal.asm: Complete rewrite. * mpn/powerpc64/mode64/mod_1_4.asm: New file. 2010-05-02 Torbjorn Granlund * config.guess: Recognise power7. * configure.in: Major overhaul of powerpc support. * mpn/powerpc64/p6/lshift.asm: New file. * mpn/powerpc64/p6/lshiftc.asm: Likewise. * mpn/powerpc64/p6/rshift.asm: Likewise. 2010-04-30 Torbjorn Granlund * configure.in (powerpc64): Support CPU specific mode-less subdirs. * mpn/powerpc64/aix.m4 (PROLOGUE_cpu): Use "named csect" making requested alignment actually honoured. 2010-04-30 Niels Möller * mpn/generic/jacobi_lehmer.c (mpn_jacobi_2): Fixed handling of the case bl == 1. Fixed missing application of reciprocity. 2010-04-29 Niels Möller * configure.in (gmp_mpn_functions): Deleted gcdext_subdiv_step. * mpn/generic/gcdext.c (mpn_gcdext): Use new generalized mpn_gcd_subdiv_step. * mpn/generic/gcdext_lehmer.c (gcdext_update): New function. (gcdext_done): New function. (gcdext_hook): New const hook struct. (mpn_gcdext_lehmer_n): Use new generalized mpn_gcd_subdiv_step. * mpn/generic/gcd.c (gcd_done): New function. (gcd_hook): New const hook struct. (mpn_gcd): Adapted to new mpn_gcd_subdiv_step interface. * mpn/generic/gcd_subdiv_step.c (mpn_gcd_subdiv_step): Reorganized function. Added hook function pointers to the argument list, so the same function can be used for gcd, gcdext, and jacobi. * gmp-impl.h (struct gcd_subdiv_step_hook): New struct. (mpn_gcdext_subdiv_step): Deleted prototype. (struct gcdext_ctx): New struct. (gcdext_hook): Declare const struct. (mpn_gcd_subdiv_step): Updated prototype. * mpn/generic/gcdext_subdiv_step.c: Deleted file. 2010-04-28 Torbjorn Granlund * mpn/powerpc64/lshift.asm: Rewrite. * mpn/powerpc64/rshift.asm: Likewise. * mpn/powerpc64/mode64/lshiftc.asm: New file. * mpn/powerpc64/aix.m4: Align functions to 32-byte boundary. * mpn/powerpc64/darwin.m4: Likewise. * mpn/powerpc64/elf.m4: Likewise. 2010-04-28 Niels Möller * tests/mpz/t-jac.c (check_data): Added some more test cases. * mpn/generic/jacobi_lehmer.c (mpn_jacobi_2): Bugfix, count trailing zeros, not leading. 2010-04-27 Torbjorn Granlund * mpn/powerpc64/mode64/p6/mul_basecase.asm: New file. 2010-04-23 Niels Möller * gmp-impl.h (MPN_GCD_LEHMER_N_ITCH): Deleted. (mpn_gcd_lehmer_n): Deleted declaration. * mpn/generic/gcd.c (gcd_2): Moved from gcd_lehmer.c. (mpn_gcd): Inlined the code from mpn_gcd_lehmer_n. Also use MPN_GCD_SUBDIV_STEP_ITCH rather than MPN_GCD_LEHMER_N_ITCH. 2010-04-22 Torbjorn Granlund * mpn/powerpc64/mode64/bdiv_dbm1c.asm: Swap multiply insns to make them consecutive, for the benefit of POWER6. * mpn/powerpc64/mode64/p6/gmp-mparam.h: New file. 2010-04-21 Torbjorn Granlund * mpn/generic/gcd_lehmer.c: Deleted file. * mpn/powerpc64/mode64/divrem_1.asm: Swap multiply insns to make them consecutive, for the benefit of POWER6. * mpn/powerpc64/mode64/dive_1.asm: Likewise. * mpn/powerpc64/mode64/divrem_2.asm: Likewise. * mpn/powerpc64/mode64/mul_1.asm: Likewise. * mpn/powerpc64/mode64/aorsmul_1.asm: Likewise. * mpn/powerpc64/mode64/aorslshC_n.asm: Swap ldx operands as a temporary workaround for POWER6 pipeline glitch. 2010-04-19 Niels Möller * mpz/jacobi.c (mpz_jacobi): New implementation using mpn_jacobi_lehmer. Currently #if:ed out. * mpn/generic/jacbase.c (mpn_jacobi_base) [JACOBI_BASE_METHOD < 4]: Support inputs with a >= b. * gmp-impl.h (mpn_jacobi_lehmer): Added prototype. (jacobi_table): Declare. (mpn_jacobi_init): New inline function. (mpn_jacobi_finish): Likewise. (mpn_jacobi_update): Likewise. * mpn/generic/jacobi_lehmer.c (mpn_jacobi_lehmer): New file, new function. * configure.in (gmp_mpn_functions): Added jacobi_lehmer. 2010-04-14 Niels Möller * configure.in (gmp_mpn_functions): Added matrix22_mul1_inverse_vector. * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Added matrix22_mul1_inverse_vector.c. * gmp-impl.h (mpn_matrix22_mul1_inverse_vector): Updated for rename of mpn_matrix22_mul1_inverse_vector. * mpn/generic/gcd_lehmer.c (mpn_gcd_lehmer_n): Likewise. * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Likewise. * mpn/generic/hgcd.c (hgcd_step): Likewise. * mpn/generic/matrix22_mul1_inverse_vector.c (mpn_matrix22_mul1_inverse_vector): New file, function moved and renamed... * mpn/generic/hgcd2.c (mpn_hgcd_mul_matrix1_inverse_vector): ...from here. 2010-04-12 Torbjorn Granlund * tests/mpn/t-toom6h.c (SIZE_LOG): Define. * tests/mpn/t-toom8h.c (SIZE_LOG): Likewise. 2010-04-10 Torbjorn Granlund * mpn/ia64/lorrshift.asm: Rewrite feed-in and wind-down code. * mpn/ia64/aorslsh1_n.asm: Adapt to new aorslsh1_n. * mpn/ia64/aorslsh1_n.asm: Likewise. * mpn/ia64/aors_n.asm: Complete rewrite. * mpn/ia64/aorslsh1_n.asm: Likewise. * mpn/ia64/add_n_sub_n.asm: Misc cleanups. Add slotting comments. * mpn/ia64/lshiftc.asm: New file. * mpn/x86_64/pentium4/gmp-mparam.h: No longer disable rsh1add_n and rsh1sub_n; instead disable rsblsh1_n, addlsh2_n, rsblsh2_n. * mpn/x86/divrem_2.asm: Use "orb" instead of "or" to work around Solaris assembler bug. * mpn/x86_64/mpn/x86_64/divrem_2.asm: Likewise. * mpn/x86/aors_n.asm: Use operand-less shift-by-1 insn form. * mpn/x86/pentium/aors_n.asm: Likewise. * mpn/x86_64/invert_limb.asm: Likewise. * mpn/x86_64/pentium4/aors_n.asm: Let non-nc code fall into nc code. * mpn/x86_64/pentium4/rsh1aors_n.asm: New file. 2010-03-25 Torbjorn Granlund * mpn/ia64/add_n_sub_n.asm: New file. * mpn/generic/toom33_mul.c: Fix mpn_add_n_sub_n usage. * mpn/generic/toom3_sqr.c: Likewise. * mpn/generic/toom63_mul.c: Likewise. * mpn/generic/add_n_sub_n.c: Renamed from addsub_n.c. 2010-03-23 Torbjorn Granlund * mpn/x86_64/divrem_2.asm: Use mpn_invert_limb instead of div insn. * mpn/ia64/aorslshC_n.asm: New file, generalised from last iteration of aorslsh1_n.asm. * mpn/ia64/aorslsh1_n.asm: Use aorslshC_n.asm. * mpn/ia64/aorslsh1_n.asm: New file, use aorslshC_n.asm. 2010-03-20 Torbjorn Granlund * mpn/powerpc64/mode64/invert_limb.asm: Rewrite to exploit cancellation in the Newton iteration. 2010-03-20 Marco Bodrato * mpn/generic/toom_interpolate_8pts.c: Use mpn_sublsh2_n. 2010-03-20 Torbjorn Granlund * mpn/powerpc64/mode64/aorslshC_n.asm: New file, generalised from last iteration of aorslsh1_n.asm. * mpn/powerpc64/mode64/aorslsh1_n.asm: Use aorslshC_n.asm. * mpn/powerpc64/mode64/aorslsh1_n.asm: New file, use aorslshC_n.asm. 2010-03-19 Torbjorn Granlund * mpn/x86_64/nano/dive_1.asm: New file. * mpn/x86_64/divrem_1.asm: Avoid shld since it is slow on several CPU types. Unconditionally provide code for normalised and unnormalised divisors. Cleanup labels. * mpn/x86_64/core2/divrem_1.asm: Remove special code for normalised divisors. Cleanup labels. * mpn/generic/toom_interpolate_6pts.c: Call mpn_sublsh2_n and mpn_sublsh_n with correct args. * tests/devel/try.c: Use enum for TYPE_*. * tests/devel/try.c: Test mpn_sublsh2_n. * tests/refmpn.c (refmpn_sublsh2_n): New function. * tests/tests.h (refmpn_sublsh2_n): Declare. * mpn/powerpc64/mode64/aorslsh1_n.asm: New file, with faster mpn_addlsh1_n and mpn_sublsh1_n. * mpn/powerpc64/mode64/addlsh1_n.asm: Delete. * mpn/powerpc64/mode64/sublsh1_n.asm: Delete. 2010-03-18 Torbjorn Granlund * configure.in (*-*-aix): Define gcc_32_cflags_maybe, ar_32_flags and nm_32_flags. * mpn/x86/pentium4/sse2/addlsh1_n.asm: Tune for slightly better speed. Misc cleanups. Add cycle table. * mpn/x86_64/copyi.asm: Update cycle table. * mpn/x86_64/copyd.asm: Likewise. * mpn/x86_64/rsh1aors_n.asm: Likewise. * mpn/x86_64/dive_1.asm: Likewise. * mpn/x86/pentium4/sse2/add_n.asm: Misc cleanups. Add cycle table. * mpn/x86/pentium4/sse2/sub_n.asm: Likewise. 2010-03-16 Torbjorn Granlund * mpn/x86_64/divrem_1.asm: Use mpn_invert_limb instead of div insn. * mpn/x86_64/core2/divrem_1.asm: Likewise. * tune/speed.c (routine): Add FLAG_R_OPTIONAL for many binops. 2010-03-15 Torbjorn Granlund * mpn/alpha/ev6/mod_1_4.asm (mpn_mod_1s_4p_cps): Rewrite. * mpn/ia64/aors_n.asm: Insert explicitly typed nops to trigger intended bundling. * mpn/ia64/aorslsh1_n.asm: Likewise. * mpn/ia64/dive_1.asm: Likewise. 2010-03-13 Torbjorn Granlund * mpn/x86/pentium4/sse2/submul_1.asm: Rewrite. * mpn/powerpc64/mode64/aorsmul_1.asm: New file, faster than old code for both mpn_addmul_1 and mpn_submul_1. * mpn/powerpc64/mode64/addmul_1.asm: Remove. * mpn/powerpc64/mode64/submul_1.asm: Remove. 2010-03-11 Niels Möller * mpn/generic/gcd_lehmer.c (gcd_2): Use sub_ddmmss. * mpn/generic/jacbase.c (mpn_jacobi_base): Reorganized the JACOBI_BASE_METHOD 4 slightly. Now requires that b > 1. 2010-03-10 Torbjorn Granlund * mpn/x86_64/divrem_1.asm: Make fraction code take documented # of cycles. Annotate code for more CPUs. Misc cleanups. * mpn/x86_64/core2/divrem_1.asm: Annotate code for more CPUs. * mpn/alpha/ev6/mod_1_4.asm: New file. * mpn/ia64/mod_34lsub1.asm: New file. * doc/gmp.texi (Language Bindings): Update Python site, add Ruby. 2010-03-10 Niels Möller * tune/tuneup.c (tune_jacobi_base): Consider mpn_jacobi_base_4. * tune/speed.c (routine): Added mpn_jacobi_base_4. * tune/common.c (speed_mpn_jacobi_base_4): New function. * tune/speed.h (speed_mpn_jacobi_base_4): Declare it. * tune/Makefile.am (libspeed_la_SOURCES): Added jacbase4.c. * tune/jacbase4.c: New file. * mpn/generic/jacbase.c (mpn_jacobi_base): New function, for JACOBI_BASE_METHOD 4. 2010-03-09 Niels Möller * tests/mpz/t-jac.c (check_large_quotients): Also generate inputs with large quotients and a large gcd. 2010-03-09 Marco Bodrato * tests/mpz/t-bin.c (randomwalk): New test-generator function. 2010-03-07 Torbjorn Granlund * tune/speed.c (routine): Force r argument for several mod_1 calls. 2010-03-06 Torbjorn Granlund * mpn/x86_64/divrem_1.asm: Disable SPECIAL_CODE_FOR_NORMALIZED_DIVISOR. Misc clean up. * mpn/x86_64/mod_1_1.asm: New file. * mpn/x86_64/mod_1_2.asm: New file. * mpn/x86_64/mod_1_4.asm: Update cycle counts. * tests/tests.h (TESTS_REPS): Fix typo. 2010-03-03 Torbjorn Granlund * mpn/x86_64/core2/divrem_1.asm: New file. 2010-02-26 Niels Möller * tune/speed.c (routine): Added udiv_qrnnd_preinv3. * tune/common.c (speed_udiv_qrnnd_preinv3): New function. * tune/speed.h: Added prototype for it. 2010-02-26 Niels Möller * tests/mpz/t-jac.c (check_large_quotients): New test. Currently disabled, since it's quite slow. (mpz_nextprime_step): New function. 2010-02-26 Torbjorn Granlund * mpn/pa64/aors_n.asm: Fix typo in last change. 2010-02-25 Niels Möller * tests/mpz/t-jac.c (ref_jacobi): New reference implementation, using factorization and legendre symbols computed by powm. * tests/devel/try.c (param_init, call): Don't pass negative values for the second argument to mpz_jacobi and refmpz_jacobi. * tests/refmpz.c (refmpz_jacobi): Require that b is odd and positive. * tests/devel/try.c (param_init): Support mpz_legendre. (choice_array): Added mpz_kronecker (apparently forgotten) and mpz_legendre. (call): Added TYPE_MPZ_LEGENDRE. (try_one): Added support for DATA_SRC1_ODD_PRIME. * tests/refmpz.c (refmpz_legendre): Rewrote using powm. 2010-02-25 Torbjorn Granlund * config.guess: Make "corei" default for unrecognised Intel P6 CPUs. * tests/mpz/t-perfpow.c (check_random): Use mp_limb_t type for limb variables. * tests/mpn/t-toom6h.c (COUNT): Define. * tests/mpn/t-toom8h.c (COUNT): Define. * tests/mpn/t-div.c: Cast a switch index to placate HP's cc. * tests/mpn/t-bdiv.c: Likewise. * mpn/pa64/aors_n.asm: Fix support of the 2.0n ABI. 2010-02-24 Marco Bodrato * tests/mpz/t-bin.c (data): Replace (2k,k), tested by twos (). * tests/mpf/t-inp_str.c (data): Test also "+" in the exponent. 2010-02-23 Torbjorn Granlund * mpn/generic/mod_1_3.c: Cast a switch index to placate HP's cc. * mpn/generic/sqrtrem.c: Use CNST_LIMB. 2010-02-20 Niels Möller * tune/speed.h (mpn_gcd_accel): Deleted prototype. (mpn_hgcd_lehmer): New prototype. (MPN_HGCD_LEHMER_ITCH): New macro (previously in gmp-impl.h). * tune/Makefile.am (libspeed_la_SOURCES): Added hgcd_lehmer.c. * tune/hgcd_lehmer.c: New file. * tune/gcd_accel.c: Deleted obsolete file. * gmp-impl.h (MPN_HGCD_LEHMER_ITCH): Deleted macro. * mpn/generic/hgcd.c (mpn_hgcd_lehmer): Deleted function, (mpn_hgcd): Don't call mpn_hgcd_lehmer, instead use inlined loop around hgcd_step. (mpn_hgcd_itch): Substitute n for MPN_HGCD_LEHMER_ITCH (n). 2010-02-19 Niels Möller * Makefile.am (mpn/jacobitab.h): Added the rules needed to generate this file. * gen-jacobitab.c: New file. 2010-02-19 Torbjorn Granlund * mpn/generic/powm.c: Honour SQR_BASECASE_THRESHOLD in innerloop expansions. 2010-02-16 Niels Möller * tune/time.c (cgt_works_p): Added rudimentary sanity check for clock_gettime working. 2010-02-15 Niels Möller * tune/time.c (speed_time_init): Make use of cycle counter configurable, via the speed_option_cycles_broken flag. * tune/common.c (speed_option_cycles_broken): New global variable. (speed_option_set): Recognize option "cycles-broken". * tune/time.c (cycles_works_p): Deleted hack to disable cycle counter on linux. Needs to be replaced by something more selective. 2010-02-11 Niels Möller * tune/time.c (speed_time_init): Fix speed_time_string when using clock_gettime. (cycles_works_p): On linux, don't use the cycle counter. * tune/Makefile.am: Add $(TUNE_LIBS) when linking programs. * configure.in: Check if -lrt is needed for clock_gettime, and if so, add that flag to TUNE_LIBS. 2010-02-07 Torbjorn Granlund * tune/tuneup.c (tune_redc): Set min_size and min_is_always when measuring REDC_1_TO_REDC_2_THRESHOLD. (tune_mod_1): Set min_size for PREINV_MOD_1_TO_MOD_1_THRESHOLD. * mpn/x86_64/aorrlsh_n.asm (cnt): Fix a typo. * mpn/x86_64/lshsub_n.asm: Likewise. 2010-02-05 Torbjorn Granlund * Version 5.0.1 released. * mpn/generic/powm.c: Use rp target area for power table computation in order to use less scratch. * mpn/generic/binvert.c (mpn_binvert_itch): Enable more economical mpn_mulmod_bnm1_itch call. * mpn/generic/mu_div_qr.c: Remove always true #if. * mpn/generic/mu_divappr_q.c: Likewise. * mpn/generic/mu_bdiv_q.c: Likewise. * mpn/generic/mu_bdiv_qr.c: Likewise. 2010-02-01 Torbjorn Granlund * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*, LIBMP_LT_*): Bump version info. * mpn/powerpc64/mode64/gmp-mparam.h: Remove {MUL,SQR}_FFT_TABLE2. * mpn/x86/p6/gmp-mparam.h: Likewise. * mpn/x86/p6/mmx/gmp-mparam.h: Likewise. * mpn/generic/mul_fft.c: Don't depend on FFT_TABLE2, it was broken. 2010-01-29 Torbjorn Granlund * mpn/generic/mul_fft.c (mpn_mul_fft_internal): Remove arguments n, m, k and rec; add argument sqr. Don't call mpn_mul_fft_decompose here, instead do that in all callers. (mpn_mul_fft): Trim allocation when squaring, and use TMP_ALLOC*, not explicit alloc/free. (mpn_fft_div_2exp_modF): Avoid a scalar division. (mpn_fft_mul_modF_K): Replace some multiplies by K with shifting by k. (mpn_fft_mul_2exp_modF): Make function more symmetrical. 2010-01-27 Torbjorn Granlund * mpn/generic/mu_div_q.c (mpn_mu_div_q_itch): Rewrite. * mpn/generic/mu_div_qr.c (mpn_mu_div_qr_itch): Re-enable better mulmod itch estimate. * mpn/generic/mu_divappr_q.c (mpn_mu_divappr_q_itch): Likewise. * mpn/generic/mu_bdiv_qr.c (mpn_mu_bdiv_qr_itch): Likewise. * mpn/generic/mu_bdiv_q.c (mpn_mu_bdiv_q_itch): Likewise. 2010-01-27 Marco Bodrato * mpn/generic/mu_div_qr.c (mpn_mu_div_qr_itch): Disabled guessed estimate, enabled a conservative one. * mpn/generic/mu_divappr_q.c (mpn_mu_divappr_q_itch): Likewise. * mpn/generic/mu_bdiv_qr.c (mpn_mu_bdiv_qr_itch): Likewise. * mpn/generic/mu_bdiv_q.c (mpn_mu_bdiv_q_itch): Likewise. 2010-01-26 Marco Bodrato * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1): Partial rewrite to reduce memory usage. * mpn/generic/sqrmod_bnm1.c (mpn_sqrmod_bnm1): Likewise. (mpn_sqrmod_bnm1_next_size): New function. * gmp-impl.h (mpn_mulmod_bnm1_itch): Accepts 3 parameters now. (mpn_sqrmod_bnm1_itch): New inline function. (mpn_sqrmod_bnm1_next_size): Declaration and mangling. * mpn/generic/nussbaumer_mul.c: Use the new functions. * mpn/generic/invertappr.c (mpn_ni_invertappr): Use new syntax for mpn_mulmod_bnm1_itch. * mpn/generic/mu_divappr_q.c (mpn_mu_divappr_q_itch): Likewise. * mpn/generic/mu_bdiv_qr.c (mpn_mu_bdiv_qr_itch): Likewise. * mpn/generic/mu_bdiv_q.c (mpn_mu_bdiv_q_itch): Likewise. * mpn/generic/mu_div_qr.c (mpn_mu_div_qr_itch): Likewise. * mpn/generic/binvert.c (mpn_binvert_itch): Likewise. * tune/speed.h (SPEED_ROUTINE_MPN_MULMOD_BNM1_CALL): Likewise. (SPEED_ROUTINE_MPN_MULMOD_BNM1_ROUNDED): Likewise. * tests/mpn/t-sqrmod_bnm1.c, tests/mpn/t-mulmod_bnm1.c: Test reduced memory usage. 2010-01-25 Torbjorn Granlund * tune/tuneup.c (INSERT_FFTTAB): New macro, like old insertion code but also inserting a sentinel. (fftmes): Use INSERT_FFTTAB for inserting new measurements. Limit k range to best_k - 4 ... best_k + 4. 2010-01-23 Torbjorn Granlund * gmp-h.in (__GNU_MP_VERSION_PATCHLEVEL): Bump. (__GMP_MP_RELEASE): New macro. * mpf/div.c: Rewrite to use mpn_div_q. 2010-01-21 Torbjorn Granlund * Add FFT_TABLE3 tables for a basic set of machines. * configure.in: Use -mtune=nocona for 64-bit pentium4. * config.guess: Recognise many more Intel processors. * tune/common.c: Whitespace cleanup. (speed_mpn_matrix22_mul): Rewrite. 2010-01-21 Niels Möller * mpn/generic/nussbaumer_mul.c (mpn_nussbaumer_mul): Take advantage of new mpn_mulmod_bnm1 interface, to reduce allocation. * tests/mpn/t-mulmod_bnm1.c (ref_mulmod_bnm1, main): Adapted to mpn_mulmod_bnm1 interface change. * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1): Interface change, in case an + bn < rn, only write an + bn output limbs. New input requirement, an + bn > rn/2. * mpn/generic/sqrmod_bnm1.c (mpn_sqrmod_bnm1): Corresponding changes. 2010-01-19 Torbjorn Granlund * tune/tuneup.c (fftmes): Round up initial n according to initial k. Limit k to 24 in loop. Remove an obsolete always-true condition. Remove a redundant trace printout. 2010-01-18 Torbjorn Granlund * tune/tuneup.c (fftmes): New function (fft): Rewrite. (mpn_mul_fft_lcm): New function, copied from mpn/generic/mul_fft.c. (fftfill): New function, code taken from mul_fft.c (mpn_mul_fft). (cached_measure): New function. * gmp-impl.h (struct fft_table_nk): Moved from mul_fft.c. (MUL_FFT_TABLE3, SQR_FFT_TABLE3): Provide dummy versions for tuneup builds. (FFT_TABLE3_SIZE): Increase value for tuneup builds. * mpn/generic/mul_fft.c: Handle a new FFT threshold table type ("3"). Misc cleanups to old table type code. 2010-01-16 Torbjorn Granlund * mpn/x86_64/darwin.m4: Fix typo in last change. 2010-01-15 Torbjorn Granlund * gmp-h.in (__GMP_EXTERN_INLINE): Remove "extern" for newer Sun C. * gmp-impl.h (GMP_LIMB_BYTES): New define. * mpn/x86_64/darwin.m4 (LEA): New define. * mpn/x86/invert_limb.asm (approx_tab): Use DEF_OBJECT. Rename and globalise it to work around Mac OS bug. With Philip McLaughlin: * mpn/x86_64/gcd_1.asm (ctz_table): Don't use local prefix, but use DEF_OBJECT...END_OBJECT. Keep stack pointer at ABI mandated alignment over call. 2010-01-12 Torbjorn Granlund * tune/speed.c (routine): Remove obsolete mpn_dc_tdiv_qr and mpn_dc_div_qr_n. * tune/common.c (speed_mpn_dc_tdiv_qr, speed_mpn_dcpi1_div_qr_n): Remove now unused functions. * tune/speed.h (SPEED_ROUTINE_MPN_DC_DIVREM_N, SPEED_ROUTINE_MPN_DC_DIVREM_SB, SPEED_ROUTINE_MPN_DC_TDIV_QR): Remove now unused macros. * mpn/x86_64/fat/fat_entry.asm (mpn_cpuid_available): Remove function. * ltmain.sh: Upgrade from 1.5.24 to 2.2.6b. * ylwrap: New file. * .bootstrap: Remove explicit versions. * doc/gmp.texi (Block-wise Barrett Division): New node. * mpn/generic/powm.c: Change some #if to plain 'if' to avoid fat build problems. 2010-01-11 Torbjorn Granlund * tune/speed.h (SPEED_ROUTINE_MPN_PI1_DIV): Accept arguments for size restrictions. * tune/common.c (speed_mpn_sbpi1_div_qr, speed_mpn_dcpi1_div_qr, (speed_mpn_sbpi1_divappr_q, speed_mpn_dcpi1_divappr_q): Pass size limits for SPEED_ROUTINE_MPN_PI1_DIV. * tune/speed.c (routine): Allow .r argument for mpn_sbpi1_divappr_q and mpn_dcpi1_divappr_q. 2010-01-08 Torbjorn Granlund * Version 5.0.0 released. * mpn/generic/div_q.c: Handle mpn_*_divappr_q returning high limb everywhere. 2010-01-07 Torbjorn Granlund * Update MUL_FFT_TABLE2 and SQR_FFT_TABLE2 for many machines. * mpn/generic/mu_div_q.c: Account for divisor truncation error as well as mpn_mu_divappr_q's error. * mpn/generic/mu_div_q.c: Handle mpn_preinv_mu_divappr_q returning a high limb. * tests/mpn/t-bdiv.c: Move a random call for debugability. * tests/mpn/t-div.c: Likewise. * mpn/generic/mu_divappr_q.c: Rewrite quotient round-up code. * mpn/generic/mu_div_qr.c: Handle carry-out from a carry propagation subtract. * mpn/generic/mu_divappr_q.c: Likewise. * mpn/generic/mu_divappr_q.c (mpn_preinv_mu_divappr_q, mpn_mu_divappr_q): Declare dividend constant. * gmp-impl.h: Likewise. * perfpow.c (mpn_perfect_power_p): Call mpn_divexact instead of mpn_bdiv_q (with too little scratch space!). From Niels Möller: * tests/mpn/t-div.c (check_one): Get rid of the poorly managed variable tn. * mpn/minithres/gmp-mparam.h: Add all lately defined thresholds. * mpn/generic/div_q.c: Use SB division for small quotients as well as small divisors. Fix typo in itch call. 2010-01-06 Niels Möller * tests/mpn/t-div.c (check_one): Checking based on multiplication, refmpn_mul, rather than refmpn_tdiv_qr. 2010-01-06 Marco Bodrato * mpn/generic/toom8h_mul.c: Avoid overflows of mp_size_t. 2010-01-06 Torbjorn Granlund * gmp-h.in (__GNU_MP__): Bump. (__GNU_MP_VERSION,__GNU_MP_VERSION_MINOR,__GNU_MP_VERSION_PATCHLEVEL): Bump version info. * mp-h.in (__GNU_MP__): Bump. * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*, LIBMP_LT_*): Bump version info. * doc/gmp.texi: Rewrite mpn_gcdext text. Remove some out-of-date text in Algorithms chapter. * mpn/generic/div_q.c: Properly handle np=scratch. Fix critical typo in final adjustment code. Misc cleanups. * mpn/generic/rootrem.c: Use mpn_div_q. * mpz/tdiv_q.c: Likewise. * tests/mpn/t-div.c: Test mpn_div_q. (SIZE_LOG): Up to 17. * mpn/generic/div_q.c: New file. * configure.in (gmp_mpn_functions): Add div_q. * mpn/generic/mu_div_q.c: Actually declare dividend constant. 2010-01-04 Torbjorn Granlund * tune/tuneup.c (fft): Separate tuning of modf and full products. (struct fft_param_t): New field, mul_modf_function. (tune_fft_sqr): Fix typo. (tune_fft_mul, tune_fft_sqr): Initialise mul_modf_function field. * tune/common.c (speed_mpn_fft_mul, speed_mpn_fft_sqr): New functions. * tune/speed.h (SPEED_ROUTINE_MPN_MULMOD_BNM1_ROUNDED): Clean up. * mpn/generic/mul.c: Simplify rational expression. * gmp-impl.h: Cleanup threshold variables; remove obsolete ones and make all possibly needed definitions for existing ones. * tune/tuneup.c (tune_mul): Write fractions-compensated values to threshold variables. 2010-01-03 Marco Bodrato * tune/common.c, tune/speed.c, tune/speed.h: Support measuring mpn_toom43_mul. * mpn/generic/toom_interpolate_6pts.c: Small reorganisation. 2010-01-03 Torbjorn Granlund * gmp-impl.h (MUL_TO_MULMOD_BNM1_FOR_2NXN_THRESHOLD): Default to INV_MULMOD_BNM1_THRESHOLD/2 instead. * gmp-impl.h (INV_APPR_THRESHOLD, INV_MULMOD_BNM1_THRESHOLD): Default here... * mpn/generic/invert.c, mpn/generic/invertappr.c: ...not here. * tests/mpn/t-div.c: Rewrite operand generation code. 2010-01-02 Torbjorn Granlund * gmp-impl.h (MUL_TO_MULMOD_BNM1_FOR_2NXN_THRESHOLD): Default to INV_MULMOD_BNM1_THRESHOLD. 2010-01-02 Marco Bodrato * mpn/generic/dcpi1_div_q.c: Handle divappr approximation problem more efficiently. * mpn/generic/mu_div_q.c: Likewise. * mpn/generic/invert.c: Remove duplicated code. 2010-01-01 Torbjorn Granlund * gmp-impl.h (MUL_TO_MULMOD_BNM1_FOR_2NXN_THRESHOLD): Default to 0. * mpn/generic/mu_div_qr.c: Rewrite to use mpn_mulmod_bnm1. Clean up scratch usage. Improve itch functions. * mpn/generic/mu_divappr_q.c: Likewise. * mpn/generic/mu_bdiv_qr.c: Likewise. * mpn/generic/mu_div_q.c: Likewise. * mpn/generic/dcpi1_bdiv_qr.c: Add parameter ASSERTs. * mpn/generic/dcpi1_bdiv_q.c: Likewise. * tests/mpn/t-bdiv.c: Replace with unit testing code, based on t-div.c. Increase COUNT to 500. * tests/mpn/t-div.c: Avoid generating too small test operands. Move SB suppression limit downwards. Increase COUNT to 200. 2009-12-31 Torbjorn Granlund * mpn/generic/tdiv_qr.c: Handle numerator/remainder overlap in MU case. * tests/tests.h (TESTS_REPS): New macro. * tests/mpz/dive.c: Use larger operands, decrease default reps, use TESTS_REPS. * tests/mpz/convert.c: Likewise. * tests/mpz/t-sqrtrem.c: Likewise. * tests/mpz/reuse: Likewise. * tests/mpz/t-root.c: Likewise. * tests/mpz/t-tdiv.c: Likewise. * tests/mpz/t-gcd.c: Likewise. * tests/mpz/t-powm.c: Likewise. 2009-12-31 Marco Bodrato * mpn/generic/toom8_sqr.c (SQR_TOOM8_MAX): Avoid overflow. * mpn/generic/toom6_sqr.c (SQR_TOOM6_MAX): Likewise. * mpn/generic/mulmod_bnm1.c: Don't mention MISUSE any more, simply consider UNLIKELY any unexpected size. 2009-12-31 Torbjorn Granlund * tune/tuneup.c (speed_mpn_sbordcpi1_div_qr): New function. (tune_mu_div): Use it. 2009-12-30 Torbjorn Granlund * tune/tuneup.c (tune_mu_bdiv, tune_dc_bdiv, tune_mu_div) (tune_dc_div): Clear global s.r to make speed functions do 2n/n. * tune/speed.c (routine): New entries for mpn_mu_div_qr and mpn_mupi_div_qr. Allow .r parameter for mpn_sbpi1_div_qr, mpn_dcpi1_div_qr. * tune/speed.h (SPEED_ROUTINE_MPN_PI1_DIV, SPEED_ROUTINE_MPN_MU_DIV_QR) (SPEED_ROUTINE_MPN_MUPI_DIV_QR): Handle .r parameter. * tests/mpz/t-tdiv.c: Increase operands size again. * mpn/generic/tdiv_qr.c: Attempt to choose between DC and MU cleverer. * mpn/generic/tdiv_qr.c: Don't overwrite rp with unnecessary temporary alloc. 2009-12-29 Torbjorn Granlund * tune/tuneup.c (tune_mu_div): Tune MUPI_DIV_QR_THRESHOLD. * tune/speed.h (struct speed_params): Allow 3 source operands. (SPEED_ROUTINE_MPN_MUPI_DIV_QR): New macro. * tune/common.c (speed_mpn_mupi_div_qr): New function. * mpn/generic/tdiv_qr.c: Call mpn_mu_div_qr. * tests/mpz/t-tdiv.c: Use larger test operands. * mpn/generic/mu_div_qr.c (mpn_mu_div_qr2): Remove code for dn==1. * mpz/mul.c: Call mpn_sqr directly. Use PTR,SIZ,ALLOC. * tune/tuneup.c (tune_mu_div): Set min_size to 6, DC functions require this. * tests/mpn/t-div.c: Call mu_div functions with operands that generate a high quotient limb. * mpn/generic/mu_div_qr.c: Rewrite to return a high quotient limb, to let dividend argument be constant, and as a general cleanup. * mpn/generic/mu_divappr_q.c: Likewise. * mpn/generic/mu_div_q.c: Likewise. * gmp-impl.h: Update declarations of changed functions. * mpn/generic/invertappr.c (mpn_invertappr): Allocate scratch space when caller passed NULL. 2009-12-28 Torbjorn Granlund * mpn/generic/toom_couple_handling.c: Prefix name with mpn_. * gmp-impl.h: Likewise. * mpn/generic/toom63_mul.c: Likewise. * mpn/generic/toom6_sqr.c: Likewise. * mpn/generic/toom6h_mul.c: Likewise. * mpn/generic/toom8_sqr.c: Likewise. * mpn/generic/toom8h_mul.c: Likewise. * configure.in (gmp_mpn_functions_optional) Move "com" from here... (gmp_mpn_functions): ...to here. * mpn/generic/com.c: New file. * (mpn_com): New name for mpn_com_n. Make public. * (mpn_neg): Analogous changes. * tune/tuneup.c (tune_mu_div, tune_mu_bdiv): Set step_factor. * tune/common.c, tune/speed.c, tune/speed.h: Support measuring mpn_lshiftc. * tests/devel/try.c: Test mpn_lshiftc. * tests/refmpn.c (refmpn_com): New function. (refmpn_lshiftc): Likewise. * configure.in (gmp_mpn_functions_optional) Move lshiftc from here... (gmp_mpn_functions): ...to here. * mpn/generic/lshiftc.c: New file. * mpn/x86_64/lshiftc.asm: New file. * mpn/x86_64/core2/lshiftc.asm: New file. * mpn/generic/mul_fft.c (mpn_lshiftc): Remove. * mpn/x86_64/core2/lshift.asm: Tweak for better Core iN performance. * mpn/x86_64/core2/rshift.asm: Likewise. 2009-12-27 Marco Bodrato * mpn/generic/mul.c: Use toom6h and toom8h for almost balanced. * mpn/generic/mullo_n.c (mpn_dc_mullo_n): New ratio, to be used in Toom-8 range. 2009-12-27 Torbjorn Granlund * (mpn_sqr): New name for mpn_sqr_n. Many files affected. * tune/tuneup.c (tune_mullo): Up step_factor for MULLO_MUL_N_THRESHOLD. (tune_invertappr, tune_invert, tune_binvert): Let max_size default. * tune/tuneup.c (tune_mu_div, tune_mu_bdiv) New functions. * tune/speed.h (SPEED_ROUTINE_MPN_MU_DIV_Q): New macro. (SPEED_ROUTINE_MPN_MU_DIV_QR): Likewise. (SPEED_ROUTINE_MPN_MU_BDIV_Q): Likewise. (SPEED_ROUTINE_MPN_MU_BDIV_QR): Likewise. * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add bdiv_q.c and bdiv_qr.c. * tune/common.c (speed_mpn_mu_div_qr): New function. (speed_mpn_mu_divappr_q): Likewise. (speed_mpn_mu_div_q): Likewise. (speed_mpn_mu_bdiv_q): Likewise. (speed_mpn_mu_bdiv_qr): Likewise. * mpn/*/gmp-mparam.h: Fix incorrect MOD_1U_TO_MOD_1_1_THRESHOLD 0 values. * gmp-impl.h (MODEXACT_1_ODD_THRESHOLD): Remove. (BMOD_1_TO_MOD_1_THRESHOLD): New parameter, with the reverse meaning of MODEXACT_1_ODD_THRESHOLD. (MPN_MOD_OR_MODEXACT_1_ODD): Use BMOD_1_TO_MOD_1_THRESHOLD. * mpn/generic/divis.c, mpz/{cong.c,cong_ui.c,divis_ui.c}: Likewise. * tune/tuneup.c (tune_modexact_1_odd): Tune BMOD_1_TO_MOD_1_THRESHOLD; Do not assume native mpn_modexact_1_odd is faster than mpn_mod_1. (tuned_speed_mpn_mod_1): Remove variable. (tune_mod_1): Fix thinkos. Suppress printing of "always" etc. (all): Measure for divrem_1, mod_1, divexact_1, etc first, since Toom depends on some of them. * mpn/generic/toom22_mul.c (TOOM22_MUL_REC): New name for TOOM22_MUL_MN_REC. 2009-12-26 Niels Möller * tests/mpn/t-toom32.c (MIN_AN, MIN_BN, MAX_BN): Relax requirements a bit. * mpn/generic/toom32_mul.c (mpn_toom32_mul): Relax requirement on input sizes, to support s+t>=n (used to be s+t>=n+2). Keep high limbs of the evaluated values in scalar variables. * mpn/generic/sbpi1_divappr_q.c (mpn_sbpi1_divappr_q): Remove unused variables. * mpn/generic/toom32_mul.c (mpn_toom32_mul): Fixed left-over use of mpn_addsub_n which should be mpn_add_n_sub_n. 2009-12-26 Marco Bodrato * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add new toom files (spotted by Torbjorn). * gmp-impl.h (mpn_toom6_sqr_itch): Rename to mpn_toom6_mul_n_itch and redefine. (mpn_toom8_sqr_itch): Rename to mpn_toom8_mul_n_itch and redefine. * mpn/generic/mul_n.c: Use renamed _itch macros. 2009-12-25 Niels Möller * tests/mpn/t-toom32.c (MIN_AN, MIN_BN, MAX_BN): Tightened requirements. * gmp-impl.h (mpn_toom32_mul_itch): Updated. Less scratch needed by toom32 itself, and also the pointwise multiplications are currently mpn_mul_n with no supplied scratch. * mpn/generic/toom32_mul.c (mpn_toom32_mul): Reorganized interpolation to use less scratch space. No longer supports the most extreme size ratios. 2009-12-25 Torbjorn Granlund * tune/tuneup.c (tune_preinv_mod_1): Purge. (tune_mod_1): Use speed_mpn_mod_1_tune for PREINV_MOD_1_TO_MOD_1_THRESHOLD * mpn/generic/dcpi1_divappr_q.c: Handle 2n/n properly. Don't use full precision in mpn_sbpi1_divappr_q call. Misc cleanup. * tune/tuneup.c (tune_mod_1): Add a check_size for PREINV_MOD_1_TO_MOD_1_THRESHOLD. 2009-12-24 Torbjorn Granlund * tune/mod_1_div.c (MOD_1N_TO_MOD_1_1_THRESHOLD, (MOD_1U_TO_MOD_1_1_THRESHOLD): Set. * tune/mod_1_inv.c (MOD_1N_TO_MOD_1_1_THRESHOLD, (MOD_1U_TO_MOD_1_1_THRESHOLD): Set. * gmp-impl.h (USE_PREINV_MOD_1): Remove. (MPN_MOD_OR_PREINV_MOD_1): Define to choose functions dynamically in terms of PREINV_MOD_1_TO_MOD_1_THRESHOLD (used to choose statically using USE_PREINV_MOD_1). * mpn/generic/perfsqr.c (PERFSQR_MOD_PP): Corresponding updates. * tune/tuneup.c (tune_mod_1): Rewrite. * gmp-impl.h (MOD_1N_TO_MOD_1_1_THRESHOLD): New. (MOD_1U_TO_MOD_1_1_THRESHOLD): New name for MOD_1_1_THRESHOLD. (MOD_1_1_TO_MOD_1_2_THRESHOLD): Mew name for MOD_1_2_THRESHOLD. (MOD_1_2_TO_MOD_1_4_THRESHOLD): New name for MOD_1_4_THRESHOLD. * mpn/generic/mod_1.c: Corresponding updates. 2009-12-24 Marco Bodrato * mpn/generic/mul_n.c: Use also toom6h and toom8h. * mpn/generic/sqr_n.c: Use also toom6 and toom8. * gmp-impl.h: Initial support for tuning of Toom-6half and Toom-8half. * tune/tuneup.c: Tune Toom-6half and Toom-8half thresholds. 2009-12-24 Torbjorn Granlund * mpn/generic/mod_1_4.c: Get ASSERT right. * mpn/generic/mod_1_3.c: Likewise. * mpn/generic/mod_1_2.c: Likewise. * mpn/generic/powm_sec.c: Use SQR_TOOM2_THRESHOLD as limit for a native mpn_sqr_basecase, not TUNE_SQR_TOOM2_MAX. 2009-12-23 Marco Bodrato * tune/common.c, tune/speed.c, tune/speed.h: Support for measuring mpn_toom8h_mul and mpn_toom8_sqr speed. * mpn/generic/toom_eval_pm2exp.c: Fix ASSERTs. * mpn/generic/toom8h_mul.c: New file. * mpn/generic/toom8_sqr.c: New file. * mpn/generic/toom_interpolate_16pts.c: New file. * gmp-impl.h: Provide corresponding declarations. * configure.in (gmp_mpn_functions): List toom_interpolate_16pts, toom8h_mul, and toom8h_sqr. * tests/mpn/t-toom8h.c: New test program. * mpn/generic/toom6_sqr.c: New file, was part of toom6h_mul. * mpn/generic/toom6h_mul.c: Removed _sqr. * mpn/generic/mulmod_bnm1.c: Nailify CRT. * mpn/generic/sqrmod_bnm1.c: Likewise. * mpn/generic/mullo_n.c: Split dc_mullo_n function; ALLOC memory at once. * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Update. * mpn/generic/toom6h_mul.c: Add prefix to toom_interpolate_12pts. * mpn/generic/toom_interpolate_12pts.c: Likewise. * mpn/generic/invertappr.c (mpn_bc_invertappr): Use mpn_divrem_2. * mpn/generic/invert.c: Faster basecase, use mpn_sbpi1_div_q. * mpn/generic/toom_eval_pm2exp.c: Assert support for degree 3. * mpn/generic/toom6h_mul.c: Avoid obsolete _itch function. 2009-12-23 Torbjorn Granlund * tune/common.c, tune/speed.c, tune/speed.h: Support for measuring mpn_mod_1_1p, mpn_mod_1s_2p, mpn_mod_1s_3p, mpn_mod_1s_4p. * tests/mpz/t-powm.c: Test mpz_powm_sec. * mpz/powm_sec.c: New file. * gmp-h.in: Declare it. * Makefile.am, mpz/Makefile.am: Compile it. * doc/gmp.texi: Document it. * mpn/generic/powm_sec.c (mpn_powm_sec_itch): New function. (mpn_powm_sec): Use passed scratch, no local allocation. Allow exp argument = 1. (win_size): Start loop from 1. * mpn/generic/powm.c (win_size): Start loop from 1. 2009-12-22 Torbjorn Granlund * tests/mpn/t-div.c: New file. * tests/mpn/Makefile.am: Compile it. * mpn/generic/mu_divappr_q.c: Handle quotient overflow. * mpn/generic/mu_div_q.c (mpn_mu_div_q_itch): New function. 2009-12-22 Niels Möller * mpn/generic/sbpi1_div_q.c: Use udiv_qr_3by2. Intended to change nothing after preprocessing. * mpn/generic/sbpi1_divappr_q.c: For the last call to udiv_qr_3by2, avoid using memory locations as output parameters, and revert to explicitly copying n1 and n0 to memory. * gmp-impl.h (udiv_qr_3by2): Tweaked to expand to precisely the same code as was used before the introduction of this macro. Eliminated some local variables, instead do multiple updates to the output parameters. 2009-12-22 Torbjorn Granlund * tests/mpn/t-toom6h.c (MIN_AN): Set to MUL_TOOM6H_THRESHOLD to avoid invalid recursive sizes. * tests/mpn/t-bdiv.c: Get itch function calls right. * mpn/generic/mu_bdiv_q.c (mpn_mu_bdiv_q_itch): Rewrite. * mpn/generic/mu_bdiv_qr.c (mpn_mu_bdiv_qr_itch): Simplify. * mpn/generic/bdiv_qr.c (mpn_bdiv_qr): Simplify, don't allocate. (mpn_bdiv_qr_itch): Conditionalise on MU_BDIV_QR_THRESHOLD. 2009-12-18 Niels Möller * tests/mpn/t-bdiv.c: Add red-zones. 2009-12-21 Torbjorn Granlund * mpn/generic/sbpi1_div_q.c: Fix fixup code to work for qn = 0. * mpn/generic/dcpi1_divappr_q.c: Handle qn = 1 and qn = 2 for initial quotient block (code block copied from dcpi1_div_qr.c). * mpn/generic/dcpi1_div_qr.c: Rewrite singular case giving q limb of GMP_NUMB_MAX. Remove an impossible qn = 0 case. * mpn/generic/dcpi1_bdiv_q.c: Remove a spurious mpn_sub_1. * mpn/generic/mul.c: Put back call to mpn_mul_n. * tune/tuneup.c (all): Call tune_mulmod_bnm1 before tuning fft due to dependency on mulmod_bnm1 from both mul_fft_mul and from mullo_n. * mpn/generic/dcpi1_divappr_q.c: ASSERT that dn >= 6 and nn > dn. * mpn/generic/dcpi1_div_q.c: ASSERT that dn >= 6 and nn-dn >= 3. * mpn/generic/dcpi1_div_qr.c: ASSERT that dn >= 6 and nn-dn >= 3. * mpn/generic/bdiv_q_1.c (mpn_pi1_bdiv_q_1): Renamed from mpn_bdiv_q_1_pi1. * All references changed. * configure.in: Add --enable-old-fft-full. * tune/speed.c (routine): Conditionalise mpn_mul_fft_full references on WANT_OLD_FFT_FULL. * tune/common.c (speed_mpn_mul_fft_full) (speed_mpn_mul_fft_full_sqr): Likewise. * mpn/generic/mul_fft.c (mpn_mul_fft_full): Include iff WANT_OLD_FFT_FULL. 2009-12-21 Marco Bodrato * gmp-impl.h (mpn_toom6h_mul_itch): New inline function. (MUL_TOOM6H_THRESHOLD): Default value. (SQR_TOOM6_THRESHOLD): Default value. * mpn/generic/toom6h_mul.c: Remove definitions moved to gmp-impl.h. * tune/common.c, tune/speed.c, tune/speed.h: Support for measuring mpn_toom6h_mul and mpn_toom6_sqr speed. * mpn/generic/toom63_mul.c: Remove unused TMP_*. * mpn/generic/toom_eval_pm2rexp.c: New file. * gmp-impl.h: Provide corresponding declaration. * configure.in (gmp_mpn_functions): List toom_eval_pm2rexp. * mpn/generic/toom6h_mul.c: Use shared toom_eval_pm2rexp. * mpn/generic/toom_couple_handling.c: New file, helper function for high degree Toom. * gmp-impl.h: Provide corresponding declaration. * configure.in (gmp_mpn_functions): List toom_couple_handling. * mpn/generic/toom6h_mul.c: Use shared toom_couple_handling. * mpn/generic/toom63_mul.c: Likewise. * mpn/generic/toom6h_mul.c: New file. * mpn/generic/toom_interpolate_12pts.c: New file. * gmp-impl.h: Provide corresponding declarations. * configure.in (gmp_mpn_functions): List toom_interpolate_12pts, toom6h_mul. * tests/mpn/t-toom6h.c: New test program. * tests/mpn/t-mulmod_bnm1.c (ref_mulmod_bnm1): Use ref_mul. * tests/mpn/t-sqrmod_bnm1.c (ref_sqrmod_bnm1): Likewise. 2009-12-20 Marco Bodrato * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1): New CRT. * mpn/generic/sqrmod_bnm1.c (mpn_sqrmod_bnm1): Likewise. 2009-12-20 Torbjorn Granlund * Change all bit counts for bignums to use mp_bitcnt_t. * mpn/generic/bdivmod.c: File removed. All references purged. * mpn/generic/mul_fft.c (mpn_mul_fft_full): Disable. * gmp-impl.h: Define mpn_fft_mul as an alias for mpn_nussbaumer_mul. * mpn/generic/mul.c: Refer mpn_fft_mul. * mpn/generic/mul_n.c: Likewise. * mpn/generic/sqr_n.c: Likewise. * mpn/generic/mullo_n.c: Likewise. * mpn/generic/mul.c: Loop also over mpn_nussbaumer_mul, as suggested by Marco. Use TMP_SALLOC_LIMBS in more places. Clean up ws allocation. 2009-12-19 Marco Bodrato * mpn/generic/toom_interpolate_8pts.c: Nailify. 2009-12-19 Torbjorn Granlund * mpn/generic/mul.c: Major rewrite. Use toom43, toom53, toom63. Call mpn_nussbaumer_mul for largest operands. * tune/speed.h (SPEED_ROUTINE_MPN_TOOM32_FOR_TOOM43_MUL): New macro. (SPEED_ROUTINE_MPN_TOOM43_FOR_TOOM32_MUL): New macro. (SPEED_ROUTINE_MPN_TOOM32_FOR_TOOM53_MUL): New macro. (SPEED_ROUTINE_MPN_TOOM53_FOR_TOOM32_MUL): New macro. (SPEED_ROUTINE_MPN_TOOM42_FOR_TOOM53_MUL): New macro. (SPEED_ROUTINE_MPN_TOOM53_FOR_TOOM42_MUL): New macro. * tune/common.c (speed_mpn_toom63_mul): New function. (speed_mpn_toom32_for_toom43_mul): New function. (speed_mpn_toom43_for_toom32_mul): New function. (speed_mpn_toom32_for_toom53_mul): New function. (speed_mpn_toom53_for_toom32_mul): New function. (speed_mpn_toom42_for_toom53_mul): New function. (speed_mpn_toom53_for_toom42_mul): New function. * tune/tuneup.c (tune_mul_n): New name for old tune_mul. (tune_sqr_n): New name for old tune_sqr. (tune_mul): New function, for unbalanced multiplication. * gmp-impl.h: Provide declarations for corresponding threshold vars. * gmp-impl.h (mpn_rsh1add_nc, mpn_rsh1sub_nc): Declare. * mpn/asm-defs.m4: Likewise. * configure.in: Add corresponding HAVE_NATIVEs. * mpn/x86_64/rsh1aors_n.asm: Add _nc entry point. 2009-12-18 Niels Möller * mpz/divexact.c: Rewrite to use mpn_divexact. * mpn/generic/bdiv_q_1.c (mpn_bdiv_q_1): Deleted some unused variables. * mpn/generic/toom52_mul.c (mpn_toom52_mul) [HAVE_NATIVE_mpn_add_n_sub_n]: Moved declaration of cy to avoid a compiler warning. * gmp-impl.h (gmp_pi1_t): Eliminated inv21 member. (invert_pi1): ...and don't store it here. * mpn/generic/toom63_mul.c (mpn_toom63_mul): Simplified calculation of block size n. * gmp-impl.h (mpn_toom63_mul_itch): Likewise. * mpn/generic/toom_eval_pm2exp.c (mpn_toom_eval_pm2exp): Fixed output asserts. 2009-12-18 Torbjorn Granlund * tests/mpn/t-toom63.c: New test program. 2009-12-18 Marco Bodrato * mpn/generic/invert.c: Nailify. * mpn/generic/invertappr.c: Nailify. * mpn/generic/mulmod_bnm1.c: Nailify. * mpn/generic/sqrmod_bnm1.c: Nailify. * tests/mpn/t-invert.c: New test program. * mpn/generic/toom63_mul.c: New file. * mpn/generic/toom_interpolate_8pts.c: New file. * gmp-impl.h: Provide corresponding declarations. * configure.in (gmp_mpn_functions): List toom_interpolate_8pts and toom63_mul. 2009-12-17 Torbjorn Granlund * mpn/generic/mul.c: Move allocation of ws to where it is used. Identify toom22, 32, 42, in that order (in two places). Use midline between toom22, 32, 42. * mpn/generic/toom22_mul.c (TOOM22_MUL_MN_REC): Call also mpn_toom32_mul. * doc/gmp.texi: Update References section. Update Contributors section. Misc updates. * gmp-impl.h: Renew default values for all THRESHOLDs. 2009-12-17 Niels Möller * mpn/generic/divexact.c (mpn_divexact): Don't require that the dividend is normalized. Use MPN_DIVREM_OR_PREINV_DIVREM_1. When shifting, allocate and process only the low qn+1 limbs. Eliminated code for the impossible case nn < qn. * mpn/generic/dcpi1_div_qr.c (mpn_dcpi1_div_qr): Added some input asserts. * mpn/generic/dcpi1_div_qr.c (mpn_dcpi1_div_qr): In the case that the initial quotient block is a single limb, use 3/2 division, thereby eliminating the only use of gmp_pi1_t->inv21. 2009-12-17 Marco Bodrato * mpn/generic/invert.c: Added some comment. * mpn/generic/invertappr.c: Slightly better threshold handling. * gmp-impl.h (INV_NEWTON_THRESHOLD): Default to 200. * mpn/generic/nussbaumer_mul.c: New file. * configure.in (gmp_mpn_functions): Add nussbaumer_mul. * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add nussbaumer_mul. * gmp-impl.h (mpn_nussbaumer_mul): Added prototype and name-mangling. * tune/speed.h (speed_mpn_nussbaumer_mul): Declare function. * tune/common.c (speed_mpn_nussbaumer_mul): New function. * tune/speed.c (routine): Add speed_mpn_nussbaumer_mul. * mpn/generic/sqrmod_bnm1.c: New file. * configure.in (gmp_mpn_functions): Add sqrmod_bnm1. * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add sqrmod_bnm1. * gmp-impl.h (mpn_sqrmod_bnm1): Added prototype and name-mangling. (SQRMOD_BNM1_THRESHOLD): support for the new threshold. * tune/speed.h (speed_mpn_sqrmod_bnm1): Declare function. * tune/common.c (speed_mpn_sqrmod_bnm1): New function. * tune/speed.c (routine): Add speed_mpn_sqrmod_bnm1. * tests/mpn/t-mulmod_bnm1.c: Attribution. * tests/mpn/t-sqrmod_bnm1.c: New test file. * tests/mpn/Makefile.am (check_PROGRAMS): Add t-sqrmod_bnm1. * tune/tuneup.c: Tune SQRMOD_BNM1_THRESHOLD. * mpn/generic/nussbaumer_mul.c (mpn_nussbaumer_mul): Mimic fft_mul, use squaring if operands coincide. * tune/speed.h (speed_mpn_nussbaumer_mul_sqr): Declare function. * tune/common.c (speed_mpn_nussbaumer_mul_sqr): New function. * tune/speed.c (routine): Add speed_mpn_nussbaumer_mul_sqr. 2009-12-17 Torbjorn Granlund * mpn/generic/bdiv_q.c (mpn_bdiv_q_itch): Rewrite. 2009-12-16 Torbjorn Granlund * tests/mpn/t-bdiv.c (bdiv_q_valid_p, bdiv_qr_valid_p): Call refmpn_mul instead of refmpn_mul_basecase. * tests/mpn/toom-shared.h: Likewise. * tests/refmpn.c (refmpn_mullo_n,refmpn_sqr,refmpn_mul_any): Likewise. * minithres/gmp-mparam.h: Add new thresholds, trim old values. * mpn/generic/powm.c: Use mp_bitcnt_t for bit counts. Handle REDC_1_TO_REDC_N_THRESHOLD < MUL_TOOM22_THRESHOLD in non-WANT_REDC_2 INNERLOOP expansion code. * mpn/generic/powm_sec.c: Use mp_bitcnt_t for bit counts. 2009-12-16 Niels Möller * tests/mpz/t-gcd.c (main): Added test case to exercise the unlikely u0 == u1 case in mpn_gcdext_lehmer_n. * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Get ASSERT right. 2009-12-16 Torbjorn Granlund * tests/mpz/t-mul.c: Misc cleanups. (mul_basecase): Remove. (ref_mpn_mul): Remove. * tests/refmpn.c (refmpn_mul): New function, mainly from t-mul.c's ref_mpn_mul. (refmpn_mullo_n): Add a missing free. * tune/speed.c (routine): Measure speed_mpn_{sb,dc}pi1_div_qr, mpn_{sb,dc}pi1_divappr_q, mpn_{sb,dc}pi1_bdiv_qr, and mpn_{sb,dc}pi1_bdiv_q. * mpn/generic/invertappr.c: New file, meat from invert.c. * mpn/generic/invert.c: Leave just mpn_invert.c. * configure.in (gmp_mpn_functions): Add invertappr. * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add invertappr.c. * gmp-impl.h (mpn_invert_itch, mpn_invertappr_itch): New macros. 2009-12-15 Torbjorn Granlund * mpn/generic/gcdext_subdiv_step.c: Get an ASSERT right. 2009-12-15 Niels Möller * mpn/generic/sbpi1_div_qr.c (mpn_sbpi1_div_qr): A very small step towards nail support. 2009-12-15 Marco Bodrato * gmp-impl.h (mpn_ni_invertappr): Added prototype and name-mangling. * mpn/generic/mulmod_bnm1.c: Comment representation of class [0]. 2009-12-14 Niels Möller * mpn/generic/sbpi1_divappr_q.c (mpn_sbpi1_divappr_q): Use udiv_qr_3by2. 2009-12-14 Torbjorn Granlund * tune/tuneup.c (tune_binvert): Remove BINV_MULMOD_BNM1_THRESHOLD tuning, it was always zero and caused BINV_NEWTON_THRESHOLD to be wrong (as pointed out by Marco). * (BINV_MULMOD_BNM1_THRESHOLD): Clean from other files too. 2009-12-14 Marco Bodrato * mpn/generic/invert.c: Improved comments. (mpn_bc_invertappr): Conditionally re-enable mpn_dcpi1_divappr_q. 2009-12-14 Niels Möller * gmp-impl.h (udiv_qr_3by2): Fix typo in argument list. 2009-12-13 Niels Möller * gmp-impl.h (udiv_qr_3by2): New macro. * mpn/generic/sbpi1_div_qr.c (mpn_sbpi1_div_qr): Use udiv_qr_3by2. 2009-12-13 Torbjorn Granlund * mpn/generic/dcpi1_divappr_q.c (mpn_dcpi1_divappr_q): Avoid a buffer overrun. * mpn/generic/mul_fft.c (mpn_mul_fft_full): Handle carry-out from 2nd mpn_mul_fft, add an ASSERT for the 1st mpn_mul_fft. Replace some comments on cc's range with ASSERTs. * mpn/generic/gcdext.c (compute_v): Normalise tp[] after mpn_mul. * mpz/powm.c: Rework buffer handling. 2009-12-13 Niels Möller * tests/mpn/toom-shared.h (main): Use refmpn_mul_basecase to check results (slow!). Iteration counts of all toom tests reduced considerably. 2009-12-13 Marco Bodrato * mpn/generic/invert.c (mpn_invertapp): Split in _bc and _ni. (mpn_bc_invertappr): New function, the basecase. (mpn_ni_invertapp): New function, Newton iteration. (mpn_invert): Use mpn_ni_invertapp. * tune/tuneup.c (tune_invert): Min for INV_APPR_THRESHOLD. (tune_invertappr): Min for INV_NEWTON_THRESHOLD. * tune/speed.h (SPEED_ROUTINE_MPN_NI_INVERTAPPR): New macro. (speed_mpn_ni_invertappr): Declare function. * tune/common.c (speed_mpn_ni_invertappr): New function. * tune/speed.c (routine): Add speed_mpn_ni_invertappr. * tune/tuneup.c (tune_invertappr): Use speed_mpn_ni_invertappr to tune INV_MULMOD_BNM1_THRESHOLD. 2009-12-12 Torbjorn Granlund * mpn/generic/mu_bdiv_qr.c (mpn_mu_bdiv_qr_itch): Rewrite. 2009-12-12 Marco Bodrato * tests/mpn/t-mulmod_bnm1.c (main): Disable B^n+1 stressing test for odd sizes. * mpn/generic/invert.c: Complete rewrite. Uses Newton iterations. * gmp-impl.h (mpn_invertappr): Added prototype and name-mangling. (mpn_invertappr_itch): Added prototype and name-mangling. (INV_APPR_THRESHOLD): Support for a new tunable const. * tune/speed.h (SPEED_ROUTINE_MPN_INVERTAPPR): New macro. (speed_mpn_invertappr): Declare function. * tune/common.c (speed_mpn_invertappr): New function. * tune/speed.c (routine): Add speed_mpn_invertappr. * tune/tuneup.c (tune_invertappr): New function: was tune_invert. (tune_invert): Now tune only INV_APPR_THRESHOLD. (all): Enable call to tune_invert and tune_invertappr. 2009-12-11 Torbjorn Granlund * mpn/generic/binvert.c: Use mpn_mulmod_bnm1 instead of FFT wrapping. Old, evidently broken wrapping code removed. * tune/tuneup.c (tune_binvert): Tune BINV_MULMOD_BNM1_THRESHOLD. * gmp-impl.h: Provide declarations for corresponding threshold var. * tests/mpn/t-bdiv.c (COUNT): Decrease to keep run time reasonable. * tune/tuneup.c (tune_invert): Tune INV_MULMOD_BNM1_THRESHOLD. * gmp-impl.h: Provide declarations for corresponding threshold var. * tests/mpn/t-mulmod_bnm1.c: Avoid a division by zero. * configure.in: Set up different paths for different 64-bit sparc processors. * mpn/sparc64/ultrasparc34/gmp-mparam.h: New file. 2009-12-10 Torbjorn Granlund * mpn/*/gmp-mparam.h: Regenerate many of these files. 2009-12-10 Niels Möller * gmp-impl.h (mpn_divexact): Removed scratch pointer from prototype. * mpn/generic/gcdext.c (divexact): Deleted, moved to... * mpn/generic/divexact.c (mpn_divexact): New implementation (moved from gcdext.c). The bidirectional divexact is kept but #if:ed out. Interface change, since the new code doesn't take a scratch argument. * tests/mpn/t-mulmod_bnm1.c (main): Ensure that an >= bn. Lowered MIN_N to 1. Various fixes to handle n == 1 properly. * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1): Small interface change, require an >= bn. * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1): Fixed non-recursive case to not write beyond end of result area. 2009-12-09 Torbjorn Granlund * tune/speed.h (SPEED_ROUTINE_MPN_MULMOD_BNM1_CALL): New macro, made from now deleted SPEED_ROUTINE_MPN_MULMOD_BNM1. * tune/common.c (speed_mpn_bc_mulmod_bnm1): New function. (speed_mpn_mulmod_bnm1): Use SPEED_ROUTINE_MPN_MULMOD_BNM1_CALL. * tune/speed.c (routine): Add mpn_bc_mulmod_bnm1. * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1_next_size): Rewrite. * tune/tuneup.c (tune_mulmod_bnm1): Rewrite. 2009-12-08 Marco Bodrato * mpn/generic/mulmod_bnm1.c (mpn_bc_mulmod_bnm1, mpn_bc_mulmod_bnp1): Added a parameter for scratch area, possibly same as result area (as suggested by Niels Möller). (mpn_mulmod_bnm1): Calls changed accordingly. 2009-12-08 Niels Möller * mpn/generic/gcdext_1.c (mpn_gcdext_1) [GCDEXT_1_USE_BINARY]: Use table lookup for count_trailing_zeros. Binary algorithm still disabled by default. * mpn/generic/gcdext.c (divexact): Local definition of divexact, using mpn_bdiv_q. (compute_v): Use it. * tests/mpn/Makefile.am (check_PROGRAMS): Added t-bdiv. * tests/mpn/t-bdiv.c: New file. * mpn/generic/bdiv_q.c (mpn_bdiv_q): Fixed bad quotient length, should have qn == nn. * mpn/generic/bdiv_qr.c (mpn_bdiv_qr): Pass correct nn length to the lower-level functions. 2009-12-08 Torbjorn Granlund * tune/speed.h (SPEED_ROUTINE_MPN_MULMOD_BNM1_ROUNDED): New define. * tune/common.c (speed_mpn_mulmod_bnm1_rounded): New function. * tune/speed.c (routine): Add mpn_mulmod_bnm1_rounded for measuring mpn_mulmod_bnm1 at recommended sizes. * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1_next_size): Rewrite. (mpn_bc_mulmod_bnm1): Use mpn_add_n instead of mpn_add. * tune/speed.c (routine): Add mpn_invert. * tune/tuneup.c (tune_invert): New function. * tune/speed.h (SPEED_ROUTINE_MPN_INVERT): New macro. * tune/common.c (speed_mpn_invert): New function. * gmp-impl.h: Provide declarations for corresponding threshold var. * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add invert.c. 2009-12-08 Marco Bodrato * tests/devel/try.c: Test mpn_addlsh2_n and mpn_{add,sub}lsh_n; mpn_rsblsh_n now tests all shift values. * tests/refmpn.c (refmpn_addlsh_n, refmpn_sublsh_n): New functions. (refmpn_addlsh1_n): Use generic refmpn_addlsh_n. (refmpn_sublsh1_n): Use generic refmpn_sublsh_n. (refmpn_addlsh2_n): New function. * tests/tests.h: Declare new functions. 2009-12-06 Torbjorn Granlund * tune/tuneup.c (tune_mulmod_bnm1): Up min_size to 12. * Globally: Rename *mullow* to *mullo*, *MULLOW* to *MULLO*. * configure.in: Don't include ev5 directory for ev6* and ev7. Misc alpha path cleanups. * mpn/alpha/add_n.asm: Replaced by mpn/alpha/ev5/add_n.asm. * mpn/alpha/sub_n.asm: Replaced by mpn/alpha/ev5/sub_n.asm. * mpn/alpha/lshift.asm: Replaced by mpn/alpha/ev5/lshift.asm. * mpn/alpha/rshift.asm: Replaced by mpn/alpha/ev5/rshift.asm. * mpn/alpha/com_n.asm: New, moved from mpn/alpha/ev5/rshift.asm. * mpn/alpha/ev5/diveby3.asm: New, moved from mpn/alpha/diveby3.asm. * mpn/powerpc64/mode64/diveby3.asm: Remove, it is slower than mpn_bdiv_dbm1c on all hardware. * mpn/generic/powm_sec.c: Rework logic for mpn_sqr_basecase size limit. * gmp-impl.h (mpn_redc_1_sec): Declare. * configure.in (gmp_mpn_functions): Add redc_1_sec. 2009-12-06 Marco Bodrato * tests/devel/try.c (try_one): DATA_SRC0_HIGHBIT sets the high bit. 2009-12-05 Marco Bodrato * mpn/generic/toom_eval_dgr3_pm1.c: Change return value: 0 or ~0. * mpn/generic/toom_eval_dgr3_pm2.c: Likewise. * mpn/generic/toom_eval_pm1.c: Likewise. * mpn/generic/toom_eval_pm2exp.c: Likewise. * mpn/generic/toom_eval_pm2.c: Rewrite to use mpn_addlsh2_n. * mpn/generic/toom_interpolate_5pts.c: Param sa is a flag, not a sign. * mpn/generic/toom33_mul.c: Adapt to changes above. * mpn/generic/toom3_sqr.c: Likewise. * mpn/generic/toom42_mul.c: Likewise. * mpn/generic/toom43_mul.c: Reduce branches. * mpn/generic/toom44_mul.c: Likewise. * mpn/generic/toom53_mul.c: Likewise. * mpn/generic/toom62_mul.c: Likewise. * mpn/generic/toom52_mul.c: Use toom_eval_ functions. * mpn/generic/toom4_sqr.c: Avoid C99 construct. * mpn/generic/toom_interpolate_7pts.c: Likewise. 2009-12-05 Torbjorn Granlund * mpn/generic/redc_1_sec.c: New file. * mpn/generic/powm_sec.c: Use redc_1_sec. Use dummy full subtract instead of mpn_cmp since the latter leaks to the side channel. (mpn_local_sqr_n): New function, with associated macros. (mpn_powm_sec): Use mpn_local_sqr_n. * configure.in (HAVE_NATIVE): Add missing functions, then sort. 2009-12-04 Torbjorn Granlund * tune/tuneup.c (tune_dc_div): Up min_size to 6. (tune_mod_1): Set MOD_1_1_THRESHOLD min_size to 2. * tune/speed.h: Negate "binvert"-type inverses, as required. * mpn/generic/redc_1.c: Add ASSERTs. * mpn/generic/redc_2.c: Likewise. * mpn/generic/sbpi1_bdiv_q.c: Simplify loops, indexing. 2009-12-03 Yann Droneaud * acinclude.m4 ([long long reliability test 1]): Add a "static" for C99 inline semantics compatibility. 2009-12-03 Torbjorn Granlund * configure.in: Move intptr_t test into common AC_CHECK_TYPES. * mpn/generic/gcdext.c: Add a TMP_FREE. 2009-12-03 Niels Möller * mpn/generic/gcdext_1.c (mpn_gcdext_1) [GCDEXT_1_USE_BINARY]: Added various masking tricks. * mpn/generic/gcdext_1.c (mpn_gcdext_1) [GCDEXT_1_USE_BINARY]: Reimplemented binary gcdext, with proper canonicalization. * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Handle v == 0 from mpn_gcdext_1. * mpn/generic/gcdext_1.c (mpn_gcdext_1): Allow inputs with a < b, assertions fixed accordingly. 2009-12-03 Torbjorn Granlund * tune/tuneup.c: Tune DC_DIVAPPR_Q_THRESHOLD. Rewrite DC_DIV_QR_THRESHOLD tuning code. (tune_dc_div): Rewrite. * tune/speed.h (SPEED_ROUTINE_MPN_PI1_DIV): New macro. * tune/common.c (speed_mpn_sbpi1_div_qr, speed_mpn_dcpi1_div_qr, speed_mpn_sbpi1_divappr_q, speed_mpn_sbpi1_bdiv_qr): New functions. * gmp-impl.h: Provide declarations for corresponding threshold vars. * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add dcpi1_divappr_q.c. * tune/tuneup.c (tune_binvert): Up max_size. 2009-12-02 Marco Bodrato * tests/devel/try.c: Test mpn_rsblsh2_n and mpn_rsblsh_n. * tests/refmpn.c (refmpn_rsblsh_n, refmpn_rsblsh2_n): New functions. (refmpn_rsblsh1_n): Use generic refmpn_rsblsh_n. * tests/tests.h: Declare new functions. 2009-12-03 Niels Möller * mpn/generic/gcdext_subdiv_step.c (mpn_gcdext_subdiv_step): Select the right cofactor in the cases A == B or A == 2B. * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Deleted handling of ap[0] == 0 and bp[0] == 0; these cases don't happen. Select the right cofactor in the case ap[0] == bp[0]. * mpn/generic/gcdext.c (mpn_gcdext): Analogous changes. 2009-12-02 Niels Möller * gmp-h.in (mpn_gcdext_1): Updated prototype. * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Updated for signed cofactors from gcdext_1. * mpn/generic/gcdext_1.c (mpn_gcdext_1): Use Euclid's algorithm, and return signed cofactors. 2009-12-02 Torbjorn Granlund * doc/gmp.texi (Low-level Functions): Document mpn_sqr_n. * tune/speed.c (routine): Add mpn_binvert. * tune/tuneup.c: Tune BINV_NEWTON_THRESHOLD. (tune_binvert): New function. * tune/speed.h (SPEED_ROUTINE_MPN_BINVERT): New macro. * tune/common.c (speed_mpn_binvert): New function. * gmp-impl.h: Provide declarations for corresponding threshold var. * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add binvert.c. * tune/tuneup.c: Tune DC_BDIV_QR_THRESHOLD and DC_BDIV_Q_THRESHOLD. (tune_dc_bdiv): New function. (tune_dc_div): New name for tune_dc. * tune/speed.h (SPEED_ROUTINE_MPN_PI1_BDIV_QR, SPEED_ROUTINE_MPN_PI1_BDIV_Q): New macros. * tune/common.c (speed_mpn_sbpi1_bdiv_qr, speed_mpn_dcpi1_bdiv_qr, speed_mpn_sbpi1_bdiv_q, speed_mpn_dcpi1_bdiv_q): New functions. * gmp-impl.h: Provide declarations for corresponding threshold vars. * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add dcpi1_bdiv_qr.c and dcpi1_bdiv_q.c. 2009-12-01 Marco Bodrato * mpn/generic/toom53_mul.c: Removed double computation of vinf. * mpn/x86_64/aorrlsh_n.asm: Correct return value for rsblsh_n. * mpn/asm-defs.m4 (define_mpn): Add rsblsh_n. * gmp-impl.h (mpn_rsblsh_n): Added prototype and name-mangling. * mpn/generic/fib2_ui.c: Reduce the amount of temporary storage. Use mpn_rsblsh_n. 2009-12-01 Torbjorn Granlund * mpn/generic/redc_n.c: Rework temp allocation. * mpn/generic/dcpi1_bdiv_qr.c (mpn_dcpi1_bdiv_qr_n_itch): Add pi1 also to this function. * mpn/generic/dcpi1_bdiv_q.c: Get the mpn_sbpi1_bdiv_q call right. Misc cleanups. * tune/speed.c (routine): Fix typo in last change. Add mpn_redc_2. * tune/speed.h (SPEED_ROUTINE_REDC_N): Set min size properly. 2009-12-01 Niels Möller * tune/speed.c (routine): Added mpn_toom42_mul and mpn_redc_n. * tune/speed.h (SPEED_ROUTINE_MPN_TOOM42_MUL): New macro. (speed_mpn_toom42_mul): Declare function. * tune/common.c (speed_mpn_toom42_mul): New function. * gmp-impl.h (MPN_TOOM42_MUL_MINSIZE): New constant. 2009-11-30 Marco Bodrato * mpn/generic/fib2_ui.c: Use mpn_rsblsh2_n. 2009-11-29 Torbjorn Granlund * mpn/x86_64/pentium4/gmp-mparam.h (HAVE_NATIVE_mpn_addlsh1_n, HAVE_NATIVE_mpn_sublsh1_n): Don't undef. * Makefile.am (EXTRA_DIST): Remove macos. 2009-11-28 Torbjorn Granlund * tune/tuneup.c (tune_redc): Set min_size to 16 for redc_n tuning. * mpn/x86_64/sqr_basecase.asm (SQR_TOOM2_THRESHOLD_MAX): Avoid quoting to allow configure.in parse it more easily. Trim from 120 to 80. 2009-11-28 Marco Bodrato * mpn/generic/mulmod_bnm1.c: Basecases made simpler, this also corrects a bug affecting previous version. 2009-11-28 Torbjorn Granlund * configure.in: Handle atom also in 32-bit mode. * mpn/x86/atom/gmp-mparam.h: New file. * gmp-impl.h (MULMOD_BNM1_THRESHOLD): Default. * mpn/generic/redc_n.c: Use mpn_mulmod_bnm1 instead of mpn_mul_n. * Use TMP_ALLOC_LIMBS consistently. * Finish renaming BITS_PER_MP_LIMB to GMP_LIMB_BITS. * macos: Remove entire directory. 2009-11-27 Torbjorn Granlund * mpn/x86_64/corei/gmp-mparam.h: New file. * mpn/x86_64/core2/gmp-mparam.h: Now for just core2. * mpn/powerpc64/mode64/p3/gmp-mparam.h: New file. * mpn/powerpc64/mode64/p4/gmp-mparam.h: New file. * mpn/powerpc64/mode64/p5/gmp-mparam.h: New file. * config.guess: Return "corei" for core i7 and core i5. * config.sub: Recognise "corei". * acinclude.m4 (X86_64_PATTERN): Add corei. * configure.in (powerpc): Set up more CPU-specific paths. (x86): Handle corei. * mpz/powm.c: Allow input operand overlap also when exponent = 1. Misc cleanups. 2009-11-26 Marco Bodrato * tests/mpn/t-mulmod_bnm1.c: New test file. * tests/mpn/Makefile.am (check_PROGRAMS): Add t-mulmod_bnm1. * mpn/generic/mullow_n.c: Comments on Mulders' trick implementation. 2009-11-26 Torbjorn Granlund * mpn/generic/powm.c: Make comments reflect current code state. * tests/devel/try.c: Make mpn_mullow_n testing actually work. 2009-11-25 Torbjorn Granlund * mpz/powm.c: Clean up unused defs. 2009-11-24 Torbjorn Granlund * tune/tuneup.c (tune_redc): Rewrite. * mpn/generic/powm.c: Use REDC_1_TO_REDC_2_THRESHOLD, REDC_1_TO_REDC_N_THRESHOLD, and REDC_2_TO_REDC_N_THRESHOLD. Get rid of previous REDC params, including LOCAL_REDC_N_THRESHOLD. (WANT_REDC_2): Define. * gmp-impl.h: Corresponding changes. 2009-11-23 Torbjorn Granlund * mpn/generic/powm.c: Fix typo. Define LOCAL_REDC_N_THRESHOLD, use in REDC_2_THRESHOLD... REDC_N_THRESHOLD chain. 2009-11-22 Torbjorn Granlund * tune/tuneup.c (tune_mullow): Set min_size to 1. * mpn/generic/powm_sec.c: Use just mpn_mul_basecase and mpn_sqr_basecase for multiplication and squaring. * tune/tuneup.c: Tune REDC_2_THRESHOLD and REDC_N_THRESHOLD. (tune_redc): New function. (tune_powm): Remove function. * tune/speed.h (SPEED_ROUTINE_REDC_2, SPEED_ROUTINE_REDC_N): New. * tune/common.c (speed_mpn_redc_2, speed_mpn_redc_n): New. * mpz/powm.c: Complete rewrite. Use mpn_powm and mpn_powlo. * mpn/generic/powm.c: Rewrite. * mpn/generic/redc_n.c: New file. * configure.in (gmp_mpn_functions): Add redc_n. * gmp-impl.h (REDC_2_THRESHOLD, REDC_N_THRESHOLD): Default, and define for tuneup. 2009-11-21 Marco Bodrato * mpn/generic/mullow_n.c: Disable Mulders' trick for small operands, use fft for bigger ones. * tests/mpn/t-mullo.c: New test file. 2009-11-22 Torbjorn Granlund * tune/tuneup.c (tune_mullow): Rewrite. 2009-11-21 Marco Bodrato * gmp-impl.h: Removed unused macros (CACHED_ABOVE_THRESHOLD and CACHED_BELOW_THRESHOLD). * mpn/generic/mullow_n.c: Use Mulders' trick. * tune/tuneup.c (tune_mullow): MULLOW_MUL_N_THRESHOLD range of search depends on FFT tuning; (all): Anticipate tune_fft_{mul,sqr}. * tune/speed.c (routine): Add entry related to mpn_mulmod_bnm1. 2009-11-19 Niels Möller * mpn/generic/toom_eval_dgr3_pm2.c (mpn_toom_eval_dgr3_pm2) [HAVE_NATIVE_mpn_add_n_sub_n]: Fixed typo in mpn_add_n_sub_n call (spotted by Marco Bodrato). * mpn/generic/toom_eval_pm2.c (mpn_toom_eval_pm2): Likewise. * mpn/generic/toom_eval_pm2exp.c (mpn_toom_eval_pm2exp): Likewise. * mpn/generic/toom_eval_pm2.c (mpn_toom_eval_pm2) [HAVE_NATIVE_mpn_addlsh_n]: Fixed missing declaration. * mpn/asm-defs.m4 (define_mpn): Add addlsh_n. * gmp-impl.h (mpn_addlsh_n): Added prototype and name-mangling. 2009-11-19 Niels Möller * mpn/generic/toom_eval_pm2.c (mpn_toom_eval_pm2): New file. * mpn/generic/toom53_mul.c (mpn_toom53_mul): Use mpn_toom_eval_pm2. * mpn/generic/toom62_mul.c (mpn_toom62_mul): Likewise. * configure.in (gmp_mpn_functions): Added toom_eval_dgr3_pm2. 2009-11-18 Torbjorn Granlund * gmp-impl.h (mpn_and_n, etc): Adapt to now-public logic functions. * config.guess: Recognise VIA nano. * config.sub: Likewise. * configure.in: Generalise x86_64 support; recognise VIA nano. 2009-11-16 Torbjorn Granlund * tune/speed.c (routine): Add measurement of mpn_addlsh2_n, mpn_sublsh2_n, mpn_rsblsh2_n. * tune/common.c: Add speed routines for lsh2 functions. * mpn/generic/divis.c: Use MU_BDIV_QR_THRESHOLD. * configure.in (gmp_mpn_functions_optional): Add *lsh_n functions. * mpn/generic/toom_eval_pm2exp.c: Make HAVE_NATIVE_mpn_addlsh_n code work. * mpn/x86_64/aorrlsh2_n.asm: Optimise inner loop. * configure.in (gmp_mpn_functions_optional): Remove copyi,copyd, they are now in gmp_mpn_functions. Analogously move logical functions. 2009-11-16 Marco Bodrato * mpn/generic/toom53_mul.c: Use addlsh2 for evaluation (and fix typo). * mpn/generic/toom_eval_dgr3_pm2.c: Likewise (affects toom44 and 43). * mpn/asm-defs.m4: Fix comments for op_lsh2 new functions. * gmp-impl.h: Likewise. * tests/mpz/t-fac_ui.c: Fix a comment. 2009-11-15 Torbjorn Granlund * mpn/x86_64/aorrlsh2_n.asm: New file. * configure.in: Add support for addlsh2_n, sublsh2_n, and rsblsh2_n, including mulfuncs. * gmp-impl.h (mpn_addlsh2_n, mpn_sublsh2_n, mpn_rsblsh2_n): Declare. * mpn/asm-defs.m4: Likewise. * mpn/generic/copyi.c: New file. * mpn/generic/copyd.c: Likewise. * mpn/generic/zero.c: Likewise. * gmp-h.in: Declare new functions. * configure.in (gmp_mpn_functions): Add new functions. 2009-11-15 Marco Bodrato * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1_next_size): fix typo * mpn/generic/toom33_mul.c: Use rsblsh1 for evaluation. * mpn/generic/toom3_sqr.c: Likewise. 2009-11-14 Torbjorn Granlund * mpn/generic/toom52_mul.c: Use mpn_addlsh1_n. * mpn/generic/toom52_mul.c: Toggle the right flag bit in an HAVE_NATIVE_mpn_add_n_sub_n arm. * tests/mpz/t-remove.c: New file. * mpn/generic/remove.c: Major overhaul. Add parameter 'cap'. * mpn/generic/binvert.c: Fix typo in last change. * mpn/generic/bdiv_qr.c: Make it actually work. Also use passed-in scratch space. * mpn/generic/mu_bdiv_qr.c: Reset FFT parameters for each call. 2009-11-12 Torbjorn Granlund * mpn/x86/k7/gcd_1.asm (MASK): Compute from MAXSHIFT. 2009-11-11 Torbjorn Granlund * mpn/generic/binvert.c: Simplify, fix comments. * tests/devel/try.c: Test mpn_invert and mpn_binvert. * tests/refmpn.c (refmpn_invert, refmpn_binvert): New functions. * tests/tests.h: Declare new functions. 2009-11-10 Torbjorn Granlund * configure.in: Supply compiler options for atom in 32-bit mode. * acinclude.m4 (X86_64_PATTERN): New. * configure.in: Setup and use X86_64_PATTERN. * mpn/x86_64/fat/fat.c: New file. * mpn/x86_64/fat/fat_entry.asm: New file. * mpn/x86_64/fat: Copy C placeholder files from mpn/x86/fat. * mpn/x86_64/x86_64-defs.m4 (CPUVEC_FUNCS_LIST): New, copied from mpn/x86/x86-defs.m4. * configure.in: Move down x86 fat setup code until after ABI has been determined; generalise to handle x86_64. 2009-11-09 Torbjorn Granlund * mpn/x86/fat/mod_1.c: New file. * acinclude.m4 (GMP_C_FOR_BUILD_ANSI): Avoid poor quoting. 2009-11-08 Torbjorn Granlund * gmp-impl.h (MPN_LOGOPS_N_INLINE): Rewrite, update interface. Callers updated. * mpn/generic/logops_n.c: New file. * doc/gmp.texi (Low-level Functions): Document logical mpn functions. 2009-11-07 Torbjorn Granlund * tune/speed.h (SPEED_ROUTINE_MPN_MULMOD_BNM1): Adapt to new mpn_mulmod_bnm1 interface. 2009-11-07 Marco Bodrato * mpn/generic/mulmod_bnm1.c: New interface, with size specified for all operands in mpn_mulmod_bnm1. * gmp-impl.h: Changed mpn_mulmod_bnm1 prototype. 2009-11-05 Torbjorn Granlund * mpn/x86/k7/gcd_1.asm: Actually use div-reduced value. Mnemonic cleanup. * mpn/x86_64/gcd_1.asm: New file. 2009-11-03 Torbjorn Granlund * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add sqr_n.c. 2009-11-03 Marco Bodrato * mpn/generic/toom_interpolate_6pts.c: removed an addmul_1 and cleanup. 2009-11-02 Torbjorn Granlund * configure.in (gmp_mpn_functions): Remove obsolete functions dc_divrem_n and sb_divrem_mn. * gmp-impl.h: Misc cleanup. (mpn_sb_divrem_mn, mpn_dc_divrem_n): Remove. (DIV_DC_THRESHOLD): Remove. * mpn/generic/dc_divrem_n.c: Remove. * mpn/generic/sb_divrem_mn.c: Remove. * mpn/generic/tdiv_qr.c: Use DC_DIV_QR_THRESHOLD, not DIV_DC_THRESHOLD. * tests/devel/try.c: Replace mpn_sb_divrem_mn by mpn_sbpi1_div_qr. * tests/refmpn.c (refmpn_sb_div_qr): New name for refmpn_sb_divrem_mn. * tune/Makefile.am (libspeed_la_SOURCES): Remove sb_div.c and sb_inv.c. (TUNE_MPN_SRCS_BASIC): Remove sb_divrem_mn.c. * tune/common.c (speed_mpn_dcpi1_div_qr_n): New function. Remove mpn_sb_divrem_mn related functions. * tune/speed.c (routine): Remove entries related to mpn_dc_divrem and mpn_sb_divrem. (routine): New entry for mpn_dc_div_qr_n. * tune/speed.h (SPEED_ROUTINE_MPN_DC_DIVREM_CALL): Compute inverse needed by pi1 calls. (SPEED_ROUTINE_MPN_SB_DIVREM_M3): Remove. * tune/tuneup.c (tune_sb_preinv): Remove. (tune_dc): Update to measure DC_DIV_QR_THRESHOLD. * mpn/generic/sb_divappr_q.c: Remove. 2009-11-01 Torbjorn Granlund * gmp-impl.h: Misc minor cleanups. 2009-10-31 Torbjorn Granlund * gmp-impl.h (toom itch functions): Simplify, make some into macros. (MPN_KARA_MUL_N_TSIZE, MPN_KARA_SQR_N_TSIZE): Remove. * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): Remove. * mpn/generic/mul_n.c (mpn_sqr_n): Move from here... * mpn/generic/sqr_n.c: ...to this new file. * configure.in (gmp_mpn_functions): Add sqr_n. * Globally change MUL_TOOM3_THRESHOLD => MUL_TOOM33_THRESHOLD, MUL_KARATSUBA_THRESHOLD => MUL_TOOM22_THRESHOLD, SQR_KARATSUBA_THRESHOLD => SQR_TOOM2_THRESHOLD, and associated names analogously. 2009-10-31 Niels Möller * mpn/generic/toom_interpolate_7pts.c: Changed evaluation points, replacing -1/2 by -2. * mpn/generic/toom44_mul.c: Updated to use new evaluation points, and use mpn_toom_eval_dgr3_pm2. * mpn/generic/toom4_sqr.c (mpn_toom4_sqr): Likewise. * mpn/generic/toom53_mul.c (mpn_toom53_mul): Updated to use new evaluation points, and use mpn_toom_eval_pm1 and mpn_toom_eval_pm2exp. * mpn/generic/toom62_mul.c (mpn_toom62_mul): Likewise. * mpn/generic/toom_eval_pm2exp.c: New file. * mpn/generic/toom_eval_pm1.c: New file. * mpn/generic/toom43_mul.c (mpn_toom43_mul): Use mpn_toom_eval_dgr3_pm2. 2009-10-30 Torbjorn Granlund * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add toom2* and toom3* files. 2009-10-30 Niels Möller * configure.in (gmp_mpn_functions): Added toom_eval_dgr3_pm2. * gmp-impl.h: Added prototype for mpn_toom_eval_dgr3_pm2. * mpn/generic/toom_eval_dgr3_pm2.c: New file. 2009-10-29 Niels Möller * mpn/generic/toom43_mul.c (mpn_toom43_mul): Use mpn_toom_eval_dgr3_pm1. * mpn/generic/toom42_mul.c (mpn_toom42_mul): Likewise. 2009-10-29 Torbjorn Granlund * mpn/generic/mulmod_bnm1.c: Replace some add_1 by INCR. * gmp-impl.h (mpn_mulmod_bnm1_itch): New macro. * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1): Call mpn_mul_fft. (mpn_mulmod_bnm1_next_size): Adopt to SS FFT. * mpn/generic/mul_fft.c (mpn_mul_fft): Make it return high limb. (mpn_mul_fft_internal): Likewise. * mpn/generic/mulmod_bnm1.c: New file, by Niels Möller. * configure.in (gmp_mpn_functions): Add mulmod_bnm1. * gmp-impl.h: Add related declarations. * tune/tuneup.c: Tune MULMOD_BNM1_THRESHOLD. * tune/speed.h (SPEED_ROUTINE_MPN_MULMOD_BNM1): New macro. * tune/common.c (speed_mpn_mulmod_bnm1): New function. * Makefile.am (TUNE_MPN_SRCS_BASIC): Add mulmod_bnm1.c. * gmp-impl.h (mpn_kara_mul_n, mpn_kara_sqr_n): Remove declarations. * tune/common.c: Remove/rename kara functions. * tune/speed.h: Likewise. * tests/devel/try.c: Clean up usage of %p printf arguments. * gmp-impl.h: Update MUL/SQR MINSIZE macros to reflect new function names and limitations * tune/tuneup.c: Use updated macro names. * tune/speed.h: Likewise. * tests/devel/try.c: Test new mul/sqr functions, remove old tests. 2009-10-29 Niels Möller * tune/speed.c: Added support for mpn_toom4_sqr, * tune/speed.h (SPEED_ROUTINE_MPN_TOOM4_SQR): New macro. (SPEED_ROUTINE_MPN_KARA_MUL_N): Deleted. (SPEED_ROUTINE_MPN_TOOM3_MUL_N): Deleted. (SPEED_ROUTINE_MPN_TOOM2_SQR): Use mpn_toom2_sqr_itch. * gmp-impl.h (mpn_toom3_mul_n, mpn_toom3_sqr_n): Remove declarations. (mpn_toom2_sqr_itch): Add margin for recursive calls. 2009-10-28 Niels Möller * mpn/generic/mul_n.c (mpn_kara_mul_n): Deleted old Karatsuba implementation. (mpn_kara_sqr_n): Likewise deleted. * mpn/generic/mul_n.c (mpn_sqr_n): Use mpn_toom2_sqr and mpn_toom3_sqr, not the old implementations. * gmp-impl.h (MPN_TOOM3_MUL_N_TSIZE): Deleted, replaced by mpn_toom33_mul_itch. (MPN_TOOM3_SQR_N_TSIZE): Deleted, replaced by mpn_toom3_sqr_itch. (mpn_toom33_mul_itch): Needs more scratch. (mpn_toom3_sqr_itch): Likewise. * tune/speed.h (SPEED_ROUTINE_MPN_TOOM3_MUL_N): Use mpn_toom33_mul_itch. (SPEED_ROUTINE_MPN_TOOM3_SQR_N): Use mpn_toom3_sqr_itch. * mpn/generic/mul_n.c (mpn_mul_n): Use mpn_toom33_mul_itch. (mpn_sqr_n): Use mpn_toom3_sqr_itch. * mpn/generic/toom33_mul.c (mpn_toom33_mul): Avoid TMP_ALLOC. Needs some more supplied scratch instead. * mpn/generic/toom3_sqr.c (mpn_toom3_sqr): Likewise. 2009-10-26 Torbjorn Granlund * gmp-impl.h (invert_pi1): Streamline, as suggested by Niels. 2009-10-24 Torbjorn Granlund * mpn/generic/bdiv_q.c: Update to call new functions. * mpn/generic/bdiv_qr.c: Likewise. * mpn/generic/binvert.c: Likewise. * mpn/generic/divexact.c: Likewise. * mpn/generic/divis.c: Likewise. * mpn/generic/perfpow.c: Likewise. * mpn/generic/tdiv_qr.c: Likewise. * mpn/generic/dcpi1_bdiv_q.c: New file. * mpn/generic/dcpi1_bdiv_qr.c: New file. * mpn/generic/dcpi1_div_q.c: New file. * mpn/generic/dcpi1_div_qr.c: New file. * mpn/generic/dcpi1_divappr_q.c: New file. * mpn/generic/sbpi1_bdiv_q.c: New file. * mpn/generic/sbpi1_bdiv_qr.c: New file. * mpn/generic/sbpi1_div_q.c: New file. * mpn/generic/sbpi1_div_qr.c: New file. * mpn/generic/sbpi1_divappr_q.c: New file. * mpn/generic/dc_bdiv_q.c: Removed. * mpn/generic/dc_bdiv_qr.c: Removed. * mpn/generic/dc_div_q.c: Removed. * mpn/generic/dc_div_qr.c: Removed. * mpn/generic/dc_divappr_q.c: Removed. * mpn/generic/sb_bdiv_q.c: Removed. * mpn/generic/sb_bdiv_qr.c: Removed. * mpn/generic/sb_div_q.c: Removed. * mpn/generic/sb_div_qr.c: Removed. * configure.in (gmp_mpn_functions): Add new division functions, remove obsolete division functions. * gmp-impl.h: Add declarations of new division functions, remove corresponding obsolete declarations. (gmp_pi1_t, gmp_pi2_t): New types. (invert_pi1): New macro for computing 2/1 and 3/2 inverses. 2009-10-23 Niels Möller * gmp-impl.h (mpn_toom62_mul_itch): New function. * tests/mpn/t-toom53.c: New test program. * tests/mpn/t-toom62.c: New test program. 2009-10-23 Torbjorn Granlund * mpn/generic/get_d.c: Fix code handling denorms for 64-bit machines. * tests/mpf/t-get_d.c (test_denorms): New function. 2009-10-23 Niels Möller * mpn/generic/toom52_mul.c (mpn_toom52_mul): Use supplied scratch space, not TMP_ALLOC. Interface change, now requires input sizes such that s + t >= 5. * gmp-impl.h (mpn_toom52_mul_itch): New function. * tests/mpn/t-toom52.c: New test program. 2009-10-22 Torbjorn Granlund * mpn/x86_64/sqr_basecase.asm: Tune for speed and a 7% size decrease. 2009-10-22 Niels Möller * tests/mpn/t-toom44.c: New test program. * tests/mpn/t-toom33.c: New test program. * tests/mpn/toom-shared.h (main): Reorganized input generation. Users are now supposed to define macros MAX_AN, MIN_BN and MAX_BN. Updated existing toom test programs. 2009-10-22 Torbjorn Granlund * tests/devel/try.c: Fix typos in last change. 2009-10-21 Torbjorn Granlund * mpn/asm-defs.m4 (define_mpn): Add mullow_basecase. * tests/devel/try.c: Test mpn_mullow_n. * tests/refmpn.c (refmpn_mullow_n): New function. * tests/tests.h: Declare it. 2009-10-21 Niels Möller * tests/mpn/toom-shared.h (main): Check for writes outside of the product or scratch area. * gmp-impl.h (mpn_toom43_mul_itch): New function. * mpn/generic/toom43_mul.c (mpn_toom43_mul): Use supplied scratch space, not TMP_ALLOC. Interface change, now requires input sizes such that s + t >= 5. 2009-10-20 Niels Möller * tests/mpn/toom-shared.h (MIN_BLOCK): New constant, which can be overridden by users. Needed by t-toom42 and t-toom43. * tests/mpn/Makefile.am (check_PROGRAMS): Added t-toom32, t-toom42 and t-toom43. * tests/mpn/t-toom43.c: New test program. * tests/mpn/t-toom42.c: New test program. * tests/mpn/t-toom32.c: New test program. * tests/mpn/Makefile.am (check_PROGRAMS): Added t-toom22. * tests/mpn/t-toom22.c: New test file. * tests/mpn/toom-shared.h: New file. Test framework for Toom functions. 2009-10-14 Niels Möller * mpn/generic/hgcd.c (mpn_hgcd_itch): Thanks to the new mpn_matrix22_mul_strassen, the scratch need is reduced by 16%. 2009-10-14 Marco Bodrato * mpn/generic/matrix22_mul.c (mpn_matrix22_mul_strassen): New Strassen-like algorithm, to reduce the amount of temporary storage. (mpn_matrix22_mul_itch): Updated to reflect the reduced storage need. 2009-10-03 Torbjorn Granlund * Rename mpn_addsub_n to mpn_add_n_sub_n. 2009-10-01 Torbjorn Granlund * mpn/generic/tdiv_qr.c: Call mpn_divrem_1 and mpn_dc_div_qr instead of old functions. * mpn/generic/mul_n.c: Call toom22 and toom33 instead of old functions. * mpn/generic/toom42_mul.c (TOOM42_MUL_N_REC): Renamed from TOOM22_MUL_N_REC. Unconditionally call the generic mpn_mul_n. * mpn/generic/toom32_mul.c: Analogous changes. 2009-09-28 Niels Möller * mpn/x86_64/invert_limb.asm: Rewrite. Exploit cancellation in the Newton iteration. 2009-09-27 Niels Möller * mpn/x86/invert_limb.asm: Reduce register usage. Eliminated $1 arguments to add, sub and shift. 2009-09-25 Niels Möller * mpn/x86/invert_limb.asm: New file. 2009-09-24 Torbjorn Granlund * mpn/generic/toom33_mul.c: Use new toom functions for all recursive products. * mpn/generic/toom3_sqr.c: Likewise. * mpn/generic/toom44_mul.c: Likewise. * mpn/generic/toom4_sqr.c: Likewise. * mpn/generic/add_n.c: Relax operand overlap ASSERTs. * mpn/generic/sub_n.c: Likewise. 2009-09-15 Torbjorn Granlund Suggested by Uwe Mueller: * printf/doprnt.c: Use "%ld" for exponent printing. * printf/doprntf.c (__gmp_doprnt_mpf): Make expval "long". 2009-09-14 Torbjorn Granlund * configure.in: Handle mingw64. * gmp-impl.h (gmp_intptr_t): Declare. * tests/amd64check.c (calling_conventions_values): Use CNST_LIMB. * tests/memory.c: Use gmp_intptr_t; print pointers using C90 "%p". * tests/misc.c: Use gmp_intptr_t. * tests/mpq/t-get_str.c: Print pointers using C90 "%p". 2009-08-12 Torbjorn Granlund * mpn/generic/mod_1_1.c (mpn_mod_1_1p_cps): Remove silly ASSERT code. * mpn/asm-defs.m4 (define_mpn): Remove mod_1s_1p, add mod_1_1p. * mpn/arm/invert_limb.asm: Complete rewrite. * longlong.h: Document LONGLONG_STANDALONE and NO_ASM. 2009-08-05 Torbjorn Granlund * tests/mpz/dive_ui.c (check_random): Avoid zero divisors. 2009-07-31 Torbjorn Granlund * mpn/generic/mod_1_1.c: Tweak to handle any modulus (possibility pointed out by Per Austrin). (mpn_mod_1_1p): Renamed from mpn_mod_1s_1p. (mpn_mod_1_1p_cps): Renamed from mpn_mod_1s_1p_cps. *mpn/generic/mod_1.c (mpn_mod_1): Reorganise to call mpn_mod_1_1p for any modulus. 2009-07-28 Torbjorn Granlund * configure.in: Pass arch for x86 also in 64-bit mode. 2009-07-26 Torbjorn Granlund * config.guess (_cpuid): Recognise more Intel "Core" processors. 2009-07-13 Torbjorn Granlund * mpf/eq.c: Rewrite. * tests/mpf/t-eq.c: New test. 2009-07-06 Torbjorn Granlund * gmp-impl.h (__mp_bases): Remove this alias. * mpf/get_str.c: Use less overflow prone expression for computing limb allocation. * mpz/inp_str.c: Likewise. * mpf/set_str.c: Likewise. * mpz/set_str.c: Likewise. 2009-07-03 Niels Möller * mpn/generic/gcd_1.c (mpn_gcd_1): Use masking tricks to reduce the number of branches in the loop. 2009-06-28 Torbjorn Granlund * demos/factorize.c (factor_using_pollard_rho): Rewrite. * mpz/clears.c: New file. * mpq/clears.c: New file. * mpf/clears.c: New file. * gmp-h.in (mpz_clears, mpq_clears, mpf_clears): Declare. * mpz/Makefile.am: Add clears.c. * mpq/Makefile.am: Add clears.c. * mpf/Makefile.am: Add clears.c. * Makefile.am: Add these also to respective OBJECTS variables. * doc/gmp.texi: Document inits function and clears functions. 2009-06-20 Torbjorn Granlund * mp-h.in (mp_bitcnt_t): Declare here too. 2009-06-19 Torbjorn Granlund * mpq/inits.c: New file. * mpf/inits.c: New file. * gmp-h.in (mpz_inits, mpq_inits, mpf_inits): Declare . * mpn/generic/remove.c: New file. * configure.in (gmp_mpn_functions): Add remove. * gmp-impl.h (mpn_remove): Declare. * gmp-h.in (mp_bitcnt_t): New basic type. * mpn/generic/perfpow.c (mp_bitcnt_t): Remove private definition. * mpn/generic/bdiv_qr.c: Make it actually work. * mpn/x86_64/core2/aorsmul_1.asm: Rewrite to use shorter pipeline and to need fewer registers. 2009-06-17 Torbjorn Granlund * mpn/x86_64/rsh1aors_n.asm: New file. * mpn/x86_64/rsh1add_n.asm: Remove. * mpn/x86_64/rsh1sub_n.asm: Remove. * mpz/inits.c: New file. * gen-trialdivtab.c: Wrap limb constants into CNST_LIMB. With Martin Boij: * mpn/generic/perfpow.c (binv_root, binv_sqroot): Change from being recursive to being iterative. (mpn_perfect_power_p): Reorganise temp memory usage to avoid a buffer overrun. Trim allocation of next and prev. Never create oversize products in the multiplicity binary search. * mpn/generic/dc_div_q.c: Add missing TMP_FREE. 2009-06-16 Torbjorn Granlund Revert: * mpn/generic/perfpow.c (perfpow): Test exponents up to ub, inclusive. 2009-06-16 Martin Boij * mpn/generic/perfpow.c (logs): Use more conservative table. 2009-06-15 Torbjorn Granlund * mpn/pa64/aors_n.asm: New file. * mpn/pa64/add_n.asm: Remove. * mpn/pa64/sub_n.asm: Remove. * mpn/generic/perfpow.c (perfpow): Test exponents up to ub, inclusive. 2009-06-14 Torbjorn Granlund * mpn/x86_64/bdiv_q_1.asm: Optimise away a mov insn. * mpn/x86_64/dive_1.asm: Likewise. * mpn/generic/perfpow.c (binv_root): Use mpn_bdiv_q_1, not mpn_divexact_itch for 2-adic division. (all functions): Micro optimise. * Makefile.am (libmp_la_SOURCES): Add nextprime.c. 2009-06-13 Torbjorn Granlund * gmp-h.in (mpn_perfect_power_p): Declare. * configure.in (gmp_mpn_functions): Add perfpow. * mpz/perfpow.c: Now trivial, simply calls mpn_perfect_power_p. 2009-06-13 Martin Boij * mpn/generic/perfpow.c: New file. * tests/mpz/t-perfpow.c: Rewrite. 2009-06-12 Torbjorn Granlund * mpn/generic/bdiv_qr.c: New file. * mpn/generic/bdiv_q.c: New file. * configure.in (gmp_mpn_functions): Add bdiv_qr and bdiv_q. * gmp-impl.h: Declare new functions. * nextprime.c: New file. * gmp-impl.h (gmp_primesieve_t, gmp_init_primesieve, gmp_nextprime): Declare. * Makefile.am (libgmp_la_SOURCES): Add nextprime.c. 2009-06-11 Torbjorn Granlund * mpn/generic/trialdiv.c: New file. * gen-trialdivtab.c: New file. * configure.in (gmp_mpn_functions): Add trialdiv. * gmp-impl.h (mpn_trialdiv): Declare * Makefile.am: Add rules for gen-trialdivtab and trialdiv. * longlong.h (arm count_leading_zeros): Define for armv5. * gmp-impl.h: Move down toom itch functions to after we've #defined all THRESHOLDs. * dumbmp.c (isprime): Replace with slightly less inefficient code. (mpz_tdiv_r): New function. 2009-06-11 Niels Möller Support for mpn_toom32_mul in speed: * tune/speed.c (routine): Added mpn_toom32_mul. * tune/speed.h (SPEED_ROUTINE_MPN_TOOM32_MUL): New macro. * tune/common.c (speed_mpn_toom32_mul): New function. * gmp-impl.h (mpn_toom32_mul_itch): Count scratch space needed for the calls to mpn_toom22_mul. (ABOVE_THRESHOLD): Moved this and related macros so it can be used by mpn_toom32_mul_itch. (mpn_toom22_mul_itch): Count scratch space for recursive calls. 2009-06-11 Torbjorn Granlund * mpn/x86/k7/mod_1_4.asm: New file, mainly for k7, but perhaps useful also for k6 and non-sse p6. 2009-06-10 Torbjorn Granlund * mpn/x86_64/mod_1_4.asm: Minor size reducing tweaks. * mpn/x86/mod_1.asm: Remove obsolete file. * mpn/x86/k7/mmx/mod_1.asm: Likewise. * mpn/x86/pentium4/sse2/mod_1.asm: Likewise. * mpn/x86/p6/mod_1.asm: Likewise. * mpn/x86/pentium/mod_1.asm: Likewise. 2009-06-08 Niels Möller * mpn/generic/toom4_sqr.c (mpn_toom4_sqr): Reorganized, to reduce the need for scratch space, and get rid of TMP_ALLOC. Also use mpn_toom_eval_dgr3_pm1. * mpn/generic/toom_interpolate_6pts.c (mpn_toom_interpolate_6pts): Stricter ASSERTs based on maximum size of polynomial coefficients. Improved comments on the signedness of intermediate values. 2009-06-07 Torbjorn Granlund * mpn/generic/toom2_sqr.c: Make it actually work. * mpn/generic/toom3_sqr.c: Reduce local scratch space. 2009-06-05 Torbjorn Granlund * mpn/generic/mul_fft.c (FFT_TABLE2_SIZE): Default to 200. (MUL_FFT_TABLE2_SIZE, SQR_FFT_TABLE2_SIZE): Let these decide FFT_TABLE2_SIZE if they are defined. (struct nk): Use bit field. 2009-06-05 Niels Möller * mpn/generic/toom44_mul.c (mpn_toom44_mult): Use mpn_toom_eval_dgr3_pm1. * mpn/generic/toom_eval_dgr3_pm1.c: New file. * mpn/generic/toom_interpolate_7pts.c (mpn_toom_interpolate_7pts): Minor cleanup, use mpn_add rather than mpn_add_n + MPN_INCR_U. * mpn/generic/toom44_mul.c (mpn_toom44_mul): Reorganized, to reduce the need for scratch space, and get rid of TMP_ALLOC. 2009-06-05 Torbjorn Granlund * mpn/generic/toom_interpolate_7pts.c: Fall back mpn_divexact_byN to mpn_bdiv_q_1_pi1, if the latter is NATIVE. 2009-06-04 Torbjorn Granlund * mpn/x86_64/bdiv_q_1.asm: New file. * configure.in (HAVE_NATIVE): Add recently added functions. (GMP_MULFUNC_CHOICES): Handle addlsh_n, sublsh_n, rsblsh_n. * tune/common.c (speed_mpn_bdiv_q_1, speed_mpn_bdiv_q_1_pi1): New functions. * tune/speed.c (routine): Add mpn_bdiv_q_1 and mpn_bdiv_q_1_pi1. * tune/speed.h (SPEED_ROUTINE_MPN_BDIV_Q_1_PI1): New #define. (SPEED_ROUTINE_MPN_BDIV_Q_1): Mew #define. * configure.in (gmp_mpn_functions): Add bdiv_q_1. * mpn/generic/bdiv_q_1.c: New file. * mpn/asm-defs.m4 (define_mpn): Add mpn_bdiv_q_1 and mpn_bdiv_q_1_pi1. * gmp-impl.h (mpn_bdiv_q_1, mpn_bdiv_q_1_pi1): Declare. * mpn/x86_64/lshift.asm: Cleanup. * mpn/x86_64/rshift.asm: Cleanup. * mpn/x86_64/addlsh1_n.asm: Removed. * mpn/x86_64/aorrlsh1_n.asm: Generalised addlsh1_n.asm to handle addlsh1_n and rsblsh1_n functionality. * tests/refmpn.c (refmpn_rsblsh1_n): New function. * tests/devel/try.c: Test mpn_rsblsh1_n. * tests/tests.h: Declare refmpn_rsblsh1_n. * tune/common.c (speed_mpn_rsblsh1_n): New function. * tune/speed.c (routine): Add mpn_rsblsh1_n. * tune/speed.h (mpn_rsblsh1_n): Declare. * configure.in (gmp_mpn_functions_optional): Add rsblsh1_n. (GMP_MULFUNC_CHOICES): Handle rsblsh1_n defined with a mulfunc. * mpn/asm-defs.m4 (define_mpn): Add rsblsh1_n. * gmp-impl.h (mpn_rsblsh1_n): Declare. * mpn/generic/toom32_mul.c: Consistently use TOOM22_MUL_N_REC. 2009-06-03 Marco Bodrato * mpn/generic/toom43_mul.c: New file. * mpn/generic/toom52_mul.c: New file. * mpn/generic/toom_interpolate_6pts.c: New file. 2009-06-03 Torbjorn Granlund * configure.in (gmp_mpn_functions): Add toom43_mul, toom52_mul, and toom_interpolate_6pts, but also some previously forgotten functions. * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Likewise. * gmp-impl.h: Declare new functions. Sort toom function declarations. * gmp-impl.h: Rename toom4_* flags enum to toom7_*. Relevant C files updated. * mpn/generic/toom_interpolate_7pts (divexact_2exp): Remove. 2009-06-02 Torbjorn Granlund * demos/factorize.c: Add -q command line option. 2009-06-02 Marco Bodrato * mpn/generic/toom_interpolate_7pts.c: Streamline, resulting in speed improvements. * mpn/generic/toom_interpolate_5pts.c: Likewise, but also completely do away with explicit scratch space. * gmp-impl.h (mpn_toom_interpolate_5pts): Update prototype. * mpn/generic/mul_n.c (mpn_toom3_sqr_n, mpn_toom3_mul_n): Update toom_interpolate_5pts call without scratch space parameter. * mpn/generic/toom3_sqr.c: Likewise. * mpn/generic/toom42_mul.c: Likewise. * mpn/generic/toom33_mul.c: Likewise. * mpn/generic/toom33_mul.c: Reduce local scratch space. * mpn/generic/toom32_mul.c: Rewrite to not use local scratch space. 2009-06-02 Torbjorn Granlund * mpn/generic/toom22_mul.c (TOOM22_MUL_MN_REC): New macro, use it for oo point. 2009-06-01 Torbjorn Granlund * mpn/generic/mul.c: Loop to avoid excessive recursion in toom33 and toom44 slicing code. * mpz/remove.c: Correctly handle multiplicity that does not fit an int. * Makefile.am (dist-hook): Check library version consistency. * mpn/generic/mul.c: Rewrite. 2009-05-29 Torbjorn Granlund * tests/mpz/t-divis.c (check_random): Create huge test operands. * mpn/generic/toom44_mul.c: Allocate temp space using one TMP_ALLOC call, not multiple TMP_SALLOC. * mpn/generic/toom4_sqr.c: Likewise. * gmp-impl.h (mpn_toom22_mul_itch): Replace totally wrong code. * mpn/generic/mullow_n.c: Relax overlap requirement implied by ASSERT. * mpn/generic/divis.c: Rewrite. * gmp-impl.h (mpn_mu_bdiv_qr): Now returns mp_limb_t. (mpn_toom2_sqr_itch): Simplify. * mpn/generic/mu_bdiv_qr.c: Implement properly. 2009-05-27 Torbjorn Granlund * mpn/generic/mod_1_1.c: Add proper ASSERT functionality cps function. * mpn/generic/mod_1_2.c: Likewise. * mpn/generic/mod_1_3.c: Likewise. * mpn/generic/mod_1_4.c: Likewise. * tune: Add speed measuring of toom22, toom33, and toom44. * mpn/generic/toom22_mul.c: Handle potentially unbalanced coefficient product better. 2009-05-26 Torbjorn Granlund * tests/mpz/t-mul.c (ref_mpn_mul): Use mpn_toom44_mul in FFT range for better huge-operands performance. 2009-05-24 Torbjorn Granlund * acinclude.m4 (GMP_ASM_LSYM_PREFIX): Try "$L" too, before "$". 2009-05-23 Torbjorn Granlund * gmp-impl.h (mpn_mod_1s_1p,mpn_mod_1s_2p,mpn_mod_1s_3p,mpn_mod_1s_4p): Declare using __GMP_ATTRIBUTE_PURE. * tune/tuneup.c (tune_mod_1): Specify check_size for measuring mod_1_N functions. (one): Remove redundant size loop exit condition. 2009-05-20 Torbjorn Granlund * mpn/x86/pentium4/sse2/mod_1_4.asm: New file. * mpn/x86/p6/sse2/mod_1_4.asm: New file (grabbing pentium4 code). 2009-05-18 Torbjorn Granlund * gmp-h.in (__GNU_MP_VERSION_MINOR): Bump to 4. (__GNU_MP_VERSION_PATCHLEVEL): Set to -1. * mpn/x86_64/mod_1_4.asm: New file. * mpn/asm-defs.m4: Correct names for mod_1_N functions. Add defines for corresponding cps functions. * mpn/generic/mod_1_2.c: Support any sizes > 1. * mpn/generic/mod_1_3.c: Likewise. * mpn/generic/mod_1_4.c: Likewise. 2009-05-12 Torbjorn Granlund * Version 4.3.1 released. 2009-05-11 Torbjorn Granlund * gmp-h.in (__GNU_MP_VERSION_MINOR): Bump. * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*, LIBMP_LT_*): Bump version info. 2009-05-09 Torbjorn Granlund * tests/mpz: Add MPZ_CHECK_FORMAT to many tests. 2009-05-07 Torbjorn Granlund * mpn/x86/pentium4/sse2/mul_basecase.asm: Avoid L(ret), "ret" is defined in x86-defs.m4. 2009-05-06 Torbjorn Granlund * mpn/x86/p6/aors_n.asm: Use L() for labels. * mpn/x86/pentium4/sse2/addmul_1.asm: Likewise. * mpn/x86/pentium4/sse2/mul_1.asm: Likewise. * mpn/x86/pentium4/sse2/mul_basecase.asm: Likewise. * mpn/x86/pentium4/sse2/sqr_basecase.asm: Likewise. * mpn/x86_64/lshift.asm: Likewise. * mpn/x86_64/rshift.asm: Likewise. * tests/cxx/t-locale.cc (point_string): Declare as extern "C" to placate compilers that mangle variable names. 2009-05-04 Torbjorn Granlund * tests/mpz/t-gcd.c: Generate operands that are multiple of each other. 2009-05-01 Torbjorn Granlund * gmp-h.in (__GMP_EXTERN_INLINE): Support for more systems. (gmp_randinit_set): Add missing __GMP_DECLSPEC. 2009-04-28 Torbjorn Granlund * mpn/generic/neg_n.c: New file. * configure.in (gmp_mpn_functions): Add neg_n. * mpn/asm-defs.m4 (define_mpn): Add neg_n. * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Add neg_n.c. * gmp-h.in: Handle mpn_neg_n properly. * mpn/generic/toom_interpolate_7pts.c (divexact_2exp): Nailify. * mpn/generic/gcdext.c: Change some MPN_NORMALIZE to MPN_NORMALIZE_NOT_ZERO. * mpn/generic/gcdext_lehmer.c: Likewise. Add a MPN_NORMALIZE_NOT_ZERO. * mpn/generic/binvert.c: Remove own mpn_neg_n. * tests/mpz/t-gcd.c: Add some MPZ_CHECK_FORMAT calls. 2009-04-27 Torbjorn Granlund * mpn/Makefile.am (TARG_DIST): Add minithres. * mpn/generic/bdiv_dbm1c.c: Handle nails. 2009-04-26 Torbjorn Granlund * config.guess: Recognise more POWER processor types. 2009-04-25 Torbjorn Granlund * mpn/x86/pentium4/sse2/popcount.asm: Work around Apple reloc bug. * mpn/x86/darwin.m4: Define symbol "DARWIN". 2009-04-19 Torbjorn Granlund * mpn/generic/powm.c (mpn_redc_n): Use ASSERT_ALWAYS, not abort(). * mpn/generic/powm_sec.c: Likewise. * mpn/powerpc64/aix.m4 (EXTERN_FUNC): New define. Add dummy variants for other m4 files. * mpn/powerpc64/mode64/divrem_1.asm: Use EXTERN_FUNC. * mpn/powerpc64/mode64/divrem_1.asm: Likewise. 2009-04-16 Torbjorn Granlund * mpn/x86_64/x86_64-defs.m4 (JUMPTABSECT): New define. * mpn/x86_64/darwin.m4: Likewise. * mpn/x86_64/sqr_basecase.asm: Rework switch code using JUMPTABSECT. * tune/common.c (speed_mpn_hgcd, speed_mpn_hgcd_lehmer): Remove an unused variable. * mpn/x86/x86-defs.m4 (LEA): Get SIZE arguments right. 2009-04-14 Torbjorn Granlund * Version 4.3.0 released. * scanf/doscan.c (__gmp_doscan): Pad 3-operand scanf call with dummy argument. * scanf/sscanffuns.c (scan): Disable vsscanf variant for now. 2009-04-13 Torbjorn Granlund * scanf/sscanffuns.c (scan): Rewrite to use stdarg. * tests/mpz/t-root.c: Rewrite. Add unconditional gcc 4.3.2 tests. 2009-04-09 Torbjorn Granlund * mpn/generic/powm.c: New file. * mpn/generic/powlo.c: New file. * mpn/generic/powm_sec.c: New file. * configure.in (gmp_mpn_functions): List new functions. 2009-04-08 Torbjorn Granlund * mpz/urandomm.c: Amend last fix. 2009-04-06 Torbjorn Granlund * configure.in: Support Sun cc for x86_64. * mpz/urandomm.c: Handle operand overlap. 2009-03-11 Torbjorn Granlund * configure.in (powerpc): Brave removing -Wa,-mppc64, in the hope that GCC now passes the proper options. 2009-03-09 Torbjorn Granlund * mpn/x86_64/divrem_1.asm: Add a nop to save a cycle in unnormalised case. 2009-03-05 Torbjorn Granlund * ia64/gmp-mparam.h, arm/gmp-mparam.h, x86/p6/mmx/gmp-mparam.h, pa32/hppa2_0/gmp-mparam.h sparc32/v9/gmp-mparam.h: Update. 2009-03-03 Torbjorn Granlund * mpn/ia64/bdiv_dbm1c.asm: Accept/return carry. 2009-03-02 Torbjorn Granlund * configure.in (64-bit sparc/solaris): Pass -xO3, not -O3 to solaris system compiler. 2009-03-01 Torbjorn Granlund * longlong.h (mips, powerpc): Provide assembly-free umul_ppmm for newer gcc. 2009-02-04 Torbjorn Granlund * mpn/generic/redc_2.c: Remove code for testing and timing. Update to current FSF header. * mpn/generic/redc_1.c: Update to current FSF header. 2009-01-21 Torbjorn Granlund * mpz/powm.c (redc): Remove. (mpz_powm): Use mpn_redc_1 instead of redc. * tests/mpz/t-powm.c: Rewrite reference code. 2009-01-18 Torbjorn Granlund * tests/mpz: Increase reps for many tests. * mpn/generic/rootrem.c (mpn_rootrem_internal): Use MPN_DECR_U instead of mpn_sub_1 (works around gcc 4.3 bugs and is also faster). 2009-01-16 Torbjorn Granlund * tests/tests.h: Declare refmpn_divrem_2. 2009-01-15 Torbjorn Granlund * mpz/perfpow.c: Add TMP_FREE before every return statement. * mpn/generic/rootrem.c (mpn_rootrem_internal): Add a missing TMP_FREE. * configure.in (gcc_cflags, gcc_64_cflags): Revert from -O3 to -O2, the change was accidental and cause too much miscompilation. 2009-01-14 Torbjorn Granlund * tune/tuneup.c (tune_mod_1): Run MOD_1_x_THRESHOLD tests also when longlong.h specified UDIV_PREINV_ALWAYS. * mpn/generic/mod_1.c (mpn_mod_1): Properly check for normalisation divisor. 2009-01-13 Torbjorn Granlund * tune/tuneup.c (tune_mod_1): Tune for MOD_1_1_THRESHOLD, MOD_1_2_THRESHOLD, and MOD_1_4_THRESHOLD. * mpn/generic/mod_1.c: Rewrite. * mpn/generic/mod_1_1.c: New file. * mpn/generic/mod_1_2.c: New file. * mpn/generic/mod_1_3.c: New file. * mpn/generic/mod_1_4.c: New file. * configure.in (gmp_mpn_functions): Add mod_1_*. * mpn/asm-defs.m4 (define_mpn): Add mod_1_*. * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Add mod_1_*.c. * gmp-impl.h: Declare new mpn_mod_1s_* functions and associated THRESHOLD macros. (udiv_rnd_preinv): New macro. 2009-01-12 Torbjorn Granlund * tune/tuneup.c (tune_gcd_dc,tune_gcdext_dc): Lower step_factor to 0.1. 2009-01-08 Torbjorn Granlund * tests/mpz/t-nextprime.c: New test file. * tests/mpz/Makefile.am (check_PROGRAMS): Add t-nextprime. From Niels Möller: * mpz/nextprime.c: Handle large prime gaps by limiting incr. 2009-01-04 Torbjorn Granlund * mpz/and.c, mpz/ior.c, mpz/xor.c: Re-read only necessary source pointers after reallocation. Misc cleanup. * gmp-impl.h (MPN_TOOM44_MAX_N): New define, replaces MPN_TOOM3_MAX_N. * mpn/x86/fat/diveby3.c: New file. 2008-12-30 Niels Möller * doc/gmp.texi (Greatest Common Divisor Algorithms): Updated section on GCD algorithms. 2008-12-29 Torbjorn Granlund * doc/gmp.texi (Multiplication Algorithms): Add descriptions of Toom-4 and unbalanced multiplication. (Radix to Binary): Add warning that text is outdated, (Contributors): Fix typos. * mpn/generic/toom*.c: Use coherent MAYBE_ macros for trimming unreachable recursive functions. * gmp-impl.h: Update toom itch functions. * mpn/x86_64/sqr_basecase.asm: Slightly increase stack allocation, to placate tuneup. 2008-12-28 Torbjorn Granlund * mpn/x86_64/pentium4/aors_n.asm: Tune prologue code. * mpn/x86_64/pentium4/aorslsh1_n.asm: New file. * mpn/x86_64/darwin.m4: Define symbol "DARWIN". * mpn/x86_64/invert_limb.asm: Work around darwin quirks. * mpn/x86_64/sqr_basecase.asm: Further optimize, support Darwin. * mpn/x86_64/invert_limb.asm: New file. 2008-12-27 Torbjorn Granlund * mpn/x86_64/core2/aorslsh1_n.asm: New file. 2008-12-26 Torbjorn Granlund * mpz/perfpow.c: Handle negative arguments properly. * tests/mpz/t-perfpow.c: New file. * tests/mpz/Makefile.am (check_PROGRAMS): Add t-perfpow. 2008-12-23 Torbjorn Granlund * tests/mpz/t-mul.c (dump_abort): Improve error message. * gcd.c gcd_subdiv_step.c gcdext.c gcdext_subdiv_step.c: Remove private mpn_zero_p. * tune/tuneup.c (tune_mul): Tune for MUL_TOOM44_THRESHOLD. (tune_sqr): Tune for SQR_TOOM4_THRESHOLD. * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add toom44_mul.c and toom4_sqr.c. * configure.in (gmp_mpn_functions): Toom function updates. * Rename mpn/mul_toomMN.c to mpn/toomMN_mul.c. Function names changed accordingly. * mpn/toomMN_mul.c: Add scratch parameter. Do recursive multiplies properly. Misc tuning. Remove CHECK and TIMING code. * mpn/toom2_sqr.c, mpn/toom3_sqr.c, mpn/toom4_sqr.c: New files. * gmp-impl.h (mpn_toomMN_mul_itch): Several new functions. (mpn_zero_p): New functions. Add various TOOM4/TOOM44 related parameters. Update mpn_toomMN_mul prototypes. * mpn/generic/mul_n.c (mpn_mul_n): Call mpn_toom44_mul. Use TMP_BALLOC instead of malloc. (mpn_sqr_n): Analogous changes. * mpn/generic/mul.c: Update unbalanced toom code to pass scratch space. 2008-12-21 Torbjorn Granlund * mpz/nextprime.c: Add TMP_SDECL/MARK/FREE. 2008-12-20 Torbjorn Granlund * mpn/generic/sqrtrem.c (mpn_sqrtrem1): Rewrite, improve interface. (invsqrttab): New table, remove table approx_tab. (mpn_sqrtrem2): Optimize, update mpn_sqrtrem1 call. (mpn_sqrtrem): Update mpn_sqrtrem1 call. 2008-12-18 Torbjorn Granlund * mpz/nextprime.c: Run 10 mpz_millerrabin tests (was 5). Give credit to authors. * mpn/x86_64/redc_1.asm: Align stack as mandated by ABI. * mpn/x86_64/divrem_2.asm: Add some comments. * mpn/x86_64/darwin.m4: New file. * configure.in: Use x86_64/darwin.m4. 2008-12-15 Torbjorn Granlund * doc/projects.html: Remove GCD and division projects, update text on multiplication. * doc/tasks.html: Add a caution about that the file is somewhat outdated. 2008-12-14 Torbjorn Granlund * mpn/alpha/ev6/aorsmul_1.asm: New file (same code for mpn_addmul_1, much improved for mpn_submul_1). * mpn/alpha/ev6/addmul_1: File removed. * mpn/alpha/ev6/submul_1: File removed. 2008-12-09 Torbjorn Granlund From David Harvey: * mpn/x86_64/mul_basecase.asm: Further tweaks for code size and speed. * mpn/powerpc64/mode64/divrem_1.asm: Rewrite. * mpn/powerpc64/mode64/mul_basecase.asm: New file. 2008-12-08 Torbjorn Granlund * mpn/powerpc64/mode64/gmp-mparam.h: New file. * gmp-impl.h: Additional cleanups. (mpn_set_str_compute_powtab): New prototype. (mpn_powm, mpn_powlo): New prototypes. * mpz/pow_ui.c: Handle some small exponents locally. 2008-12-07 Torbjorn Granlund * mpn/generic/set_str.c: Remove prototypes (they are in gmp-impl.h). * tune/set_strs.c, tune/set_strb.c: Make prototypes effective by moving the #define mpn_set_str* before including gmp-impl.h. * All files: Change _PROTO => __GMP_PROTO. * tune/speed.c (routine): Remove non-working choice mpn_set_str_subquad. * tune/common.c (speed_mpn_dc_set_str): Remove, it is broken. * mpn/generic/toom_interpolate_7pts.c (divexact_2exp): Make this static, and inline it. * gmp-impl.h: Major cleanup. (Remove formal parameter names. Use __GMP_PROTO consistently. Move __GMP_PROTO and __MPN use to adjacent lines for declared function. Fix typos. Remove code inside #if 0.) * configure.in (gmp_mpn_functions): Add mul_toom33. Reformat. 2008-12-05 Torbjorn Granlund * mpn/generic/redc_1.c: New file. * mpn/generic/redc_2.c: New file. * configure.in (gmp_mpn_functions): List redc_1 and redc_2. (HAVE_NATIVE): Likewise. * tune/common.c (speed_mpn_redc_1): Renamed from speed_redc. * tune/speed.c (routine): Remove "redc", and "mpn_redc_1". * tune/speed.h (SPEED_ROUTINE_REDC_1): Renamed from SPEED_ROUTINE_REDC. Updated call. * tune/tuneup.c (tune_powm): Update redc call. 2008-12-04 Torbjorn Granlund * mpn/x86_64/sqr_basecase.asm: Inline a combined diagonal product code and addlsh1 loop. Misc cleanup. 2008-12-02 Torbjorn Granlund * mpn/x86_64/sqr_basecase.asm: New file. 2008-11-30 Torbjorn Granlund * mpn/generic/sqr_basecase.c: Fix typo in mpn_addmul_2s variant. 2008-11-28 Torbjorn Granlund * mpn/x86_64/redc_1.asm: Rewrite. 2008-11-27 Torbjorn Granlund * tests/refmpn.c (refmpn_redc_1): New function. 2008-11-25 Torbjorn Granlund * mpn/x86/k7/aorsmul_1.asm: Actually handle mpn_submul_1. 2008-11-23 Torbjorn Granlund * mpn/x86_64/divrem_1.asm: Rewrite. * alpha/divrem_2.asm: New file. * powerpc32/divrem_2.asm: New file. * powerpc64/mode64/divrem_2.asm: New file. * x86/divrem_2.asm: New file. * x86_64/divrem_2.asm: New file. * tests/refmpn.c (refmpn_divrem_2): New function. 2008-11-22 Torbjorn Granlund * mpn/x86/k7/mul_1.asm: Rewrite for smaller size and better speed. * mpn/x86/k7/aorsmul_1.asm: Likewise. * acinclude.m4 (GMP_VERSION): Include last component even when zero. 2008-11-21 Torbjorn Granlund * mpn/x86_64/README: Rewrite. * tests/devel/try.c (malloc_region, mprotect_maybe): Add casts for printf type correctness. * gmp-h.in (__GNU_MP_VERSION_MINOR): Bump. * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*, LIBMP_LT_*): Bump version info. 2008-11-20 Torbjorn Granlund * gmp-impl.h: Rename modlimb_invert to binvert_limb. * tune/speed.h: Likewise. * tune/modlinv.c: Likewise. * tune/common.c: Likewise. * tests/t-modlinv.c: Likewise. * tests/t-constants.c: Likewise. * mpn/sparc64/mode1o.c: Likewise. * mpn/alpha/dive_1.c: Likewise. * mpn/sparc64/dive_1.c: Likewise. * mpn/generic/mode1o.c: Likewise. * mpn/generic/dive_1.c: Likewise. * mpn/generic/bdivmod.c: Likewise. * mpn/alpha/mode1o.asm: Likewise. * mpn/asm-defs.m4: Likewise. * mpn/ia64/mode1o.asm: Likewise. * mpn/powerpc32/README: Likewise. * mpn/powerpc32/mode1o.asm: Likewise. * mpn/powerpc64/mode64/dive_1.asm: Likewise. * mpn/powerpc64/mode64/mode1o.asm: Likewise. * mpn/x86/dive_1.asm: Likewise. * mpn/x86/k6/mmx/dive_1.asm: Likewise. * mpn/x86/k6/mode1o.asm: Likewise. * mpn/x86/k7/dive_1.asm: Likewise. * mpn/x86/k7/mode1o.asm: Likewise. * mpn/x86/p6/dive_1.asm: Likewise. * mpn/x86/p6/mode1o.asm: Likewise. * mpn/x86/pentium/dive_1.asm: Likewise. * mpn/x86/pentium/mode1o.asm: Likewise. * mpn/x86/pentium4/sse2/dive_1.asm: Likewise. * mpn/x86/pentium4/sse2/mode1o.asm: Likewise. * mpn/x86_64/dive_1.asm: Likewise. * mpn/x86_64/mode1o.asm: Likewise. * mpn/x86_64/aors_n.asm: Replace with slightly faster, more alignment neutral loop. 2008-11-18 Torbjorn Granlund * configure.in: Remove gcd_finda related declarations. * gmp-impl.h (mpn_gcd_finda): Remove declaration. * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Remove gcd_finda. * mpn/asm-defs.m4: Remove define_mpn(gcd_finda). * mpn/x86/k6/gcd_finda.asm: Remove file. * tests/devel/try.c (param_init): Remove mpn_gcd_finda. (choice_array): Remove mpn_gcd_finda. * tests/mpn/t-instrument.c (check): Remove testing of mpn_gcd_finda. * tests/refmpn.c (refmpn_gcd_finda): Remove. * tests/tests.h (refmpn_gcd_finda): Remove declaration. * tune/common.c (speed_mpn_gcd_finda): Remove. * tune/gcd_finda_gen.c: Remove file. * tune/speed.h (speed_mpn_gcd_finda): Remove declaration. * tune/speed.c (routine): Remove mpn_gcd_finda entry. * tests/mpz/t-powm.c: Print test number when failing a test. * mpn/x86_64/redc_1.asm (CALL): Move from here... * mpn/x86_64/x86_64-defs.m4: ...to here. * gmp-impl.h (mpn_jacobi_base): Remove parameter names. 2008-11-11 Torbjorn Granlund * tests/mpf/t-conv.c: Add some specific tests, supplementing the random tests. 2008-11-09 Torbjorn Granlund * mpf/set_str.c: Default 'base' before letting exp_base inherit it. * tests/cxx/t-prec.cc: Use the right precision for all float constants. 2008-11-08 Torbjorn Granlund * doc/gmp.texi (Float Comparison): Update mpf_eq documentation. * mpf/eq.c: Compare the right number of bits. 2008-11-02 Torbjorn Granlund Undo, it made testing too slow: * tests/mpz/t-mul.c: Use slower geometric progression for operand sizes. * mpn/x86/k7/mod_34lsub1.asm: Use movzb for masking low 8 bits. 2008-10-31 Niels Möller * mpn/generic/hgcd2.c (div1): New function (taken from old gcdext implementation) (mpn_hgcd2): Use single precision for the second half of the work. 2008-10-30 Torbjorn Granlund * mpn/x86/p6/sse2/gmp-mparam.h: New file. 2008-10-29 Torbjorn Granlund * configure.in (x86 fat_path): Add "x86/p6/sse2". * mpn/x86/fat/fat.c (__gmpn_cpuvec_init): Recognize sse2 capable p6 (pentiumm, core2). * mpn/x86/p6/sse2/mul_1.asm: New file. * mpn/x86/p6/sse2/addmul_1.asm: New file. * mpn/x86/p6/sse2/submul_1.asm: New file. * mpn/x86/p6/sse2/mul_basecase.asm: New file. * mpn/x86/p6/sse2/sqr_basecase.asm: New file. * mpn/x86/p6/sse2/popcount.asm: New file. * mpn/x86/fat/fat.c (__gmpn_cpuvec_init): Handle "extended" fields for model and family. 2008-10-28 Torbjorn Granlund From Mickael Gastineau: * gmp-h.in (gmp_urandomm_ui, gmp_urandomb_ui): Add __GMP_DECLSPEC. 2008-10-27 Torbjorn Granlund * gmp-h.in (mpn_gcdext_1): Remove bogus __GMP_ATTRIBUTE_PURE. 2008-10-27 Niels Möller * tune/common.c (speed_mpn_hgcd): Call mpn_hgcd_matrix_init once for each call to mpn_hgcd. (speed_mpn_hgcd_lehmer): Likewise. 2008-10-26 Torbjorn Granlund * configure.in: Point to p6/sse2 for pentiumm and core2. * gmp-impl.h (mpn_add_nc, mpn_sub_nc): Move these macros to after fat definitions. * tune/common.c, tune/speed.c, tune/speed.h: Add speed measurement of mpn_bdiv_dbm1c. 2008-10-24 Torbjorn Granlund * mpn/x86_64/gmp-mparam.h (MUL_FFT_TABLE2, SQR_FFT_TABLE2): Extend. * mpz/nextprime.c: Move declarations to function beginning. 2008-10-23 Niels Möller * gmp-impl.h (DECL_gcdext_1): Deleted. 2008-10-22 Torbjorn Granlund * mpn/x86_64/atom/aors_n.asm: New file. * mpn/x86_64/atom/gmp-mparam.h: New file. 2008-10-21 Torbjorn Granlund With Neils Möller: * mpz/nextprime.c: Rewrite. * tests/devel/try.c (main): Use strtol for 's' and 'S' optargs. * mpn/x86_64/pentium4/rshift.asm: Misc cleanups. * mpn/x86_64/pentium4/lshift.asm: Likewise. * mpn/x86_64/pentium4/aors_n.asm: Use fewer registers. * configure.in: Set up specific path for x86_64/atom. 2008-10-21 Niels Möller * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Removed qstack.c. * mpn/generic/qstack.c: Deleted obsolete file. 2008-10-20 Torbjorn Granlund * mpn/x86_64/core2/aorsmul_1.asm: New file. 2008-10-19 Torbjorn Granlund * mpn/x86_64/aors_n.asm: Remove redundant MULFUNC_PROLOGUE. * gmp-impl.h (popc_limb): Remove redundant checks of GMP_LIMB_BITS inside several of these macros. 2008-10-17 Torbjorn Granlund * tests/mpz/t-mul.c: Use slower geometric progression for operand sizes. Do every other tests for same size operands. 2008-10-15 Torbjorn Granlund * mpn/x86_64/mul_basecase.asm: Simplify addressing in epilogue. * mpn/mips64/divrem_1.asm: Remove file, it is n32-only, and uses an old algorithm. * config.guess, config.sub, configure.in: Support Intel Atom processor. 2008-10-10 Torbjorn Granlund * mpq/mul.c: Fix typo in last change. 2008-10-09 Torbjorn Granlund * tests/refmpn.c (refmpn_sb_divrem_mn): Work around a gcc bug. 2008-10-08 Torbjorn Granlund * mpq/mul.c: Use TMP_ALLOC. Cleanup. * mpq/div.c: Likewise. * mpn/x86_64/mul_basecase.asm: Use lea directly for loading entry point addresses. 2008-10-09 Niels Möller * mpn/x86/k7/gmp-mparam.h: Updated GCD-related values. 2008-10-05 Torbjorn Granlund * mpn/generic/mul_fft.c (mpn_mul_fft_internal): Do store mpn_fft_norm_modF return value, if (rec). 2008-10-04 Torbjorn Granlund * mpn/x86_64/aorsmul_1.asm: Replace with faster code. * mpn/x86_64/mul_1.asm: Likewise. * mpn/x86_64/addmul_2.asm: Likewise. * mpn/x86_64/mul_2.asm: Likewise. * mpn/x86_64/mul_basecase.asm: Likewise. 2008-10-02 Torbjorn Granlund * mpn/minithres/gmp-mparam.h: Update FFT values. 2008-10-02 Niels Möller * hgcd.c (mpn_hgcd_matrix_mul): Fixed normalization bug. 2008-09-24 Torbjorn Granlund * configure.in: Handle --enable-minithres. * mpn/minithres/gmp-mparam.h: Update all values. 2008-09-22 Torbjorn Granlund * tune/speed.c (routine): New entry for mpn_mul. * tune/speed.h (SPEED_ROUTINE_MPN_MUL): Renamed from SPEED_ROUTINE_MPN_MUL_BASECASE. (speed_mpn_mul): Renamed from speed_mpn_mul_basecase. (SPEED_ROUTINE_MPN_MUL): Allocate our own memory of xp operand. * tune/common.c: Corresponding changes. 2008-09-22 Niels Möller * mpn/generic/gcdext.c (hgcd_mul_matrix_vector): New function, replaces addmul2_n. Needs less copying. (mpn_gcdext): Use hgcd_mul_matrix_vector. Updated for interface change in mpn_gcdext_subdiv_step * mpn/generic/hgcd.c (hgcd_matrix_mul_1): Rewritten to use mpn_hgcd_mul_matrix1_vector. (hgcd_step): Updated for interface change in mpn_hgcd_mul_matrix1_inverse_vector. * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Updated for interface changes in mpn_hgcd_mul_matrix1_vector, mpn_hgcd_mul_matrix1_inverse_vector and mpn_gcdext_subdiv_step. * mpn/generic/gcd_lehmer.c (mpn_gcd_lehmer_n): Updated for interface change in mpn_hgcd_mul_matrix1_inverse_vector. * mpn/generic/gcdext_subdiv_step.c (mpn_gcdext_subdiv_step): Use separate scratch arguments for the quotient and for the cofactor update. * mpn/generic/hgcd2.c (mpn_hgcd_mul_matrix1_vector): Interface change. Store first element in rp and leave ap unmodified. No additional scratch space or copying needed. Callers that require modification in place still need to copy one of the inputs. (mpn_hgcd_mul_matrix1_inverse_vector): Likewise. 2008-09-22 Niels Möller * mpn/generic/hgcd.c (hgcd_matrix_mul_1): Use mpn_addaddmul_1msb0. * mpn/generic/hgcd2.c (mpn_hgcd_mul_matrix1_vector): Likewise. * mpn/generic/gcd.c: Use libspeed for timing measurements. * gmp-impl.h: Declare mpn_addaddmul_1msb0. * mpn/asm-defs.m4: Added addaddmul_1msb0. * mpn/x86_64/addaddmul_1msb0.asm: New file. * configure.in (gmp_mpn_functions_optional): Added addaddmul_1msb0. (HAVE_NATIVE): List addaddmul_1msb0. 2008-09-21 Torbjorn Granlund * mpn/generic/get_str.c (GET_STR_DC_THRESHOLD): Remove default. (GET_STR_PRECOMPUTE_THRESHOLD): Likewise. Misc code cleanups. * gmp-impl.h (mpn_dc_set_str_itch): Allocate GMP_LIMB_BITS more limbs. Revert: * mpn/generic/set_str.c: (mpn_dc_set_str): Remove impossible case, replace by an ASSERT. 2008-09-18 Torbjorn Granlund * mpn/alpha/ev6/gmp-mparam.h (DIVEXACT_BY3_METHOD): Define. * mpn/ia64/diveby3.asm: Remove. * mpn/x86/diveby3.asm: Remove. * mpn/x86/k6/diveby3.asm: Remove. * mpn/x86/k7/diveby3.asm: Remove. * mpn/x86/p6/diveby3.asm: Remove. * mpn/x86/pentium/diveby3.asm: Remove. * mpn/x86_64/diveby3.asm: Remove. * mpn/x86/pentium4/sse2/diveby3.asm: Remove. * configure.in (HAVE_NATIVE): List divexact_by3c. * gmp-impl.h (mpn_divexact_by3c): Override gmp-h.in's definition. (DIVEXACT_BY3_METHOD): Don't default to 0 if HAVE_NATIVE_mpn_divexact_by3c. 2008-09-18 Niels Möller * mpn/generic/gcd.c (main): Added code for tuning of CHOOSE_P. * mpn/generic/hgcd.c (mpn_hgcd_matrix_mul): Assert that inputs are normalized. 2008-09-17 Niels Möller * mpn/generic/gcdext.c (mpn_gcdext): p = n/5 caused a slowdown for large inputs. As a compromise, use p = n/2 for the first iteration, and p = n/3 for the rest. Handle the first iteration specially, since the initial u0 and u1 are trivial. * mpn/x86_64/gmp-mparam.h (GCDEXT_DC_THRESHOLD): Reduced threshold from 409 to 390. * mpn/generic/gcdext.c (CHOOSE_P): New macro. Use p = n/5. (mpn_gcdext): Use CHOOSE_P, and generalized the calculation of scratch space. * tune/tuneup.c (tune_hgcd): Use default step factor. * mpn/x86_64/gmp-mparam.h: (GCD_DC_THRESHOLD): Reduced from 493 to 412. * mpn/generic/gcd.c (CHOOSE_P): New macro, to determine the split when calling hgcd. Use p = 2n/3, as that seems better than the more obvious split p = n/2. (mpn_gcd): Use CHOOSE_P, and generalized the calculation of scratch space. 2008-09-16 Torbjorn Granlund * mpn/generic/toom_interpolate_7pts.c: Use new mpn_divexact_byN functions. * gmp-impl.h (mpn_divexact_by3, mpn_divexact_by5, mpn_divexact_by7, mpn_divexact_by9, mpn_divexact_by11, mpn_divexact_by13, mpn_divexact_by15): New macros, defined in terms of mpn_bdiv_dbm1. * configure.in (gmp_mpn_functions): List bdiv_dbm1c. (HAVE_NATIVE): Likewise. * mpn/asm-defs.m4: Define bdiv_dbm1c. * gmp-impl.h (mpn_bdiv_dbm1c): Declare. (mpn_bdiv_dbm1): New macro. * mpn/generic/bdiv_dbm1c.c: New file. * mpn/alpha/bdiv_dbm1c.asm: New file. * mpn/ia64/bdiv_dbm1c.asm: New file. * mpn/powerpc32/bdiv_dbm1c.asm: New file. * mpn/powerpc64/mode64/bdiv_dbm1c.asm: New file. * mpn/x86/bdiv_dbm1c.asm: New file. * mpn/x86_64/bdiv_dbm1c.asm: New file. * mpn/generic/diveby3.c: Add mpn_bdiv_dbm1c based function. Choose function depending on DIVEXACT_BY3_METHOD. * gmp-impl.h (DIVEXACT_BY3_METHOD): Provide default. 2008-09-16 Niels Möller * mpn/generic/hgcd.c (mpn_hgcd_addmul2_n): Moved function to gcdext.c, where it is used. * mpn/generic/gcdext.c (addmul2_n): Moved and renamed, was mpn_hgcd_addmul2_n. Made static. Deleted input normalization. Deleted rn argument. (mpn_gcdext): Updated calls to addmul2_n, and added assertions. * gmp-impl.h (MPN_HGCD_MATRIX_INIT_ITCH): Increased storage by 4 limbs. (MPN_HGCD_LEHMER_ITCH): Reduced storage by one limb. (MPN_GCD_SUBDIV_STEP_ITCH): Likewise. (MPN_GCD_LEHMER_N_ITCH): Likewise. * mpn/generic/hgcd.c (mpn_hgcd_matrix_init): Use two extra limbs. (hgcd_step): Use overlapping arguments to mpn_tdiv_qr. (mpn_hgcd_matrix_mul): Deleted normalization code. Tighter bounds for the element size of the product. Needs two extra limbs of storage for the elements. (mpn_hgcd_itch): Updated storage calculation. * mpn/generic/gcd_subdiv_step.c (mpn_gcd_subdiv_step): Use overlapping arguments to mpn_tdiv_qr. Use mpn_zero_p. * mpn/generic/gcd.c (mpn_gcd): Use mpn_zero_p. 2008-09-15 Niels Möller * mpn/generic/hgcd.c (mpn_hgcd_matrix_init): Updated for deleted tp pointer. (hgcd_matrix_update_q): Likewise. (mpn_hgcd_matrix_mul): Likewise. (mpn_hgcd_itch): Updated calculation of scratch space. * gmp-impl.h (struct hgcd_matrix): Deleted tp pointer. (MPN_HGCD_MATRIX_INIT_ITCH): Reduced storage. (mpn_hgcd_step, MPN_HGCD_STEP_ITCH): Deleted declarations. 2008-09-15 Niels Möller * mpn/x86_64/gmp-mparam.h (MATRIX22_STRASSEN_THRESHOLD): New threshold. * mpn/generic/hgcd.c (mpn_hgcd_matrix_mul): Use mpn_matrix22_mul. (mpn_hgcd_itch): Updated calculation of scratch space. Use count_leading_zeros to get the recursion depth. * mpn/generic/gcd.c (mpn_gcd): Fixed calculation of scratch space, and use mpn_hgcd_itch. 2008-09-15 Niels Möller * tune/tuneup.c (tune_matrix22_mul): New function. (all): Use it. * tune/common.c (speed_mpn_matrix22_mul): New function. * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Added matrix22_mul.c. * tests/mpn/t-matrix22.c: Use MATRIX22_STRASSEN_THRESHOLD to select sizes for tests. * gmp-impl.h (MATRIX22_STRASSEN_THRESHOLD): New threshold * configure.in (gmp_mpn_functions): Added matrix22_mul. * gmp-impl.h: Added declarations for mpn_matrix22_mul and related functions. * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Added matrix22_mul.c. * tests/mpn/Makefile.am (check_PROGRAMS): Added t-matrix22. * tests/mpn/t-matrix22.c: New file. * mpn/generic/matrix22_mul.c: New file. 2008-09-11 Niels Möller * tune/tuneup.c: Updated tuning of gcdext. * mpn/x86_64/gmp-mparam.h (GCDEXT_DC_THRESHOLD): Reduced threshold from 713 to 409. 2008-09-11 Niels Möller * gmp-impl.h: Updated for gcdext changes. (GCDEXT_DC_THRESHOLD): New constant, renamed from GCDEXT_SCHOENHAGE_THRESHOLD. * mpn/generic/gcdext.c (compute_v): Accept non-normalized a and b as inputs. (mpn_gcdext): Rewrote and simplified. Now uses the new mpn_hgcd interface. * mpn/generic/hgcd.c (mpn_hgcd_addmul2_n): Renamed from addmul2_n and made non-static. Changed interface to take non-normalized inputs, and only two size arguments. (mpn_hgcd_matrix_mul): Simplified using new mpn_hgcd_addmul2_n. * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_itch): Deleted function. (mpn_gcdext_lehmer_n): Renamed from mpn_gcd_lehmer. Now takes inputs of equal size. Moved the code for the division step to a separate function... * mpn/generic/gcdext_subdiv_step.c (mpn_gcdext_subdiv_step): New file, new function. * configure.in (gmp_mpn_functions): Added gcdext_subdiv_step. 2008-09-10 Torbjorn Granlund * tests/devel/anymul_1.c: Include . * gmp-h.in: Unconditionally include . 2008-09-10 Niels Möller * tune/common.c: #if:ed out speed_mpn_gcd_binary and speed_mpn_gcd_accel. * tune/speed.c (routine): #if:ed out mpn_gcd_binary, mpn_gcd_accel and find_a. * tune/Makefile.am (libspeed_la_SOURCES): Removed gcd_bin.c gcd_accel.c gcd_finda_gen.c. * tune/tuneup.c: Enable tuning of GCD_DC_THRESHOLD. * mpn/generic/gcd.c (mpn_gcd): Rewrote and simplified. Now uses the new mpn_hgcd interface. * */gmp-mparam.h: Renamed GCD_SCHOENHAGE_THRESHOLD to GCD_DC_THRESHOLD. * mpn/generic/gcd_lehmer.c (mpn_gcd_lehmer_n): Renamed (was mpn_gcd_lehmer). Now takes inputs of equal size. * mpn/generic/gcd_lehmer.c (mpn_gcd_lehmer): Reintroduced gcd_2, to get better performance for small inputs. * mpn/generic/hgcd.c: Don't hardcode small HGCD_THRESHOLD. * mpn/x86_64/gmp-mparam.h (HGCD_THRESHOLD): Reduced from 145 to 120. * */gmp-mparam.h: Renamed HGCD_SCHOENHAGE_THRESHOLD to HGCD_THRESHOLD. 2008-09-09 Torbjorn Granlund * doc/gmp.texi: Fix a typo and clarify mpn_gcdext docs. 2008-09-09 Niels Möller * tune/common.c (speed_mpn_hgcd, speed_mpn_hgcd_lehmer): Adapted to new hgcd interface. * gmp-impl.h (MPN_HGCD_LEHMER_ITCH): New macro. * hgcd.c (mpn_hgcd_lehmer): Renamed function, from hgcd_base. Made non-static. * gcd_lehmer.c (mpn_gcd_lehmer): Use hgcd2 also for n == 2. * gcdext_lehmer.c (mpn_gcdext_lehmer): Simplified code for division step. Added proper book-keeping of swaps, which affect the sign of the returned cofactor. * tests/mpz/t-gcd.c (one_test): Display co-factor when mpn_gcdext fails. * gcd_lehmer.c (mpn_gcd_lehmer): At end of loop, need to handle the special case n == 1 correctly. * gcd_subdiv_step.c (mpn_gcd_subdiv_step): Simplified function. The special cancellation logic is not needed here. 2008-09-08 Torbjorn Granlund * mpn/generic/invert.c: Add working but slow code. * mpn/x86_64/x86_64-defs.m4 (R32, R8): New macros. * mpn/ia64/submul_1.asm: Move some labels for broader assembler compatibility. * gmp-impl.h (mpn_mul_3, mpn_mul_4): Declare. * tests/tests.h (refmpn_mul_3, refmpn_mul_4): Declare. * tests/try.c (param_init): Set things up for mpn_mul_3 and mpn_mul_4. (choice_array): Likewise. (call): Likewise. * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Add mul_3.c and mul_4. * mpn/asm-defs.m4: Define mul_3 and mul_4. * tests/refmpn.c (refmpn_mul_N): New function. (refmpn_mul_2): Remove old definition, call refmpn_mul_N. (refmpn_mul_3, refmpn_mul_4): New functions. * tune/common.c (speed_mpn_mul_3, speed_mpn_mul_4): New functions. * tune/speed.h (speed_mpn_mul_3, speed_mpn_mul_4): Declare. * tune/speed.c (routine): New entries for mpn_mul_2 and mpn_mul_3. * ltmain.sh: Update to libtool 1.5.24. * mpn/generic/mul_toom22.c: Compute s and t more cleverly. 2008-09-08 Niels Möller * tests/mpn/t-hgcd.c: Updated tests. Rewrite of hgcd_ref. * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_itch): New function. (mpn_gcdext_lehmer): Various bugfixes. * gcdext.c (mpn_gcdext): Allocate scratch space for gcdext_lehmer. * mpn/generic/gcd_lehmer.c (gcd_2): ASSERT that inputs are odd. (mpn_gcd_lehmer): Added tp argument, for scratch space. Make both arguments odd before calling gcd_2. * mpn/generic/hgcd.c (mpn_hgcd): Allow the trivial case n <= 2, and return 0 immediately. * gmp-impl.h (MPN_EXTRACT_NUMB): New macro. * configure.in (gmp_mpn_functions): Added gcdext_lehmer. 2008-09-05 Torbjorn Granlund * mpn/generic/toom_interpolate_7pts.c: Use mpn_divexact_by3c instead of divexact_odd. * doc/texinfo.tex: Update to 2007-06-29.13. * doc/gmp.texi: Update GMP site URL. Fix some typos. * demos/pexpr.c (main): Allow bases up to 62. * gmp-impl.h: Remove formal parameter names from function prototypes. * config.guess: Recognize recent AMD and Itanium CPUs. Default X86 CPU recognition to configfsf.guess' value. * configure.in: Handle core2 separately from athlon64. 2008-09-05 Niels Möller * */Makefile.in, configure, aclocal.m4, config.in: Removed files from repository. They're instead generated by automake and autoconf before distribution. 2008-08-25 Torbjorn Granlund * mpf/set_str.c: Allocate mantissa space based on mantissa size, not on destination variable space. * mpf/set_str.c: Accept unary plus before exponent. 2008-08-06 Torbjorn Granlund * mpn/generic/mul_toom22.c: Add statistics gathering functionality, triggered by cpp predef STAT. From David Harvey: * mpn/generic/mul_toom22.c: Decrease scratch space usage. 2008-08-02 Torbjorn Granlund * tests/misc/t-scanf.c: Avoid negative arguments to _ui functions. * tests/misc/t-printf.c: Likewise. * acinclude.m4 (X86_PATTERN): Add geode. * acinclude.m4 (CL_AS_NOEXECSTACK): Avoid -q flag to grep. 2008-08-01 Torbjorn Granlund * acinclude.m4 (CL_AS_NOEXECSTACK): New. * configure.in: Use CL_AS_NOEXECSTACK. * mpn/Makeasm.am: Use ASM_FLAGS (defined by CL_AS_NOEXECSTACK). * gmpxx.h (__GMP_DBL_LIMBS): Use DBL_MAX_EXP instead of std::numeric_limits::max_exponent for better portability. 2008-07-29 Torbjorn Granlund * gmpxx.h (__GMP_DBL_LIMBS): New #define. (__GMP_ULI_LIMBS): New #define. (__GMPXX_TMP_UI): New macro. (__GMPXX_TMP_SI): New macro. (__GMPXX_TMP_D): New macro. (struct __gmp_binary_and): Rewrite, using the new macros. (struct __gmp_binary_ior): Likewise. (struct __gmp_binary_xor): Likewise. 2008-07-28 Torbjorn Granlund * tests/cxx/t-binary.cc: Add some tests for logical operations. 2008-07-24 Torbjorn Granlund * gmpxx.h: Use __GMPZ_* instead of __GMPZZ_* for bitwise ops, remove __GMPZZ_*. Remove repeated #undefs. (__gmp_alloc_cstring): Declare freefunc as extern "C". 2008-07-23 Torbjorn Granlund * gmp-h.in (__GMP_CC): New define, undocumented for now. (__GMP_CFLAGS): Likewise. 2008-07-21 Torbjorn Granlund * tests/amd64check.c: Fix a printf type clash. * mpz/realloc.c: Amend last fix. * gmp-h.in: Include for C++. * gmp-h.in: Handle new gcc 4.3 inline semantics defaults. * configfsf.guess: Update to version of 2008-04-14. * configfsf.sub: Update to version of 2008-06-16. * configure.in: Separate core2 and athlon64 flags handling. 2008-06-19 Torbjorn Granlund * config.guess: Recognize pentiumm and AMD geode. * config.sub: Likewise. * configure.in: Likewise. 2008-06-02 Torbjorn Granlund * configure.in: Disallow odd nails sizes. * configure.in: Inherit default gcc_cflags/gcc_64_cflags everywhere. 2008-05-23 Torbjorn Granlund * mpz/init2.c: Rewrite to avoid internal overflow and to detect mpz_t overflow. * mpz/realloc2.c: Likewise. * mpz/realloc.c: Detect mpz_t overflow. 2008-05-22 Torbjorn Granlund * configure.in (sparc): Remove -fast, it causes documented miscompilation. * config.guess: Properly handle the "extended" variants of x86 cpuid. 2008-05-09 Torbjorn Granlund * gmp-impl.h (mpn_mul_fft): Now void. (udiv_qrnnd_preinv3): Special case for constant (nl). 2008-05-08 Torbjorn Granlund * mpn/generic/mul_fft.c: Clean up types in TRACE (printf (...)). (TRACE): Redefine to allow command line control. (mpn_mul_fft_internal): Now void, remove return value. (mpn_mul_fft): Likewise. (MPN_FFT_TABLE2_SIZE): Up size fro 256 to 512. (mpn_fft_fft): Call mpn_fft_mul_2exp_modF just once instead of twice, then add/subtract result. Get rid of temp allocation as a result. Remove some redundant CNST_LIMB. (mpn_fft_fftinv): Analogous changes. (mpn_fft_sub_modF): Re-enable, now needed by mpn_fft_fft and mpn_fft_fftinv. 2008-03-10 Torbjorn Granlund * tests/mpz/t-mul.c (main): Let GMP_CHECK_FFT mean largest allowed power-of-2 of test operands. 2008-02-28 Torbjorn Granlund * tests/cxx/t-binary.cc (check_mpz): Expect floor rounding for right shift. 2008-02-27 Torbjorn Granlund * mpz/mul_i.h: Check sml's size (not the signed small_mult). * longlong.h (umul_ppmm) [alpha]: Define using __builtin_alpha_umulh when possible. * longlong.h (count_trailing_zeros): Force destination register mode. * gmpxx.h (struct __gmp_binary_rshift): Use floor rounding, not truncation. * gmpxx.h (__gmp_binary_and, __gmp_binary_ior, __gmp_binary_xor): Add variants with unsigned long int argument. * config.sub: Recog geode. * config.guess: Likewise. * acinclude.m4 (X86_PATTERN): Likewise. 2008-02-10 Torbjorn Granlund * mpn/x86/p6/aors_n.asm: Use Zdisp to work around GNU as bug. * mpn/x86/x86-defs.m4 (Zdisp): Add more instructions. 2008-02-08 Torbjorn Granlund * mpn/x86_64/aors_n.asm: New file. * mpn/x86_64/add_n.asm: Delete. * mpn/x86_64/sub_n.asm: Delete. 2008-02-07 Torbjorn Granlund * mpn/x86/k6/mmx/dive_1.asm: Fix typo in last change. 2007-12-10 Torbjorn Granlund * mpf/set_str.c (mpf_set_str): Write own code for converting the exponent, avoids strtol base < 36 limitation. 2007-10-28 Torbjorn Granlund * gmp-impl.h (mpn_dc_get_str_itch): New macro. (mpn_dc_get_str_powtab_alloc): New macro. (struct powers): Add field "shift". * mpn/generic/get_str.c: Compute powers without low zero limbs; all functions modified. Correct temporary allocation. Misc cleanups. * mpn/generic/set_str.c: Compute powers without low zero limbs; all functions modified. (mpn_dc_set_str): Remove impossible case, replace by an ASSERT. 2007-10-26 Torbjorn Granlund * mpn/generic/set_str.c: Remove default thresholds, not in gmp-impl.h. (mpn_dc_set_str): Insert ASSERT_ALWAYS in a presumably dead code arm. 2007-10-22 Torbjorn Granlund * gmp-impl.h (mpn_add_nc): Define as inline function, unless NATIVE. (mpn_sub_nc): Likewise. 2007-10-17 Torbjorn Granlund * tests/misc/t-printf.c: Fix a printf type clash. * tests/mpq/t-get_str.c: Likewise. * tests/mpz/t-import.c: Likewise. * acinclude.m4: Conditionally disable some tests when compiled by a C++ compiler. * gmp-impl.h (udiv_qrnnd_preinv3): Remove an unused variable. * mpn/generic/hgcd.c: Add some WANT_ASSERTs to shut up warnings. 2007-10-08 Torbjorn Granlund * mpn/powerpc64/elf.m4 (LEAL): Define as an alias for LEA. * mpn/powerpc32/darwin.m4 (LEAL): Likewise. * mpn/powerpc64/aix.m4: Likewise. * mpn/powerpc64/vmx/popcount.asm: Use LEAL. * mpn/powerpc64/darwin.m4 (LEAL): New name for LEA, since it is only usable for local symbols. (LEA): Replace with code for external references. * mpn/powerpc32/vmx/mod_34lsub1.asm: Use LEAL. 2007-10-07 Torbjorn Granlund * mpn/x86/dive_1.asm: Use LEA, remove explicit movl_eip_*. * mpn/x86/k6/mode1o.asm: Likewise. * mpn/x86/k6/mmx/dive_1.asm: Likewise. * mpn/x86/k7/dive_1.asm: Likewise. * mpn/x86/k7/mode1o.asm: Likewise. * mpn/x86/p6/dive_1.asm: Likewise. * mpn/x86/p6/mode1o.asm: Likewise. * mpn/x86/pentium4/sse2/dive_1.asm: Likewise. * mpn/x86/pentium4/sse2/mode1o.asm: Likewise. * mpn/x86/pentium4/sse2/popcount.asm: Likewise. * mpn/x86/p6/aors_n.asm: Table cycle counts. * mpn/x86/k7/mod_34lsub1.asm: Fix over-optimistic cycle count claims. * mpn/x86/x86-defs.m4 (DEF_OBJECT, END_OBJECT): New define's. * mpn/x86/darwin.m4 (LEA): Put also movl_eip_XX into EPILOGUE_cpu. Expect target register to have prepended %. * mpn/x86_64/add_n.asm: Use L() for labels. * mpn/x86_64/addlsh1_n.asm: Likewise. * mpn/x86_64/addmul_2.asm: Likewise. * mpn/x86_64/aorrlsh_n.asm: Likewise. * mpn/x86_64/aorsmul_1.asm: Likewise. * mpn/x86_64/com_n.asm: Likewise. * mpn/x86_64/copyd.asm: Likewise. * mpn/x86_64/copyi.asm: Likewise. * mpn/x86_64/diveby3.asm: Likewise. * mpn/x86_64/logops_n.asm: Likewise. * mpn/x86_64/lshsub_n.asm: Likewise. * mpn/x86_64/mul_1.asm: Likewise. * mpn/x86_64/mul_2.asm: Likewise. * mpn/x86_64/mul_basecase.asm: Likewise. * mpn/x86_64/popham.asm: Likewise. * mpn/x86_64/redc_1.asm: Likewise. * mpn/x86_64/rsh1add_n.asm: Likewise. * mpn/x86_64/rsh1sub_n.asm: Likewise. * mpn/x86_64/rshift.asm: Likewise. * mpn/x86_64/sub_n.asm: Likewise. * mpn/x86_64/sublsh1_n.asm Likewise. * mpn/x86_64/pentium4/aors_n.asm: Likewise. * mpn/x86_64/pentium4/lshift.asm: Likewise. * mpn/x86_64/pentium4/rshift.asm: Likewise. * mpn/x86_64/x86_64-defs.m4: New file, defining LEA, DEF_OBJECT, and END_OBJECT. * mpn/generic/mul.c: Put TMP_DECL as last decl. 2007-10-06 Torbjorn Granlund * mpn/x86/pentium4/sse2/popcount.asm: New file. 2007-09-26 Torbjorn Granlund * mpz/get_str.c: Cast a char index to int to shut up compilers. * mpn/generic/dc_div_qr.c: Pass dummy scratch argument to mpn_invert. * mpn/generic/dc_divappr_q.c: Likewise. * mpn/generic/mu_div_qr.c: Likewise. * mpn/generic/mu_divappr_q.c: Likewise. * mpn/generic/mu_div_q.c: Likewise. * mpn/generic/divexact.c: Likewise. * mpn/generic/invert.c: New file, placeholder for now. 2007-09-24 Torbjorn Granlund * mpn/generic/toom_interpolate_5pts.c: New file, contents from mpn/generic/mul_n.c * mpn/generic/mul_n.c (mpn_toom3_interpolate): Function removed. * mpn/generic/toom_interpolate_7pts.c: New file. * mpn/x86/k7/mmx/popham.asm: Table cycle counts. * mpn/x86/k6/README: Update URLs. * mpn/powerpc32/README: Update URL's, company names. * mpn/generic/get_d.c: Complete rewrite. * mpn/generic/mul_toom33.c: New file. * mpn/generic/mul_toom22.c: Make orthogonal with other toomXY files. * mpn/generic/mul_toom32.c: Likewise. * mpn/generic/mul_toom42.c: Likewise. * mpn/alpha/invert_limb.asm: Update cycle counts. Fix a comment typo. * mpf/get_str.c: Include stdlib.h, not stdio.h for NULL. * doc/gmp.texi: Fix a typo. * memory.c (__gmp_default_allocate, __gmp_default_reallocate): Cast size operands in error fprintf's. * longlong.h (sub_ddmmss) [powerpc 64]: Add more variants for constant args. * gmp-impl.h (udiv_qrnnd_preinv3): New define. * gmp-impl.h (ULONG_PARITY): Exclude masquerading __INTEL_COMPILER from ia64 asm. * gmp-h.in (mpn_neg_n): New function. 2007-09-18 Torbjorn Granlund * demos/pexpr.c (main): Add -v option. (enum op_t): New tag TIMING. (mpz_eval_expr): Execute TIMING. (fns): Add TIMING entry. * gmp-impl.h: Add decls and THRESHOLDs for new toom multiplication functions and division functions. 2007-09-10 Torbjorn Granlund * mpn/powerpc32/addlsh1_n.asm: Use L() for labels. * mpn/powerpc32/sublsh1_n.asm: Likewise. 2007-09-09 Torbjorn Granlund * mpn/x86/x86-defs.m4 (LEA): New define. * mpn/x86/darwin.m4: New file, for now just defining LEA. * configure.in: Pick up x86/darwin.m4. * mpn/x86/*: Use LEA for PIC references. * configure.in: For X86/32, treat core2 like pentium3. 2007-09-06 Torbjorn Granlund * tests/amd64check.c (calling_conventions_values): Put constants, dynamic values in this array (was in scalars). (calling_conventions_check): Corresponding changes. * tests/amd64call.asm: Rewrite to be PIC, smaller, using amd64check.c's array. 2007-09-04 Torbjorn Granlund * mpn/x86/pentium4/sse2/mul_basecase.asm: Misc cleanups. * mpn/x86/pentium4/sse2/sqr_basecase.asm: Likewise. * mpn/x86_64/mod_34lsub1.asm: Optimize loop, reduce code size. * tests/amd64call.asm: Remove bogus no-op moves. 2007-09-03 Torbjorn Granlund From Richard Guenther: * gmp-h.in (__GMP_EXTERN_INLINE): Declare conditionally on __GNUC_STDC_INLINE__. * tests/cxx/t-locale.cc: #include , for abort. * mpn/x86_64/core2/popcount.asm: New file. * mpn/x86_64/pentium4/popcount.asm: New file. * mpn/x86_64/addmul_2.asm: New file. * mpn/x86_64/mul_2.asm: New file. * mpn/x86_64/aorsmul_1.asm: Use 32-bit mov for zeroing registers (saves space). 2007-09-01 Torbjorn Granlund * configure.in: Handle athlon64, core2, and pentium4 separately for 64-bit ABI. * config.sub: Recog athlon64, core2, and opteron. * config.guess: Do two x86 variants, for 32-bit ABI and 64-bit ABI. Return "athlon64" and "core2", not x86_64. 2007-08-31 Torbjorn Granlund From Patrick Pelissier: * gmp-h.in: Don't refer to FILE from C++ unless we've seen FILE. 2007-08-30 Torbjorn Granlund * demos/isprime.c: Include string.h for strcmp. * demos/factorize.c (main): Declare to int. 2007-06-22 Torbjorn Granlund * mpn/x86_64/pentium4/lshift.asm: Minor tuning. * mpn/x86_64/pentium4/rshift.asm: Likewise. 2007-05-30 Torbjorn Granlund * mpn/powerpc64/mode64/aors_n.asm: Add _nc entry points. 2007-05-22 Torbjorn Granlund * tests/memory.c: Cast calls to new mem* calls to avoid unaligned ops. 2007-05-16 Torbjorn Granlund * tests/mpz/convert.c: Tweak operand sizes for best coverage. * tests/memory.c: Add red zones around allocations. 2007-05-15 Torbjorn Granlund * mpn/ia64/mul_1.asm: Make mul_1c entry point actually work. * mpn/generic/set_str.c (mpn_dc_set_str): Avoid calling mpn_add_n when ln == 0. * tests/mpz/convert.c (string_urandomb): New function. (main): Use it by enabling ifdef'ed out code. 2007-04-30 Torbjorn Granlund * mpn/x86_64/mul_basecase.asm: Complete rewrite. * mpn/x86_64/copyi.asm: Use short shift-by-one form. Misc cleanups. * mpn/x86_64/copyi.asm: Likewise. * mpn/x86_64/popham.asm: Likewise. * mpn/x86_64/aorsmul_1.asm: Cleanup formatting. 2007-04-25 Torbjorn Granlund * mpz/divexact.c: Handle undefined case of |N| < |D| to avoid segfaults. 2007-02-24 Torbjorn Granlund * doc/gmp.texi (Toom 3-Way Multiplication): Fix typo. (mpz_scan0, mpz_scan1): Fix typos. (Float Internals): Rewrite paragraph about struct types. 2007-02-12 Torbjorn Granlund * mpn/x86/pentium4/sse2/sqr_basecase.asm: Complete rewrite (except diagonal code). 2007-02-05 Torbjorn Granlund * mpn/generic/mul_fft.c (mpn_fft_fft): New name for mpn_fft_fft_sqr, old mpn_fft_fft removed. (mpn_mul_fft_internal): Call mpn_fft_fft separately for each operand. (mpn_fft_add_modF): Rewrite to avoid random branches. (mpn_fft_sub_modF): Likewise. * mpn/x86/pentium4/sse2/addmul_1.asm: Complete rewrite. * mpn/x86/pentium4/sse2/mul_1.asm: Complete rewrite. * mpn/x86/pentium4/sse2/mul_basecase.asm: Complete rewrite, based on new addmul and mul code. 2007-01-31 Torbjorn Granlund * mpn/generic/get_str.c (mpn_sb_get_str): Get loop count for frac development right. * mpn/powerpc32/vmx/mod_34lsub1.asm: New file. * mpn/powerpc32/aors_n.asm: New file, complete rewrite. * mpn/powerpc32/add_n.asm: Remove. * mpn/powerpc32/sub_n.asm: Remove. 2007-01-25 Torbjorn Granlund * mpn/x86_64/core2/aors_n.asm: Add _nc entry points, minor cleanups. * mpn/x86_64/core2/lshift.asm: Rewrite. * mpn/x86_64/core2/rshift.asm: Rewrite. * mpn/x86_64/pentium4/lshift.asm: Swap some loop insns for a small speedup. * mpn/x86_64/pentium4/rshift.asm: New file, based on lshift.asm. * mpn/x86_64/pentium4/gmp-mparam.h: New file. * mpn/x86_64/pentium4/aors_n.asm: Complete rewrite of add/subtract code. * mpn/x86_64/pentium4/add_n.asm: Remove. * mpn/x86_64/pentium4/sub_n.asm: Remove. 2007-01-20 Torbjorn Granlund * mpn/x86_64/lshift.asm: Add special case for cnt=1. 2007-01-19 Torbjorn Granlund * mpn/x86_64/aorsmul_1.asm: New file, written from scratch, finally at 3.0 c/l on K8 (addmul_1 was 3.3; submul_1 was 3.5). * mpn/x86_64/addmul_1.asm: Remove. * mpn/x86_64/submul_1.asm: Remove. 2006-12-29 Torbjorn Granlund * randmt.c (__gmp_randclear_mt): Initialize ALLOC field, like in __gmp_randinit_mt_noseed. (__gmp_randclear_mt, __gmp_randinit_mt_noseed): Make similar functions look similar. (__gmp_randclear_mt): Pass actually allocated size. * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Add mul_toom22.c, mul_toom32.c, mul_toom42.c. * configure.in: Recognize athlon64 and core2 as alternatives to x86_64. Provide special settings for core2. * configure.in (gmp_mpn_functions): Add mul_toom22, mul_toom32, mul_toom42. * mpn/generic/mul_toom22.c: New file. * mpn/generic/mul.c: Use mpn_mul_toom22. Trim cutoff points between the mpn_mul_toomN2 functions. Handle balanced operands at function entry. 2006-12-29 Marco Bodrato * mpn/generic/mul_n.c: Rewrite interpolation code. 2006-12-28 Torbjorn Granlund * mpn/generic/mul_toom32.c: New file. * mpn/generic/mul_toom42.c: New file. * mpn/generic/mul.c: Use mpn_mul_toom32 and mpn_mul_toom42 for unbalanced operands. 2006-12-17 Torbjorn Granlund * mpn/x86_64/aorrlsh_n.asm: New file. * mpn/x86_64/lshsub_n.asm: New file. * mpn/x86_64/core2/aors_n.asm: New file. * mpn/x86_64/core2/lshift.asm: New file. * mpn/x86_64/core2/rshift.asm: New file. * mpn/x86/p6/aors_n.asm: Replace K7 grabbing code with P6 specific code. * mpn/x86/p6/lshsub_n.asm: New file. 2006-11-23 Torbjorn Granlund * tune/speed.h (SPEED_ROUTINE_MPN_MUL_BASECASE): Allocate space for xp locally, s->xp might be insufficient. 2006-11-22 Torbjorn Granlund * randmt.c (__gmp_randinit_mt_noseed): Initialize ALLOC field of result param. 2006-11-06 Torbjorn Granlund * tune/set_strp.c: New file. 2006-11-04 Torbjorn Granlund * extract-dbl.c: Rewrite to handle nails better, and for general optimization. * mpz/bin_uiui.c: Simplify. * longlong.h (umul_ppmm) [mmix]: New. * tune/tuneup.c, tune/common.c, tune/speed.c, tune/speed.h, tune/set_strb.c, tune/set_strs.c: Add tuning and speed measurements of separate SET_STR_DC_THRESHOLD and SET_STR_PRECOMPUTE_THRESHOLD. Add tuning and speed measurement of mpn_addsub_n. 2006-10-31 Torbjorn Granlund * gmpxx.h: Remove ternary stuff, it is hardly an optimization and it writes to destination before reading all source operands. 2006-10-25 Torbjorn Granlund * mpn/generic/set_str.c: Complete rewrite. * mpn/generic/get_str.c: Likewise. * gmp-impl.h (struct powers, powers_t): New types. Restructure GET_STR_* and SET_STR_* thresholds. 2006-09-21 Torbjorn Granlund * mpn/generic/rootrem.c: Remove some redundant casts. 2006-07-12 Torbjorn Granlund * mpn/alpha/ev6/nails/addmul_2.asm: Make it run at claimed speed. * mpn/alpha/ev6/nails/addmul_4.asm: Likewise. * mpf/get_str.c: Avoid copying result when not needed. Misc cleanups. * tests/amd64call.asm: Use jmp instead of jmpq to placate Solaris. 2006-06-30 Torbjorn Granlund * configure.in (powerpc-*): Remove repeated path component. 2006-06-15 Torbjorn Granlund * configure.in: (ia64-*-linux*): Don't use -O3. 2006-06-14 Torbjorn Granlund * mpq/get_str.c: Fix upper base limit boundary in an ASSERT. * tests/refmpn.c (refmpn_sb_divrem_mn): Use ASSERT_CARRY for add-back. 2006-05-31 Torbjorn Granlund * tests/mpz/t-set_d.c (check_data): Add more data points. * mpz/set_d.c: Handle negative return values from __gmp_extract_double. 2006-05-17 Torbjorn Granlund * configure.in: Clear out gcc_cflags_cpu and gcc_cflags_arch for a fat build. 2006-05-16 Torbjorn Granlund * demos/primes.c (find_primes): Increase mpz_probab_prime_p cnt to 10. * mpn/generic/addsub_n.c: Fix criteria form when to call _nc functions. 2006-05-12 Torbjorn Granlund * config.guess: Recognize more ppc processor types. 2006-05-11 Torbjorn Granlund * tune/speed.c (usage): Update URL for gnuplot and quickplot. 2006-05-10 Torbjorn Granlund * configure.in (powerpc-*-*): Pass -maltivec to assembler for appropriate CPUs. 2006-05-08 Torbjorn Granlund * mpn/powerpc32/aix.m4 (LEA): Remove [RW] attribute. 2006-05-03 Torbjorn Granlund * mpn/powerpc64/vmx/popcount.asm: Conditionally zero extend n. 2006-04-27 Torbjorn Granlund * mpz/divexact.c: Call mpz_tdiv_q for large operands. * configure.in (powerpc-*-darwin): Remove -fast, it affects PIC. 2006-04-26 Torbjorn Granlund * config.guess: Try to recognize Ultrasparc T1 (as ultrasparct1). * config.sub: Handle ultrasparct1. 2006-04-25 Torbjorn Granlund * mpn/sparc64/gmp-mparam.h: Retune, without separation of GNUC and non-GNUC data. 2006-04-20 Torbjorn Granlund * tests/mpz/convert.c: Increase operands range. 2006-04-19 Torbjorn Granlund * configure.in: Support powerpc eABI. * mpn/powerpc32/eabi.m4: New file. * configure.in: Support powerpc *bsd. * mpn/powerpc64/elf.m4: New name for mpn/powerpc64/linux64.m4. * mpn/powerpc32/elf.m4: New name for mpn/powerpc32/linux.m4. * mpn/powerpc64/linux64.m4 (ASM_END): Quote TOC_ENTRY. 2006-04-18 Torbjorn Granlund * configure.in (gmp_mpn_functions_optional): Add lshiftc. (HAVE_NATIVE): Add lshiftc. * mpn/powerpc64/mode64/invert_limb.asm: Use LEA, not LDSYM. * mpn/powerpc64/mode64/mode1o.asm: Likewise. * mpn/powerpc64/mode64/dive_1.asm: Likewise. * mpn/powerpc64/linux64.m4 (TOC_ENTRY): Define to empty. * mpn/powerpc64/aix.m4 (TOC_ENTRY): Likewise. * mpn/powerpc32/aix.m4 (TOC_ENTRY): Likewise. * mpn/powerpc32/aix.m4 (EXTERN): New, copied form powerpc64/aix.m4. * mpn/powerpc32/mode1o.asm: Use EXTERN. * mpn/powerpc32/linux.m4 (EXTERN): Provide dummy definition. * mpn/powerpc32/darwin.m4 (EXTERN): Likewise. 2006-04-13 Torbjorn Granlund * mpn/generic/mul_fft.c: Use new thresholds mechanism if MUL_FFT_TABLE2 is defined. (mpn_lshiftc): New name for mpn_lshift_com (for consistency with some stuff already in 4.1.4. (mpn_fft_mul_2exp_modF): Reorganize initial operand reductions to avoid divisions. * tests/devel/try.c (choice_array): Add mpn_addsub_n[c]. 2006-04-11 Torbjorn Granlund * aclocal.m4: Regenerate with patched libtool. * mpn/asm-defs.m4 (ASM_END): Provide (empty) default. 2006-04-08 Torbjorn Granlund * configure.in (gmp_mpn_functions_optional): Add addsub. * gmpxx.h: Remove missed MPFR references. * gmp-impl.h (LIMBS_PER_DOUBLE): Adjust formula to not be pessimistic. * gmp-impl.h (TMP_*, WANT_TMP_DEBUG): Don't expect marker argument; define TMP_SALLOC and TMP_BALLOC. * mpn/minithres/gmp-mparam.h: New file. * tests/mpz/t-io_raw.c: Fix printf type/arg mismatches. * tests/mpz/t-export.c: Likewise. * tests/mpz/io.c: Likewise. * tests/t-constants.c: Likewise. * mpn/ia64/popcount.asm: Append "cond.dptk" to conditional branches to placate icc. * mpn/ia64/hamdist.asm: Likewise. * mpn/ia64/lorrshift.asm: Likewise. * mpn/ia64/dive_1.asm: Likewise. 2006-04-05 Torbjorn Granlund * tal-notreent.c (__gmp_tmp_mark): Add "struct" tag for tmp_marker. (__gmp_tmp_free): Likewise. * mpn/generic/mul_fft.c: Optimize many scalar divisions and mod operations into masks and shifts. (mpn_fft_mul_modF_K): Fix a spurious ASSERT_NOCARRY. 2006-03-26 Torbjorn Granlund * Version 4.2 released. * mpn/powerpc64/aix.m4 (LEA): Renamed from LDSYM. * mpn/powerpc64/darwin.m4: Likewise. * mpn/powerpc64/linux64.m4: Likewise. * mpn/powerpc64/vmx/popcount.asm: Use LEA, not LDSYM. 2006-03-23 Torbjorn Granlund * gmp-impl.h: (class gmp_allocated_string): Prefix strlen with std::. * gmpxx.h (__GMP_DEFINE_TERNARY_EXPR2): Remove for now. (struct __gmp_ternary_addmul2): Likewise. (struct __gmp_ternary_submul2): Likewise. * gmpxx.h: #include . (struct __gmp_alloc_cstring): Prefix strlen with std::. * mpn/x86/pentium/com_n.asm: Add TEXT and ALIGN. * mpn/x86/pentium/copyi.asm: Likewise. * mpn/x86/pentium/copyd.asm: Likewise. 2006-03-22 Torbjorn Granlund * gmp-h.in: Add a "using std::FILE" for C++. (_GMP_H_HAVE_FILE): Check also _ISO_STDIO_ISO_H. * gmpxx.h: Remove mpfr code. * tests/cxx: Likewise. * gmp-impl.h (FORCE_DOUBLE): Rename a tempvar to avoid a clash with GNU/Linux public include file. * configure.in (powerpc64, darwin): New optional, gcc_cflags_subtype. Grab powerpc32/darwin.m4 for ABI=mode32. * configure.in: Use host_cpu whenever just the cpu type is needed. 2006-03-08 Torbjorn Granlund * mpz/get_si.c: Fix a typo. * tests/mpq/t-get_d.c (check_random): Improve random generation for nails. 2006-02-28 Torbjorn Granlund * tests/mpq/t-get_d.c (check_random): New function. (main): Call check_random. * mpq/set_d.c: Make choices based on LIMBS_PER_DOUBLE, not BITS_PER_MP_LIMB. Make it work for LIMBS_PER_DOUBLE == 4. Use MPZ_REALLOC. * mpz/set_d.c: Make it work for LIMBS_PER_DOUBLE == 4. * extract-dbl.c: Make it work for LIMBS_PER_DOUBLE > 3. 2006-02-27 Torbjorn Granlund * mpz/cmp_d.c: Declare `i'. * mpz/cmpabs_d.c: Likewise. 2006-02-23 Torbjorn Granlund * mpn/powerpc32/vmx/copyd.asm: Set right VRSAVE bits. * mpn/powerpc32/vmx/copyi.asm: Likewise. 2006-02-22 Torbjorn Granlund * mpn/powerpc32/vmx/logops_n.asm: New file. * mpn/powerpc32/diveby3.asm: Rewrite. 2006-02-21 Torbjorn Granlund * mpn/powerpc32/vmx/copyi.asm: New file. * mpn/powerpc32/vmx/copyd.asm: New file. 2006-02-17 Torbjorn Granlund * mpn/alpha/ev6/nails/aors_n.asm (CYSH): Import proper setting from deleted mpn_sub_n. 2006-02-16 Torbjorn Granlund * mpn/alpha/ev6/addmul_1.asm: Correct slotting comments. 2006-02-15 Torbjorn Granlund * tests/devel/anymul_1.c: Copy error reporting code from addmul_N.c. * tests/devel/addmul_N.c: New file. * tests/devel/mul_N.c: New file. * mpn/alpha/default.m4 (PROLOGUE_cpu): Align functions at 16-byte boundary. * mpn/alpha/ev6/nails/aors_n.asm: New file. * mpn/alpha/ev6/nails/add_n.asm: Remove. * mpn/alpha/ev6/nails/sub_n.asm: Remove. * mpn/alpha/ev6/nails/addmul_1.asm: Rewrite. * mpn/alpha/ev6/nails/submul_1.asm: Likewise. * mpn/alpha/ev6/nails/mul_1.asm: Likewise. * mpn/alpha/ev6/nails/addmul_2.asm: Use L() for labels. * mpn/alpha/ev6/nails/addmul_3.asm: Use L() for labels. * mpn/alpha/ev6/nails/addmul_4.asm: Use L() for labels. 2006-02-13 Torbjorn Granlund * mpn/powerpc32/diveby3.asm: Trivially reorder loop insns to save 1 c/l. * mpn/x86_64/dive_1.asm: Use movabsq to support large model non-PIC. * mpn/x86_64/rsh1add_n.asm: Replace high register with rbx. * mpn/x86_64/rsh1sub_n.asm: Likewise. 2006-02-10 Torbjorn Granlund * mpn/powerpc64/sqr_diagonal.asm: Software pipeline. * mpn/powerpc64/vmx/popcount.asm: Add prefetching. 2006-02-07 Torbjorn Granlund * mpn/powerpc64/mode64/diveby3.asm: Rewrite. 2006-02-04 Torbjorn Granlund * mpn/powerpc64/vmx/popcount.asm: Remove mpn_hamdist partial code. Move compare for huge n so that it is always executed. 2006-02-03 Torbjorn Granlund * mpn/powerpc32/linux.m4 (LEA): Add support for PIC. * configure.in (powerpc): New optional, gcc_cflags_subtype. * mpn/x86_64/pentium4/add_n.asm: New file. * mpn/x86_64/pentium4/sub_n.asm: New file. * mpn/x86_64/pentium4/lshift.asm: New file. * mpn/powerpc64/linux64.m4 (PROLOGUE_cpu): Align function start to 16-multiple. * mpn/powerpc64/aix.m4: Likewise. * mpn/powerpc64/darwin.m4: Likewise. * mpn/powerpc64/copyi.asm: Align loop to 16-multiple. * mpn/powerpc64/copyd.asm: Likewise * configure.in (powerpc): Add vmx to relevant paths. * mpn/powerpc64/linux64.m4 (DEF_OBJECT): Accept 2nd argument, for alignment. * mpn/powerpc64/aix.m4: Likewise. * mpn/powerpc64/darwin.m4: Likewise. * mpn/powerpc32/linux.m4 (DEF_OBJECT, END_OBJECT): New macros, inherited from powerpc64 versions. * mpn/powerpc32/aix.m4: Likewise. * mpn/powerpc32/darwin.m4: Likewise. * mpn/powerpc64/vmx/popcount.asm: New file, for ppc32 and ppc64. * mpn/powerpc32/vmx/popcount.asm: New file, grabbing above file. 2006-01-22 Torbjorn Granlund * configure.in: Generalize OS-dependent patterns for powerpcs. 2006-01-20 Torbjorn Granlund * mpn/x86_64/popham.asm: Optimize. * config.guess: Recognize power4 and up under linux-gnu. * config.sub: Generalize power recognition code. * acinclude.m4 (POWERPC64_PATTERN): Add 64-bit powerpc processors. * configure.in: Recognize powerpc processors masquerading as power processors. 2006-01-19 Torbjorn Granlund * mpn/x86_64/logops_n.asm: Rewrite for more stable speed and smaller code. * mpn/x86_64/com_n.asm: Likewise. 2006-01-18 Torbjorn Granlund * mpn/x86_64/addlsh1_n.asm: Rewrite to use indexed addressing. * mpn/x86_64/sublsh1_n.asm: Likewise. 2006-01-17 Torbjorn Granlund * mpn/generic/diveby3.c: Use GMP standard parameter names. Nailify alternative code. Use restrict for params. * configure.in: Recognize andn_n as not needing nailification. * tests/mpq/t-equal.c (check_various): Disable a test that gives common factors for GMP_NUMB_BITS == 62. 2006-01-16 Torbjorn Granlund * mpn/generic/get_str.c (mpn_sb_get_str): Fix digit count computation, was inaccurate for nails. 2006-01-15 Torbjorn Granlund * mpn/x86_64/mode1o.asm: Remove unneeded carry register zeroing. 2006-01-08 Torbjorn Granlund * mpn/alpha/ev6/sqr_diagonal.asm: New file. 2006-01-06 Torbjorn Granlund * mpn/powerpc64/mode64/mod_34lsub1.asm: Tune to 1.5 c/l. * mpn/generic/mullow_n.c (MUL_BASECASE_ALLOC): New #define. (mpn_mullow_n): Use it. * mpn/powerpc64/mode64/dive_1.asm: Use EXTERN. * mpn/powerpc64/mode64/mode1o.asm: Likewise. * mpn/powerpc64/aix.m4 (EXTERN): Define to import symbol. (LDSYM): Remove [RW] attribute. * mpn/powerpc64/linux64.m4 (EXTERN): Dummy definition. * mpn/powerpc64/darwin.m4 (EXTERN): Likewise. 2006-01-05 Torbjorn Granlund * mpn/powerpc64/mode64/mode1o.asm: New file. * mpn/powerpc64/mode64/dive_1.asm: Use L() for labels. Invoke ASM_END. * mpn/powerpc64/mode64/invert_limb.asm: Invoke ASM_END. * mpn/powerpc64/linux64.m4: Move toc entry generation from direct at DEF_OBJECT to delayed via LDSYM, define ASM_END to output it. * mpn/powerpc64/aix.m4: Likewise. * mpn/powerpc64/darwin.m4: Define a dummy ASM_END. * mpn/powerpc64/mode64/addmul_1.asm: Add POWER5 timings. * mpn/powerpc64/mode64/mul_1.asm: Likewise. * mpn/powerpc64/mode64/submul_1.asm: Tweak to save 1.5 c/l for POWER5. 2006-01-04 Torbjorn Granlund * mpn/powerpc64/mode64/dive_1.asm: New file. * mpn/powerpc64/mode64/invert_limb.asm: Add missing ASM_START. * mpn/powerpc64/mode64/addmul_1.asm: Fix a comment typo. * mpn/x86_64/diveby3.asm: Rewrite. 2006-01-03 Torbjorn Granlund * configure.in: Update bugs reporting address. * mpn/powerpc64/mode64/diveby3.asm: Trim a cycle off of POWER4 timing. Misc cleanup. 2006-01-02 Torbjorn Granlund * mpn/powerpc64/linux64.m4 (CALL): New macro. * mpn/powerpc64/aix.m4: Likewise. * mpn/powerpc64/darwin.m4: Likewise, also define macro "DARWIN". 2005-12-28 Torbjorn Granlund * mpn/powerpc64/mode64/mod_34lsub1.asm: New file. 2005-12-26 Torbjorn Granlund * mpn/x86_64/mod_34lsub1.asm: New file. 2005-12-20 Torbjorn Granlund * mpn/x86_64/submul_1.asm: Save a push/pop by not using register r12. Use addq instead of leaq for pointer updates; schedule them. (These changes shaves one cycle of overhead and 0.25 c/l.) 2005-12-18 Torbjorn Granlund * mpf/ui_div.c: Implement workaround for GCC bug triggered on alpha. * mpf/set_q.c: Likewise. 2005-12-16 Torbjorn Granlund * mpn/generic/tdiv_qr.c: Remove statement with no effect. Rename dead variable to `dummy'. 2005-12-15 Torbjorn Granlund * demos/pexpr.c (setup_error_handler): Add a missing ";". 2005-11-27 Torbjorn Granlund * mpn/generic/mul.c: Crudely call mpn_mul_fft_full before checking for unbalanced operands. * mpn/generic/mul_fft.c: Remove many scalar divisions. (mpn_mul_fft_lcm): Simplify. (mpn_mul_fft_decompose): Rewrite to handle arbitrarily unbalanced operands. 2005-11-22 Torbjorn Granlund * configure.in: Properly recognize all 32-bit Solaris releases. 2005-11-10 Torbjorn Granlund * mpn/generic/mul_fft.c: Inline mpn_fft_mul_2exp_modF, mpn_fft_add_modF and mpn_fft_normalize. 2005-11-02 Torbjorn Granlund * tests/mpz/reuse.c: Increase operand size, decrease # of reps. * mpz/rootrem.c: Adapt to new mpn_rootrem. * mpz/root.c: Likewise. * tests/mpz/reuse.c: Test mpz_rootrem. With Paul Zimmermann: * mpn/generic/rootrem.c: Complete rewrite. 2005-10-31 Torbjorn Granlund * mpz/pprime_p.c (mpz_probab_prime_p): Considerably limit trial dividing. * mpz/perfpow.c (mpz_perfect_power_p): Use mpz_divisible_ui_p instead of mpz_tdiv_ui. * mpz/divegcd.c: Correct probability number for GCD == 1. * mpn/x86_64/mul_basecase.asm: Remove an obsolete comment. * mpn/x86: Add cycle counts for array of x86 processors. * mpn/x86/k7/mod_34lsub1.asm: Remove spurious mentions of ebp. * mpn/powerpc32: Add POWER5 timings. * mpn/powerpc32/README: Describe global reference variations. * mpn/ia64/divrem_2.asm: Add some comments. * mpn/ia64/divrem_1.asm: Reformat. * mpn/ia64/addmul_2.asm: Correct a comment on slotting. * mpn/ia64/logops_n.asm: Likewise. * mpn/ia64/addmul_1.asm: Remove a redundant preg mutex decl. * mpn/generic/dive_1.c: Whitespace cleanup. * mpn/alpha/ev6/nails/addmul_1.asm: Correct comments on slotting. * mpn/alpha/ev6/nails/addmul_2.asm: Likewise. * mpn/alpha/ev6/nails/addmul_4.asm: Likewise. * mpf/out_str.c: List some allocation improvement ideas. * doc/gmp.texi: Update many URLs and email addresses. * gmp-h.in (_GMP_H_HAVE_FILE): Check also _STDIO_H_INCLUDED. 2005-10-26 Torbjorn Granlund * tune/tuneup.c (tune_mullow): Update param.max_size for each threshold measurement. * configure.in (POWERPC64_PATTERN/*-*-darwin*): Set SPEED_CYCLECOUNTER_OBJ_mode64 and cyclecounter_size_mode64. (POWERPC64_PATTERN/*-*-linux*): Likewise. 2005-10-03 Torbjorn Granlund * demos/factorize.c (factor_using_division_2kp): Honor verbose flag. (factor_using_pollard_rho): Divide out new factor before it's clobbered. Don't stop factoring after a composite factor was found. 2005-09-17 Torbjorn Granlund * demos/pexpr.c (fns): Add factorial keywords. 2005-08-16 Torbjorn Granlund * tune/Makefile.am (EXTRA_DIST): Change "amd64" => "x86_64". * mpn/Makefile.am (TARG_DIST): Change "amd64" => "x86_64". 2005-08-15 Torbjorn Granlund * configure.in: Change "amd64" => "x86_64". 2005-06-13 Torbjorn Granlund * mpn/generic/pre_mod_1.c: Canonicalize variable names. * mpn/generic/divrem.c: Rate qxn test as UNLIKELY. * mpn/generic/gcdext.c (sanity_check_row): Invoke TMP_MARK. * tune/tuneup.c (tune_mullow): Fix all max_size fields. * gmp-impl.h (SQR_TOOM3_THRESHOLD_LIMIT): New #define. * tune/tuneup.c (tune_sqr): Use SQR_TOOM3_THRESHOLD_LIMIT. (sqr_toom3_threshold): Initialize from SQR_TOOM3_THRESHOLD_LIMIT. * mpn/generic/mul_n.c (mpn_sqr_n): Use SQR_TOOM3_THRESHOLD_LIMIT. * gmp-impl.h (mpn_nand_n, mpn_iorn_n, mpn_nior_n, mpn_xnor_n): Handle nails. 2005-06-13 Niels Möller * mpn/generic/gcdext.c (gcdext_schoenhage): Check for the (unlikely) case that one of the hgcd/euclid steps results in two remainders of one limb each. Then use gcdext_1. 2005-06-12 Torbjorn Granlund * mpn/alpha/ev6/sub_n.asm: Analogous changes as to add_n.asm last. 2005-06-11 Torbjorn Granlund * mpn/alpha/ev6/add_n.asm: Rewrite inner loop to load later. Add mpn_add_nc entry. * mpn/alpha/ev6/addmul_1.asm: Remove redundant initial loads. 2005-06-09 Torbjorn Granlund * mpn/ia64/dive_1.asm: Fix issues with HP-UX. 2005-06-08 Torbjorn Granlund * mpn/ia64/diveby3.asm: Update TODO list. * mpn/ia64/mode1o.asm: Fix comment typos. * mpn/ia64/dive_1.asm: New file. 2005-06-07 Torbjorn Granlund * mpn/ia64/mode1o.asm: Add prefetching. * mpn/generic/dive_1.c: Use variable h for upper umul_ppmm result. 2005-06-06 Torbjorn Granlund * mpn/ia64/hamdist.asm: Complete rewrite. * mpn/ia64/popcount.asm: Rewrite to use multi-pronged feed-in. * mpn/ia64/aors_n.asm: Rewrite feed-in code. * mpn/ia64/rsh1aors_n.asm: Likewise. * mpn/ia64/aorslsh1_n.asm: Likewise. * mpn/ia64/lorrshift.asm: Likewise. 2005-06-04 Torbjorn Granlund * tests/devel/try.c (choice_array): Exclude mpn_preinv_mod_1 unless USE_PREINV_MOD_1. (choice_array): Exclude mpn_sqr_basecase if SQR_KARATSUBA_THRESHOLD is zero. 2005-06-03 Torbjorn Granlund * mpn/alpha/ev6/addmul_1.asm: Prefix all labels with "$". * mpn/alpha/ev6/mul_1.asm: Likewise. 2005-06-02 Torbjorn Granlund * tests/refmpn.c (refmpn_divmod_1c_workaround): Implement workaround to gcc 3.4.x bug triggered on powerpc64 with 32-bit ABI. 2005-06-01 Torbjorn Granlund * tests/devel/try.c (main): Fix a typo. 2005-05-31 Torbjorn Granlund * mpn/alpha/ev6/addmul_1.asm: Rewrite for L1 cache, add prefetch. 2005-05-30 Torbjorn Granlund * tests/misc.c (tests_rand_start): Mask random seed to 32 bits. 2005-05-29 Torbjorn Granlund * mpn/powerpc64/mode32/mul_1.asm: Handle BROKEN_LONGLONG_PARAM. * mpn/powerpc64/mode32/addmul_1.asm: Likewise. * mpn/powerpc64/mode32/submul_1.asm: Likewise. * mpn/powerpc32/mode1o.asm: Rewrite to actually work. * mpn/powerpc32/aix.m4 (LEA): New macro. (ASM_END): New macro. * mpn/powerpc32/linux.m4: New file. * mpn/powerpc32/darwin.m4: New file. * configure.in: Use linux.m4 and darwin.m4. (powerpc64-linux-gnu): Add support for mode32. 2005-05-25 Torbjorn Granlund * mpn/generic/mullow_n.c: Remove FIXME mentioning fixed flaw. * tests/mpz/t-cmp_d.c (check_one): Fix printf fmt string typo. * demos/isprime.c: #include stdlib.h. * tests/rand/t-urbui.c: Likewise. * tests/rand/t-urmui.c: Likewise. * tests/mpz/t-popcount.c (check_random): Remove spurious printf arg. * mpn/ia64/lorrshift.asm: Cleanup code layout. * mpn/ia64/popcount.asm: Likewise. 2005-05-24 Torbjorn Granlund * tests/devel/try.c (param_init) [TYPE_GET_STR]: Set retval field. (compare): Handle SIZE_GET_STR as SIZE_RETVAL. * tests/refmpn.c (refmpn_get_str): Rewrite to make it work. 2005-05-23 Torbjorn Granlund * mpn/amd64/add_n.asm: Add mpn_add_nc entry point. * mpn/amd64/sub_n.asm: Add mpn_sub_nc entry point. * longlong.h (many places): Remove lvalue casts. * gmp-impl.h (MPF_SIGNIFICANT_DIGITS): Cast prec to avoid overflow for > 4G digits. * mpn/alpha/ev6/add_n.asm: Prefetch using ldl. * mpn/alpha/ev6/sub_n.asm: Likewise. * mpn/alpha/ev6/slot.pl (optable): Recognize negq and ldl. * mpn/ia64/aors_n.asm: Prefetch using lfetch. * mpn/ia64/lorrshift.asm: Likewise. * mpn/ia64/popcount.asm: Likewise. * mpn/ia64/diveby3.asm: Likewise. 2005-05-22 Torbjorn Granlund * mpn/alpha/ev67/popcount.asm: Prefetch. * mpn/alpha/ev67/hamdist.asm: Prefetch. * longlong.h (add_ssaaaa) [x86]: Remove lvalue casts. (sub_ddmmss) [x86]: Likewise. * tests/devel/try.c (param_init) [TYPE_MPZ_JACOBI]: Add DATA_SRC1_ODD. (param_init) [TYPE_MPZ_KRONECKER]: Clear inherited DATA_SRC1_ODD. (param_init) [TYPE_DIVEXACT_1]: Use symbolic name DIVISOR_LIMB. 2005-05-21 Torbjorn Granlund * tests/devel/try.c (param_init) [TYPE_MPZ_JACOBI]: Initialize divisor field according to UDIV_NEEDS_NORMALIZATION. * mpz/mul_i.h: Remove left-over TMP_XXXX marker arguments. 2005-05-20 Torbjorn Granlund * mpn/x86/pentium4/sse2/addmul_1.asm (mpn_addmul_1c): Put carry in proper register. * mpn/generic/sqr_basecase.c (mpn_sqr_basecase, addmul_2 version): Avoid accesses out-of-bound in MPN_SQR_DIAGONAL applicate code. 2005-05-19 Torbjorn Granlund * mpn/alpha/diveby3.asm: Make it actually work. * gmp-impl.h (MULLOW_BASECASE_THRESHOLD_LIMIT): New #define. * mpn/generic/mullow_n.c: Use fixed stack allocation for the smallest operands; use TMP_S* allocation for medium operands. * gmp-impl.h: Remove nested TUNE_PROGRAM_BUILD test. 2005-05-18 Torbjorn Granlund * mpn/generic/mul_n.c: Make squaring and multiplication code more similar. Use TMP_S* functions. * gmp-impl.h (TMP_DECL, TMP_MARK, TMP_FREE): Get rid of argument. (TMP_SALLOC): New macro for "small" allocations. (TMP_BALLOC): New macro for "big" allocations. (TMP_SDECL, TMP_SMARK, TMP_SFREE): New macros for functions that use just TMP_SALLOC. (WANT_TMP_ALLOCA): Make default functions choose alloca or reentrant functions, depending on size. * *.c: Remove TMP_XXXX marker arguments. * acinclude.m4 (WANT_TMP): Want tal-reent.lo also for alloca case. 2005-05-16 Torbjorn Granlund * mpn/ia64/gmp-mparam.h: Further extend FFT tables. 2005-05-15 Torbjorn Granlund * gmp-impl.h (udiv_qrnnd_preinv2): Pull an add into add_ssaaaa. (udiv_qrnnd_preinv2gen): Likewise. 2005-05-14 Torbjorn Granlund * longlong.h (add_ssaaaa) [x86_64]: Restrict allowed immediate operands. * (sub_ddmmss) [x86_64]: Likewise. 2005-05-02 Torbjorn Granlund * acinclude.m4 (GMP_HPC_HPPA_2_0): Make gmp_tmp_v1 sed pattern handle version numbers like B.11.X.32509-32512.GP. * mpn/m68k/aors_n.asm: Correct MULFUNC_PROLOGUE. * mpn/powerpc64/mode64/aors_n.asm: Add a MULFUNC_PROLOGUE. * mpf/inp_str.c: Use plain int for mpf_set_str return value (works around gcc 4 bug). * acinclude.m4 (GMP_ASM_POWERPC_PIC_ALWAYS): Handle darwin's assembly syntax. (long long reliability test 1): New GMP_PROG_CC_WORKS_PART test. (long long reliability test 2): New GMP_PROG_CC_WORKS_PART test. * configure.in: Add mode64 support for darwin. Use darwin.m4. Add cflags_opt flags for mode32 darwin. * mpn/powerpc64: Use L() for all asm files. * mpn/asm-defs.m4 (PIC_ALWAYS): Define PIC just iff PIC_ALWAYS = "yes". * mpn/powerpc64/darwin.m4: New file. * mpn/powerpc64/linux64.m4: Remove TOCREF, add LDSYM. Rework DEF_OBJECT to need just one argument. * mpn/powerpc64/aix.m4: Likewise. * mpn/powerpc64/mode64/invert_limb.asm: Load approx_tab address with LDSYM. Optimize somewhat. Remove 2nd DEF_OBJECT operand. 2005-05-01 Torbjorn Granlund * mpn/generic/popham.c: Compute final summation differently for 64-bit. * tests/mpz/t-popcount.c (check_random): New function. (main): Call it. 2005-04-28 Torbjorn Granlund * mpn/amd64/add_n.asm: Use r9 instead of rbx to save push/pop. * mpn/amd64/sub_n.asm: Likewise. 2005-04-09 Torbjorn Granlund * mpn/powerpc64/copyi.asm: If HAVE_ABI_mode32, ignore upper 32 bits of mp_size_t argument. * mpn/powerpc64/copyd.asm: Likewise. * mpn/powerpc64/sqr_diagonal.asm: Likewise. * mpn/powerpc64/lshift.asm: Likewise. * mpn/powerpc64/rshift.asm: Likewise. * mpn/powerpc64/logops_n.asm: Likewise. * mpn/powerpc64/com_n.asm: Likewise. 2005-04-08 Torbjorn Granlund * mpn/generic/rootrem.c: Allocate PP_ALLOC limbs also for qp. 2005-04-07 Torbjorn Granlund * mpn/powerpc32/add_n.asm: Add nc entry point. * mpn/powerpc32/sub_n.asm: Likewise. * mpn/amd64/*.asm: Add Prescott/Nocona cycle/limb numbers. * mpn/alpha/add_n.asm: Add correct cycle/limb numbers. * mpn/alpha/sub_n.asm: Likewise. * mpn/alpha/ev5/add_n.asm: Likewise. * mpn/alpha/ev5/sub_n.asm: Likewise. 2005-03-31 Torbjorn Granlund * mpn/x86/k7/gmp-mparam.h: Fix typo in last change. 2005-03-19 Torbjorn Granlund * mpn/amd64/gmp-mparam.h: Update. * mpn/alpha/gmp-mparam.h: Update. * mpn/alpha/ev5/gmp-mparam.h: Update. * mpn/alpha/ev6/gmp-mparam.h: Update. * mpn/ia64/gmp-mparam.h: Update. * mpn/x86/p6/mmx/gmp-mparam.h: Update. * mpn/x86/pentium4/sse2/gmp-mparam.h: Update. * mpn/x86/k7/gmp-mparam.h: Update. * tests/mpz/t-gcd.c (main): Honor command line reps argument. * tune/speed.h (SPEED_ROUTINE_MPN_GCD_CALL): Simplify and correct code for generating test operands. 2005-03-17 Niels Möller * mpn/generic/hgcd.c (qstack_adjust): New argument d, saying how much to adjust the top quotient. (hgcd_adjust): The quotient can be off by either 1 or 2. 2005-03-16 Torbjorn Granlund * tests/mpz/t-gcd.c (MAX_SCHOENHAGE_THRESHOLD): Set to largest of gcd,gcdext thresholds. 2005-03-15 Niels Möller * mpn/generic/gcdext.c (gcdext_schoenhage): When calling gcdext_lehmer, reuse all temporary limb storage, including the storage used for the qstack. 2005-03-09 Torbjorn Granlund * mpn/amd64/logops_n.asm: Add MULFUNC_PROLOGUE. 2005-03-05 Torbjorn Granlund * mpn/amd64/gmp-mparam.h: Extend MUL_FFT_TABLE and SQR_FFT_TABLE. * mpn/ia64/gmp-mparam.h: Likewise. 2005-02-17 Torbjorn Granlund * mpn/ia64/divrem_1.asm: Add preinv entry point. 2005-01-13 Torbjorn Granlund * gmp-impl.h (MPN_SIZEINBASE): Count bits in type size_t. (MPN_SIZEINBASE_16): Likewise. 2004-12-17 Torbjorn Granlund * tune/speed.c (run_gnuplot): Use lines, not linespoints. Output a reset gnuplot command initially. 2004-12-04 Torbjorn Granlund * mpn/generic/random2.c (gmp_rrandomb): Rework again. * mpz/rrandomb.c (gmp_rrandomb): Likewise. * mpn/amd64/redc_1.asm: Call via PLT when PIC. 2004-11-29 Torbjorn Granlund * mpn/amd64/divrem_1.asm: Add preinv entry point. * mpn/amd64/gmp-mparam.h: Set USE_PREINV_DIVREM_1 to 1. 2004-11-24 Torbjorn Granlund * mpn/alpha/diveby3.asm: Use correct prefetch instruction. 2004-11-19 Torbjorn Granlund * mpn/alpha/diveby3.asm: Add ",gp" glue in PROLOGUE. Add r31 dummy operand to `br' instruction. 2004-11-17 Torbjorn Granlund * mpn/powerpc64/mode64/addmul_1.asm: Rewrite. * mpn/powerpc64/mode64/mul_1.asm: Rewrite. * configure.in: Invoke AC_C_RESTRICT. 2004-11-16 Torbjorn Granlund * mpn/alpha/diveby3.asm: New file. 2004-11-13 Torbjorn Granlund * mpn/amd64/popham.asm: New file. 2004-11-12 Torbjorn Granlund * mpn/amd64/add_n.asm: Correct cycle count. * mpn/amd64/sub_n.asm: Likewise. * mpn/amd64/dive_1.asm: Speed divisors with many factors of 2. 2004-11-11 Torbjorn Granlund * mpn/amd64/dive_1.asm: New file. 2004-11-10 Torbjorn Granlund * mpn/generic/popham.c: Add comment. 2004-11-09 Torbjorn Granlund * mpn/amd64/com_n.asm: New file. * mpn/amd64/logops_n.asm: New file. 2004-11-08 Torbjorn Granlund * mpn/powerpc64/com_n.asm: New file. 2004-11-05 Torbjorn Granlund * mpn/amd64/diveby3.asm: New file. * config.guess: Strip any PPC string in /proc/cpuinfo. Recognize 970 in that code. 2004-11-01 Torbjorn Granlund * mpn/amd64/mul_basecase.asm: New file. * mpn/amd64/redc_1.asm: New file. 2004-10-25 Torbjorn Granlund * mpn/powerpc64/mode64/addlsh1_n.asm: Correct cycle counts. * mpn/powerpc64/README: Update POWER5/PPC970 pipeline information. * mpn/generic/mul_basecase.c (MAX_LEFT): Add comment. * doc/gmp.texi: Consistently use "x86" denotation. (Assembler SIMD Instructions): Mention SSE2 usage. * demos/pexpr.c (main): Handle "negative" base in mpz_sizeinbase call. 2004-10-18 Torbjorn Granlund * mpn/powerpc64/mode64/submul_1.asm: Shave 2 cycles/limb with new carry inversion trick. 2004-10-16 Torbjorn Granlund * configure.in: Support icc under x86. (ia64-*-linux*): Pass -no-gcc to icc. 2004-10-15 Torbjorn Granlund * longlong.h (ia64 umul_ppmm): Add version for icc. * configure.in: Support icc under ia64-*-linux*. * acinclude.m4: New "compiler works" test for icc 8.1 bug. (GMP_PROG_CC_IS_GNU): Don't let Intel's icc fool us it is GCC. 2004-10-14 Torbjorn Granlund * mpn/generic/gcdext.c: Add a few missing TMP_MARK. 2004-10-14 Torbjorn Granlund * acinclude.m4 (GMP_ASM_W32): Try also "data4". * mpn/ia64/logops_n.asm: Don't use naked "br", rejected by Intel assembler. * mpn/ia64/aors_n.asm: Likewise. * mpn/ia64/divrem_2.asm: Add ".prologue". * mpn/ia64/hamdist.asm: Put alloc first in bundle, enforced by the Intel assembler. * longlong.h: Exclude masquerading __INTEL_COMPILER from ia64 asm. * gmp-impl.h: Likewise. 2004-10-12 Torbjorn Granlund * mpn/ia64/mul_2.asm: Rewrite function entry code, write new code for n=2. * mpn/ia64/addmul_2.asm: Likewise. * tests/devel/try.c: Handle mpn_mul_2 like mpn_addmul_2. * tune/speed.c (routine): Make R parameter optional for mpn_mul_2. 2004-10-11 Torbjorn Granlund * mpn/sparc64/addmul_1.asm: Update a comment. * tests/devel/aors_n.c: #include tests.h. * tests/devel/anymul_1.c: Likewise. * tests/devel/shift.c: Likewise. * tests/devel/copy.c: Likewise. * tests/devel/aors_n.c: Handle also mpn_addlsh1_n, mpn_sublsh1_n, mpn_rsh1add_n, and mpn_rsh1sub_n. * mpn/ia64/submul_1.asm: Add TODO item. * mpn/ia64/aors_n.asm: Rewrite function entry code (again). * mpn/ia64/aorslsh1_n.asm: Likewise. * mpn/ia64/logops_n.asm: Likewise. * mpn/ia64/rsh1aors_n.asm: Tune function entry and feed-in code. * mpn/ia64/lorrshift.asm: Likewise. Remove several spurious loads. * tests/devel/Makefile.am (EXTRA_PROGRAMS): Updates for yesterday's file removals and additions. 2004-10-10 Torbjorn Granlund * mpn/ia64/copyi.asm: Tune function entry code. * mpn/ia64/copyd.asm: Likewise. * mpn/ia64/logops_n.asm: Tune function entry and feed-in code for speed and size. * mpn/ia64/aors_n.asm: Likewise. * mpn/powerpc64/logops_n.asm: Correct cycles counts. * mpn/powerpc64/mode64/aors_n.asm: Likewise. * tests/devel/copy.c: Handle both MPN_COPY_INCR and MPN_COPY_DECR. * tests/devel/logops_n.c: New file, handle all logical operations. * tests/devel/anymul_1.c: New file, handle mpn_mul_1, mpn_addmul_1, and mpn_submul_1 * tests/devel/mul_1.c: Remove. * tests/devel/addmul_1.c: Remove. * tests/devel/submul_1.c: Remove. * tests/devel/shift.c: New file, handle mpn_lshift and mpn_rshift. * tests/devel/lshift.c: Remove. * tests/devel/rshift.c: Remove. * tests/devel/aors_n.c: New file, handle mpn_add_n and mpn_sub_n. * tests/devel/add_n.c: Remove. * tests/devel/sub_n.c: Remove. 2004-10-09 Torbjorn Granlund * mpn/powerpc64/linux64.m4: Define DEF_OBJECT, END_OBJECT, and TOCREF. * mpn/powerpc64/aix.m4: Likewise. * mpn/powerpc64/mode64/invert_limb.asm: Use DEF_OBJECT, END_OBJECT, and TOCREF for approx_tab. * mpn/amd64/mul_1.asm: Add mpn_mul_1c entry point. 2004-10-08 Torbjorn Granlund * mpn/powerpc64/copyi.asm: New file. * mpn/powerpc64/copyd.asm: New file. * gmp-h.in: Remove PPC MPN_COPY variants. * gmp-impl.h: Likewise. * mpn/powerpc64/logops_n.asm: New file. * mpn/powerpc64/mode64/invert_limb.asm: New file. 2004-10-07 Torbjorn Granlund * mpn/powerpc64/mode64/aors_n.asm: New file, optimized for POWER4 and its derivatives. * mpn/powerpc64/mode64/add_n.asm: Delete. * mpn/powerpc64/mode64/sub_n.asm: Delete. * configfsf.guess: Patch HP-UX code to accommodate HP compiler's new inability to read from stdin. * mpn/powerpc64/mode64/addsub_n.asm: Remove accidentally added file. 2004-10-02 Torbjorn Granlund * mpn/amd64/README: Update for new developments, fix typos. * mpn/amd64/mul_1.asm: Tweak addressing (3.25 => 3.0 cycles/limb). * mpn/amd64/addmul_1.asm: Remove unreachable code block. 2004-09-30 Torbjorn Granlund * mpn/amd64/addmul_1.asm: Rewrite, now 3.25 cycles/limb. * mpn/ia64/addmul_1.asm: Slightly enhance cross-jumping for code density. * mpn/ia64/mul_1.asm: Analogous changes. 2004-09-29 Torbjorn Granlund * gmp-impl.h (x86 ULONG_PARITY): Work around GCC change of "q" register flag. 2004-09-28 Torbjorn Granlund * mpn/ia64/divrem_1.asm: Add cycle counts to loop. * mpn/ia64/divrem_2.asm: New file. 2004-09-28 Paul Zimmermann * mpn/generic/mul_fft.c (mpn_mul_fft): Fix a bug in the choice of the recursive fft parameters. 2004-09-20 Torbjorn Granlund * tests/misc.c (tests_rand_start): Default to strtoul for re-seeding. * tests/mpz/t-mul.c (ref_mpn_mul): Fudge tmp allocation for toom3. 2004-09-19 Torbjorn Granlund * tests/misc.c (tests_rand_start): Shift tv_usec for better seeding. 2004-09-18 Torbjorn Granlund * tests/misc.c (tests_rand_start): Invoke fflush after printing seed. * tests/mpz/t-mul.c (main): Check environment for GMP_CHECK_FFT, run extra FFT tests if set. (ref_mpn_mul): Use library code for kara and toom, but skewded so that we never use the same algorithm that we're testing. (mul_kara): Delete. (debug_mp): Print just one line of large numbers. (ref_mpn_mul): Rework usage of tp temporary space. 2004-09-15 Torbjorn Granlund * mpn/ia64/mul_2.asm: For HAVE_ABI_32, convert vp. * mpn/ia64/addmul_2.asm: Likewise. 2004-09-13 Torbjorn Granlund * mpn/ia64/invert_limb.asm: Rewrite. * mpn/ia64/logops_n.asm: Insert some more stops. 2004-09-12 Torbjorn Granlund * mpn/ia64/gmp-mparam.h: Update. * mpn/amd64/gmp-mparam.h: Update. * mpn/ia64/sqr_diagonal.asm: Shave off a few cycles. 2004-09-11 Torbjorn Granlund * mpn/ia64/mul_2.asm: New file. * mpn/ia64/addmul_2.asm: New file. * mpn/ia64/addmul_1.asm: Tune a cycle from prologue. * mpn/ia64/lorrshift.asm: Insert stops after several branches. * mpn/ia64/aorslsh1_n.asm: Likewise. * mpn/ia64/rsh1aors_n.asm: Likewise. * mpn/generic/sqr_basecase.c: In variant for HAVE_NATIVE_mpn_addmul_2, accumulate carry also for when HAVE_NATIVE_mpn_addlsh1_n. 2004-09-07 Torbjorn Granlund * mpn/ia64/submul_1.asm: Rewrite. * mpn/ia64/addmul_1.asm: Format to placate HP-UX assembler. * mpn/ia64/mul_1.asm: Likewise. 2004-09-02 Torbjorn Granlund * mpn/ia64/mul_1.asm: Optimize feed-in code. * mpn/ia64/addmul_1.asm: Rewrite feed-in code. 2004-08-29 Torbjorn Granlund * tests/mpz/t-sizeinbase.c: Disable mpz_fake_bits and check_sample. 2004-07-16 Torbjorn Granlund * mpn/ia64/addmul_1.asm: Format to placate HP-UX assembler. 2004-06-17 Kevin Ryde * doc/gmp.texi: Use @. when sentence ends with a capital, for good spacing in tex. (Language Bindings): Add gmp-d, reported by Ben Hinkle. Update SWI Prolog URL, reported by Jan Wielemaker. 2004-06-09 Torbjorn Granlund * configure.in: Handle --enable-fat. Use that to enable x86 fat builds, remove magic meaning of i386-*-*. 2004-06-03 Kevin Ryde * gmp-impl.h (memset): Use a local char* pointer, in case parameter is something else (eg. tune/common.c). Reported by Emmanuel Thomé. 2004-06-01 Kevin Ryde * config.guess (i?86-*-*): Avoid "Illegal instruction" message which goes to stdout on 80386 freebsd4.9. 2004-05-23 Niels Möller * mpn/generic/gcdext.c (gcdext_1_u): New function. (mpn_gcdext): Use it. 2004-05-23 Torbjorn Granlund * mpn/generic/gcdext.c (gcdext_1_odd): Use masking to avoid jumps. 2004-05-22 Torbjorn Granlund * mpn/x86/pentium4/sse2/addmul_1.asm: Add Prescott cycle numbers. * mpn/amd64/divrem_1.asm: Shave a cycle from fraction development code. * mpn/powerpc32/lshift.asm: Add more cycle numbers. * mpn/powerpc32/rshift.asm: Likewise. * mpn/ia64/addmul_1.asm: Reformat. 2004-05-21 Torbjorn Granlund * gmp-impl.h (mpn_mullow_n, mpn_mullow_basecase): Declare. * tune/Makefile.am: Compile gcdext.c. * gmp-impl.h (GET_STR_THRESHOLD_LIMIT): Lower outrageous value to 150. (GCDEXT_SCHOENHAGE_THRESHOLD): Set reasonable default. Override when TUNE_PROGRAM_BUILD. (GCDEXT_THRESHOLD): Remove. * tune/tuneup.c (gcdext_schoenhage_threshold): New variable. (gcdext_threshold): Remove variable. (tune_gcd_schoenhage): Lower step_factor to 0.1. (tune_gcdext_schoenhage): New function, based on tune_gcd_schoenhage. (tune_gcdext): Remove function. (all): Corresponding changes. 2004-05-21 Niels Möller * mpn/generic/gcdext.c: Complete rewrite. Uses fast Lehmer code for small operands, and Schoenhage code for large operands. * tune/speed.h (SPEED_ROUTINE_MPN_GCD_CALL): Ensure first operand is not smaller than 2nd operand. 2004-05-17 Kevin Ryde * gmp-h.in (mpz_get_ui): Use #if instead of plain if, and for nails use ?: same as normal case, to avoid warnings from Borland C++ 6.0. Reported by delta trinity. 2004-05-15 Kevin Ryde * tune/time.c (getrusage_backwards_p): New function (speed_time_init): Use it to exclude broken netbsd1.4.1 getrusage. * configure.in (m68*-*-netbsd1.4*): Remove code pretending getrusage doesn't exist. * tune/README (NetBSD 1.4.1 m68k): Update notes. * configure.in (mips*-*-* ABI=n32): Remove gcc_n32_ldflags and cc_n32_ldflags, libtool knows to put the linker in n32 mode. 2004-05-15 Torbjorn Granlund * config.guess (powerpc*-*-*): Add more processor types to mfpvr code. * configure.in: Generalize powerpc subtype matching code. * mpz/fac_ui.c: Misc cleanups, spelling corrections. 2004-05-14 Kevin Ryde * mpf/sub.c: When one operand cancels high limbs of the other, strip high zeros on the balance before truncating to destination precision. Truncating first loses accuracy and can lead to a result 0 despite operands being not equal. Reported by John Abbott. Also, ensure exponent is zero when result is zero, for instance if operands are exactly equal. * tests/mpf/t-sub.c (check_data): New function, exercising these. 2004-05-12 Kevin Ryde * configure.in (AC_PROG_RANLIB): New macro, supposedly required by automake, though it doesn't complain. * demos/expr/Makefile.am (ARFLAGS): Add a default setting, to workaround an automake bug. 2004-05-10 Kevin Ryde * */Makefile.in, install-sh, aclocal.m4: Update to automake 1.8.4. * doc/gmp.texi (Demonstration Programs): Add a remark about expression evaluation in the main gmp library. * demos/expr/exprfa.c (mpf_expr_a): Correction to mpX_init, use mpf_init2 to follow requested precision. * demos/expr/exprza.c, demos/expr/exprqa.c: Use wrappers for mpX_init, to make parameters match. * demos/expr/run-expr.c: Don't use getopt, to avoid needing configury for optarg declaration. Remove TRY macro, rename foo and bar to var_a and var_b, for clarity. * demos/expr/expr-impl.h: Don't use expr-config.h. * configure.in (demos/expr/expr-config.h): Remove. * demos/expr/expr-config.in: Remove file. 2004-05-08 Kevin Ryde * doc/configuration (Configure): Update for current automake not copying acinclude.m4 into aclocal.m4. * configure.in, Makefile.am, doc/gmp.texi, doc/configuration, tests/cxx/Makefile.am, demos/expr/Makefile.am, demos/expr/README, demos/expr/expr.c, demos/expr/expr.h, demos/expr/expr-config-h.in, demos/expr/expr-impl.h, demos/expr/run-expr.c, demos/expr/t-expr.c: MPFR now published separately, remove various bits. * mpfr/*, tests/cxx/t-headfr.cc, demos/expr/exprfr.c, demos/expr/exprfra.c: Remove. 2004-05-07 Kevin Ryde * tests/cxx/Makefile.am (TESTS_ENVIRONMENT): Amend c++ shared library path hack, on k62-unknown-dragonfly1.0 /usr/bin/make runs its commands "set -e", so we need an "|| true" in case there's nothing to copy (for instance in a static build). 2004-05-06 Kevin Ryde * mpn/alpha/mode1o.c: Remove, in favour of ... * mpn/alpha/mode1o.asm: New file. * mpn/alpha/alpha-defs.m4 (bwx_available_p): New macro. * tune/amd64.asm: Save rbx in r10 rather than on the stack. * configure.in (x86_64-*-*): Try also "-march=k8 -mno-sse2", in case we're in ABI=32 on an old OS not supporting xmm regs. (GMP_GCC_PENTIUM4_SSE2, GMP_OS_X86_XMM): Run these tests under -march=k8 too, and not under ABI=64. * doc/gmp.texi (Converting Integers): For mpz_get_d, note truncation and overflows. For mpz_get_d_2exp note truncation, note result if OP==0, and cross reference libc frexp. (Rational Conversions): For mpq_get_d, note truncation and overflows. (Converting Floats): For mpf_get_d, note truncation and overflows. For mpf_get_d_2exp, note truncation, note result if OP==0. (Assembler Code Organisation): Note nails subdirectories. Clarification of get_d_2exp OP==0 reported by Sylvain Pion. 2004-05-05 Torbjorn Granlund * mpn/generic/mullow_n.c, mpn/generic/mullow_basecase.c: New files (mainly by Niels Möller). * configure.in, mpn/Makefile.am: Add them. * gmp-impl.h (MULLOW_BASECASE_THRESHOLD, MULLOW_DC_THRESHOLD, MULLOW_MUL_N_THRESHOLD): Override for TUNE_PROGRAM_BUILD. * tune/Makefile.am: Compile mullow_n.c. * tune/common.c (speed_mpn_mullow_n, speed_mpn_mullow_basecase): New functions. * tune/speed.c (routine): Add entries for mpn_mullow_n and mpn_mullow_basecase. * tune/speed.h (SPEED_ROUTINE_MPN_MULLOW_N_CALL, SPEED_ROUTINE_MPN_MULLOW_BASECASE): New #defines. * tune/tuneup.c (tune_mullow): New function. * gmp-impl.h (invert_limb): Compute branch-freely. 2004-05-02 Kevin Ryde * mpn/amd64/mode1o.asm: Use movabsq to support large model non-PIC. Use 32-bit insns to save code bytes, and to save a couple of cycles on the initial setup multiplies. 2004-05-01 Kevin Ryde * doc/gmp.texi (References): Update gcc online docs url to gcc.gnu.org. * configure.in (mips*-*-irix[6789]*): Correction to m4 quoting of this pattern. (Believe the mips64*-*-* part also used picks up all current irix6 tuples anyway.) Reported by Rainer Orth. 2004-04-30 Kevin Ryde * acinclude.m4 (GMP_PROG_CC_X86_GOT_EAX_EMITTED, GMP_ASM_X86_GOT_EAX_OK): New macros. (GMP_PROG_CC_WORKS): Use them to detect an old gas bug tickled by recent gcc. Reported by David Newman. * doc/gmp.texi (Reentrancy): Note also gmp_randinit_default as an alternative to gmp_randinit. 2004-04-29 Torbjorn Granlund * configfsf.guess: Update to 2004-03-12. * configfsf.sub: Likewise. 2004-04-27 Torbjorn Granlund * mpz/rrandomb.c (gmp_rrandomb): Rework to avoid extra limb allocation and to generate even numbers. * mpn/generic/random2.c (gmp_rrandomb): Likewise. 2004-04-25 Kevin Ryde * gmp-impl.h (FORCE_DOUBLE): Don't use an asm with a match constraint on a memory output, apparently not supported and provokes a warning from gcc 3.4. 2004-04-24 Kevin Ryde * longlong.h (count_leading_zeros_gcc_clz, count_trailing_zeros_gcc_ctz): New macros. (count_leading_zeros, count_trailing_zeros) [x86]: Use them on gcc 3.4. * configure.in (x86-*-* gcc_cflags_cpu): Give a -mtune at the start of each option list, for use by gcc 3.4 to avoid deprecation warnings about -mcpu. * mpz/aorsmul.c, mpz/aorsmul_i.c, mpz/cfdiv_q_2exp.c, mpz/cfdiv_r_2exp.c, mpq/aors.c, mpf/ceilfloor.c: Give REGPARM_ATTR() on function definition too, as demanded by gcc 3.4. 2004-04-22 Kevin Ryde * tests/rand/t-lc2exp.c (check_bigc1): New test. * doc/fdl.texi: Tweak @appendixsubsec -> @appendixsec to match our preference for this in an @appendix, and because texi2pdf doesn't support @appendixsubsec directly within an @appendix. 2004-04-20 Kevin Ryde * doc/texinfo.tex: Update to 2004-04-07.08 from texinfo 4.7. * doc/gmp.texi, mpfr/mpfr.texi (@copying): Don't put a line break in @ref within @copying, recent texinfo.tex doesn't like that. * demos/perl/GMP.xs (static_functable): Treat cygwin the same as mingw DLLs. * */Makefile.in, install-sh: Update to automake 1.8.3. * ltmain.sh, aclocal.m4, configure: Update to libtool 1.5.6. * gmp-impl.h (LIMB_HIGHBIT_TO_MASK): Use a compile-time constant expression, rather than a configure test. * acinclude.m4, configure.in (GMP_C_RIGHT_SHIFT): Remove, no longer needed. * tests/t-hightomask.c: New file. * tests/Makefile.am (check_PROGRAMS): Add it. * macos/configure (parse_top_configure): Look for PACKAGE_NAME and PACKAGE_VERSION now used by autoconf. (what_objects): Only demand 9 object files, as for instance occurs in the scanf directory. (asm files): Transform labels L(foo) -> Lfoo. Take func name from PROLOGUE to support empty "EPILOGUE()". Recognise and substitute register name "define()"s. * macos/Makefile.in (CmnObjs): Add tal-notreent.o. 2004-04-19 Torbjorn Granlund * tune/speed.h (SPEED_ROUTINE_MPN_ROOTREM): New #define. (speed_mpn_rootrem): Declare. * tune/common.c (speed_mpn_rootrem): New function. * tune/speed.c (routine): Add entry for mpn_rootrem. 2004-04-16 Kevin Ryde * doc/fdl.texi: Update from FSF, just fixing a couple of typos. * macos/configure, macos/Makefile.in: Add printf and scanf directories. * tests/mpz/t-gcd.c (check_data): New function, exercising K6 gcd_finda bug. 2004-04-14 Kevin Ryde * doc/gmp.texi (Reentrancy, Random State Initialization): Note gmp_randinit use of gmp_errno is not thread safe. Reported by Vincent Lefèvre. * doc/gmp.texi (Random State Initialization): Add index entries for gmp_errno and constants. * mpn/m68k/README: Update _SHORT_LIMB -> __GMP_SHORT_LIMB. * configure.in (--enable-mpbsd): Typo Berkley -> Berkeley in help msg. 2004-04-12 Kevin Ryde * demos/perl/GMP.xs (static_functable): New macro, use it for all function tables, to support mingw DLL builds. * demos/perl/INSTALL (NOTES FOR PARTICULAR SYSTEMS): Remove note on DLLs, should be ok now. * demos/perl/sample.pl: Print the module and library versions in use. * demos/perl/GMP.pm, Makefile.PL (VERSION): Set to '2.00'. * demos/perl/GMP.pm (COPYRIGHT): New in the doc section. * Makefile.am: Note 4.1.3 libtool versioning info, and REVISION policy. * tal-debug.c: Add for abort. 2004-04-07 Torbjorn Granlund * tests/refmpf.c (refmpf_add_ulp): Adjust exponent when needed. * mpn/generic/random2.c: Rewrite (clone mpz/rrandomb.c). 2004-04-07 Kevin Ryde * mpn/x86/k6/gcd_finda.asm: Correction jbe -> jb in initial setups. Zero flag is wrong here, it relects only the high limb of the compare, leading to n1>=n2 not satisfied and wrong results. cp[1]==0x7FFFFFFF with cp[0]>=0x80000001 provokes this. * doc/gmp.texi (BSD Compatible Functions): Note "pow" name clash under the pow function description too. (Language Bindings): Add XEmacs (betas at this stage). Reported by Jerry James. * tests/refmpn.c (refmpn_mod2): Correction to ASSERTs, r==a is allowed. * gen-psqr.c (generate_mod): Cast mpz_invert_ui_2exp args, for K&R. * gen-bases.c, gen-fib.c, gen-psqr.c: For mpz_out_str, use stdout instead of 0, in case a K&R treats int and FILE* params differently. 2004-04-04 Kevin Ryde * gmp-impl.h (BSWAP_LIMB) [amd64]: New macro. (FORCE_DOUBLE): Use this for amd64 too. * tests/amd64check.c, tests/amd64call.asm: New files, derived in part from x86check.c and x86call.asm. * tests/Makefile.am (EXTRA_libtests_la_SOURCES): Add them. * configure.in (x86_64-*-* ABI=64): Use them. 2004-04-03 Kevin Ryde * mpn/amd64/mode1o.asm: New file. * mpn/amd64/amd64-defs.m4 (ASSERT): New macro. * mpn/x86/k7/mmx/divrem_1.asm, mpn/x86/pentium4/sse2/divrem_1.asm: Add note on how "dr" part of algorithm is handled. * mpn/x86/k7/dive_1.asm, mpn/x86/k7/mod_34lsub1.asm, mpn/x86/k7/mode1o.asm: Note Hammer (32-bit mode) speeds. 2004-03-31 Kevin Ryde * doc/gmp.texi (Language Bindings): Add GOO, MLGMP and Numerix. * mpf/mul_2exp.c, mpf/div_2exp.c: Rate u==0 as UNLIKELY. 2004-03-28 Torbjorn Granlund * mpn/amd64/divrem_1.asm: Trim a few cycles. 2004-03-27 Torbjorn Granlund * mpn/amd64/sublsh1_n.asm: Fix typo. * mpn/generic/divrem_1.c: Fix typo. * mpn/generic/sqr_basecase.c: Fix typo. * mpn/amd64/divrem_1.asm: New file. 2004-03-20 Kevin Ryde * longlong.h (power, powerpc): Add comments on how we select this code. * gmp-h.in (mpz_get_ui): Use ?: instead of mask style, gcc treats the two identically but ?: is a bit clearer. * insert-dbl.c: Remove file, no longer used, scaling is now integrated in mpn_get_d. * Makefile.am (libgmp_la_SOURCES): Remove insert-dbl.c. * gmp-impl.h (__gmp_scale2): Remove prototype. 2004-03-17 Kevin Ryde * mpn/x86/fat/fat.c (__gmpn_cpuvec_init, fake_cpuid_table): Add x86_64. * mpq/get_d.c: Use mpn_tdiv_qr, demand den>0 per canonical form. 2004-03-16 Torbjorn Granlund * mpn/generic/sqr_basecase.c: Add versions using mpn_addmul_2 and mpn_addmul_2s. 2004-03-14 Kevin Ryde * mpf/mul_ui.c: Incorporate carry from low limbs, for exactness. * tests/mpf/t-mul_ui.c: New file. * tests/mpf/Makefile.am (check_PROGRAMS): Add it. * mpf/div.c: Use mpn_tdiv_qr. Use just one TMP_ALLOC. Use full divisor, since truncating can lose accuracy. * tests/mpf/t-div.c: New file. * tests/mpf/Makefile.am (check_PROGRAMS): Add it. * tests/mpf/t-set_q.c, tests/mpf/t-ui_div.c (check_various): Amend bogus 99/4 test. * tests/mpf/t-ui_div.c (check_rand): Exercise r==v overlap. * tests/refmpf.c, tests/tests.h (refmpf_set_overlap): New function. * mpf/cmp_si.c [nails]: Correction, cast vval in exp comparisons, for when vval=-0x800..00 and limb==longlong. * mpf/cmp_si.c [nails]: Correction, return usign instead of 1 when uexp==2 but value bigger than an mp_limb_t. * tests/mpf/t-cmp_si.c (check_data): Add test cases. * tests/trace.c (mpf_trace): Use ABS(mp_trace_base) to allow for negative bases used for upper case hex in integer traces. 2004-03-12 Torbjorn Granlund * mpn/generic/sb_divrem_mn.c: Correct header comment. 2004-03-11 Kevin Ryde * aclocal.m4, configure, ltmain.sh: Downgrade to libtool 1.5, version 1.5.2 doesn't remove .libs/*.a files when rebuilding, which is bad for development when changing contents or with duplicate named files like we have. Revert this, ie restore AR_FLAGS=cq: * acinclude.m4 (GMP_PROG_AR): Remove AR_FLAGS=cq, libtool 1.5.2 now does this itself on detecting duplicate object filenames in piecewise linking mode. * randbui.c, randmui.c [longlong+nails]: Correction to conditionals for second limb. * mpz/aors_ui.h, mpz/cdiv_q_ui.c, mpz/cdiv_qr_ui.c, mpz/cdiv_r_ui.c, mpz/cdiv_ui.c, mpz/fdiv_q_ui.c, mpz/fdiv_qr_ui.c, mpz/fdiv_r_ui.c, mpz/fdiv_ui.c, mpz/gcd_ui.c, mpz/iset_ui.c, mpz/lcm_ui.c, mpz/set_ui.c, mpz/tdiv_q_ui.c, mpz/tdiv_qr_ui.c, mpz/tdiv_r_ui.c, mpz/tdiv_ui.c, mpz/ui_sub.c, mpf/div_ui.c, mpf/mul_ui.c [longlong+nails]: Amend #if to avoid warnings about shift amount. 2004-03-07 Kevin Ryde * mpf/reldiff.c: Use rprec+ysize limbs for d, to ensure accurate result. Inline mpf_abs(d,d) and mpf_cmp_ui(x,0), and rate the latter UNLIKELY. * mpf/ui_div.c: Use mpn_tdiv_qr. Use just one TMP_ALLOC. Use full divisor, since truncating can lose accuracy. * tests/mpf/t-ui_div.c: New file. * tests/mpf/Makefile.am (check_PROGRAMS): Add it. * mpf/set_q.c: Expand TMP_ALLOC_LIMBS_2, to make conditional clearer and avoid 1 limb alloc when not wanted. * gmp-impl.h (WANT_TMP_DEBUG): Define to 0 if not defined. (TMP_ALLOC_LIMBS_2): Use "if" within macro rather than "#if", for less preprocessor conditionals. * mpf/mul_2exp.c, mpf/div_2exp.c: Add some comments. * tests/refmpn.c (refmpn_sb_divrem_mn, refmpn_tdiv_qr): Nailify. 2004-03-04 Kevin Ryde * gen-psqr.c (print): Add CNST_LIMB in PERFSQR_MOD_TEST, for benefit of K&R. * tests/mpn/t-perfsqr.c (PERFSQR_MOD_1): Use CNST_LIMB for K&R. * doc/configuration (Configure): Remove mkinstalldirs, no longer used. * acinclude.m4 (GMP_PROG_AR): Remove AR_FLAGS=cq, libtool 1.5.2 now does this itself on detecting duplicate object filenames in piecewise linking mode. * configure.in (hppa2.0*-*-*): Test sizeof(long) == 4 or 8 to verify ABI=2.0n versus ABI=2.0w. In particular this lets CC=cc_bundled correctly fall back to ABI=2.0n (we don't automatically add CC=+DD64 to that compiler, currently). * doc/gmp.texi (Reentrancy): Note C++ mpf_class constructors using global default precision. (Random State Miscellaneous): Describe gmp_urandomb_ui as giving N bits. (C++ Interface Floats): Describe operator= copying the value, not the precision, and what this can mean about copy constructor versus default constructor plus assignment. * mpf/set_q.c: Use mpn_tdiv_qr rather than mpn_divrem, so no shifting. Don't truncate the divisor, it can make the result inaccurate. * tests/mpf/t-set_q.c: New file. * tests/mpf/Makefile.am (check_PROGRAMS): Add it. * mpf/set.c: Use MPN_COPY_INCR, in case r==u and ABSIZ(u) > PREC(r)+1. No actual bug here, because MPN_COPY has thusfar been an alias for MPN_COPY_INCR, only an ASSERT failure. * tests/mpf/t-set.c: New file. * tests/mpf/Makefile.am (check_PROGRAMS): Add it. * mpf/set.c, mpf/iset.c: Do MPN_COPY last, for possible tail call. * mpf/set_d.c: Rate d==0 as UNLIKELY. Store size before extract call, to shorten lifespan of "negative". * mpf/init.c, mpf/init2.c, mpf/iset_d.c, mpf/iset_si.c, mpf/iset_str.c, mpf/iset_ui.c: Store prec before alloc call, for one less live quantity across that call. * mpf/init.c, mpf/init2.c, mpf/iset_str.c: Store size and exp before alloc call, to overlap with other operations. * tests/refmpf.c, tests/tests.h (refmpf_fill, refmpf_normalize, refmpf_validate, refmpf_validate_division): New functions. * tests/refmpn.c, tests/tests.h (refmpn_copy_extend, refmpn_lshift_or_copy_any, refmpn_rshift_or_copy_any): New functions. * tal-debug.c: Add for strcmp. * tests/cxx/t-istream.cc (check_mpz, check_mpq, check_mpf): Use size_t for loop index, to quieten g++ warning. 2004-03-02 Kevin Ryde * tests/mpn/t-hgcd.c: Use __GMP_PROTO on prototypes. 2004-03-01 Torbjorn Granlund With Karl Hasselström: * mpn/generic/dc_divrem_n.c (mpn_dc_div_2_by_1): New function, with meat from old mpn_dc_divrem_n. Accept scratch parameter. Rewrite to avoid a recursive call. (mpn_dc_div_3_by_2): New function, with meat from old mpn_dc_div_3_halves_by_2. Accept scratch parameter. (mpn_dc_divrem_n): Now just allocate scratch space and call new mpn_dc_div_2_by_1. 2004-02-29 Kevin Ryde * longlong.h (count_leading_zeros) [alpha gcc]: New version, inlining mpn/alpha/cntlz.asm cmpbge technique. * aclocal.m4, configure, install-sh, missing, ltmain.sh, */Makefile.in: Update to automake 1.8.2 and libtool 1.5.2. * doc/gmp.texi (C++ Interface Integers): Note / and % rounding follows C99 / and %. (Exact Remainder): Index entries for divisibility testing algorithm. * tune/time.c (speed_endtime): Return 0.0 for negative time measured. Revise usage comments for clarity. * tune/common.c (speed_measure): Recognise speed_endtime 0.0 for failed measurement. * tests/mpn/t-get_d.c (check_rand): Correction to nhigh_mask setup. 2004-02-27 Torbjorn Granlund * tune/tuneup.c (tune_dc, tune_set_str): Up param.step_factor. * tests/mpz/t-gcd.c: Decrease # of tests to 50. 2004-02-27 Kevin Ryde * tests/devel/try.c: Add a comment that this is not for Cray systems. * mpf/set_q.c: Don't support den(q)<0, demand canonical form in the usual way. 2004-02-24 Torbjorn Granlund From Kevin: * mpn/generic/mul_fft.c (mpn_fft_add_modF): Loop until normalization criterion met. 2004-02-22 Kevin Ryde * acinclude.m4 (GMP_PROG_CC_WORKS, GMP_OS_X86_XMM, GMP_PROG_CXX_WORKS): Remove files that might look like compiler output, so our "||" alternatives are not fooled. * acinclude.m4 (GMP_PROG_CC_WORKS): Add test for lshift_com code mis-compiled by certain IA-64 HP cc at +O3. * gmp-impl.h (USE_LEADING_REGPARM): Disable under prof or gprof, for the benefit of freebsd where .mcount clobbers registers. Spotted by Torbjorn. * configure.in (WANT_PROFILING_PROF, WANT_PROFILING_GPROF): New AC_DEFINEs. 2004-02-21 Kevin Ryde * configure.in (sparc64-*-*bsd*): Amend -m32 setup for ABI=32, so it's not used in ABI=64 on the BSD systems. 2004-02-18 Niels Möller * tests/mpz/t-gcd.c (gcdext_valid_p): New function. (ref_mpz_gcd): Deleted function. (one_test): Rearranged to call mpz_gcdext first, so that the returned value can be validated. (main): Don't use ref_mpz_gcd. 2004-02-18 Torbjorn Granlund * gmp-impl.h (MPN_TOOM3_MAX_N): Move to !WANT_FFT section. * tests/mpz/t-mul.c: Exclude special huge operands unless WANT_FFT. * mpz/rrandomb.c (gmp_rrandomb): Rewrite. * mpn/generic/mul_n.c (mpn_toom3_sqr_n): Remove write-only variable c5. 2004-02-18 Kevin Ryde * mpf/iset_si.c, mpf/iset_ui.c, mpf/set_si.c, mpf/set_ui.c [nails]: Always store second limb, to avoid a conditional. * tests/mpf/t-get_ui.c: New file. * tests/mpf/Makefile.am (check_PROGRAMS): Add it. * tests/mpf/t-get_si.c (check_limbdata): Further tests. * gmp-impl.h (MP_EXP_T_MAX, MP_EXP_T_MIN): New defines. * mpf/get_ui.c, mpf/get_si.c: Remove size==0 test, it's covered by other conditions. Attempt greater clarity by expressing conditions as based on available data range. * mpf/get_si.c [nails]: Correction, don't bail on exp > abs_size, since may still have second limb above radix point available. * mpf/get_ui.c: Nailify. 2004-02-16 Kevin Ryde * mpz/scan0.c, mpz/scan1.c: Use count_trailing_zeros, instead of count_leading_zeros on limb&-limb. * mpf/sqrt.c: Use "/ 2" for exp, avoiding C undefined behaviour on ">>" of negatives. Correction to comment, exp is rounded upwards. SIZ(r) always prec now, no need for tsize expression. Store EXP(r) and SIZ(r) where calculated to reduce variable lifespans. Make tsize mp_size_t not mp_exp_t, though of course those are currently the same. * gmp-h.in (GMP_ERROR_ALLOCATE, GMP_ERROR_BAD_STRING, GMP_ERROR_UNUSED_ERROR): Remove, never used or documented, and we don't want to use globals for communicating error information. * mpz/gcd_ui.c [nails]: Correction, actually return a value. * mpn/generic/addmul_1.c, mpn/generic/submul_1.c [nails==1]: Add code. 2004-02-15 Kevin Ryde * tests/mpz/t-jac.c (check_data): Remove unnecessary variable "answer". 2004-02-14 Torbjorn Granlund * mpn/ia64/aors_n.asm: Break a group with a RAW conflict. 2004-02-14 Kevin Ryde * acinclude.m4 (GMP_C_RIGHT_SHIFT): Note that it's "long"s which we're concerned about. * mpn/generic/mul_n.c: Add some remarks about toom3 high zero stripping. * mpn/generic/scan0.c, mpn/generic/scan1.c: Remove design issue remarks. What to do about going outside `up' space is a problem, but anything to address it would be an incompatible change. 2004-02-12 Torbjorn Granlund * tests/mpn/t-hgcd.c: Remove unused variables. * mpn/ia64/hamdist.asm: Remove bundling incompatible with HP-UX assembler. Misc HP-UX changes. * mpn/ia64/gcd_1.asm: Add some syntax to placid the HP-UX assembler. 2004-02-11 Kevin Ryde * longlong.h (power, powerpc): Use HAVE_HOST_CPU_FAMILY_power and HAVE_HOST_CPU_FAMILY_powerpc rather than various cpp defines. * gmp-impl.h: Add remarks about limits.h and Cray etc. * mpn/ia64/mul_1.asm: Don't put .pred directives on labelled lines, hpux 11.23 assembler doesn't like that. * mpn/ia64/README: Add a note on this. * dumbmp.c (mpz_mul): Set ALLOC(r) for new data block used. Reported by Jason Moxham. * mpn/pa32/README, mpn/pa64/README (REFERENCES): New sections. 2004-02-10 Torbjorn Granlund * tests/mpz/t-gcd.c: Decrease # of tests run. * mpn/*/gmp-mparam.h: Add HGCD values, update TOOM values. 2004-02-01 Torbjorn Granlund From Kevin: * config.guess: Recognize AMD's hammer processors, return x86_64. 2004-01-31 Niels Möller * mpn/generic/hgcd.c (mpn_cmp_sum3): Declare static. 2004-01-25 Niels Möller * tests/mpn/Makefile.am (check_PROGRAMS): Add t-hgcd. * mpn/generic/hgcd.c (hgcd_jebelean): Simplify, use mpn_cmp_sum3. (mpn_cmp_sum3): New function. (mpn_diff_smaller_p): Remove. (hgcd_final, hgcd_jebelean, hgcd_small_1, hgcd_small_2, euclid_step): Remove tp,talloc arguments. Callers changed. 2004-01-25 Torbjorn Granlund * tune/tuneup.c (all): Reenable calls of tune_gcd_schoenhage and tune_hgcd. * mpn/generic/gcd.c: Reenable Schoenhage code. With Niels Möller: * mpn/generic/hgcd.c: Add const and inline to several functions. (qstack_push_start qstack_push_end qstack_push_quotient): Remove. (euclid_step): Insert removed functions here. (hgcd_adjust): Simplify, don't handle d != 1. (qstack_adjust): Corresponding changes. (mpn_hgcd2_lehmer_step): Remove redundant tests for bh against zero. (hgcd_start_row_p): Tweak. (hgcd_final): Shorten life of ralloc. 2004-01-24 Kevin Ryde * tests/mpf/t-sqrt.c (check_rand1): Further diagnostic printouts. * mpn/generic/sqrtrem.c (mpn_sqrtrem): Add ASSERT_MPN. (mpn_dc_sqrtrem): Add casts for K&R. * mpf/sqrt_ui.c: Nailify. * mpf/set_z.c: Do MPN_COPY last, for possible tail call. * doc/gmp.texi (Miscellaneous Float Functions): For mpf_random2, note exponent is in limbs. * mpn/ia64/README: Add remark about concentrating on itanium-2. 2004-01-22 Kevin Ryde * mpf/sqrt.c: Change tsize calculation to get prec limbs result always, previously got prec+1 when exp was odd. * tests/mpf/t-sqrt.c (check_rand1): New function, code from main. (check_rand2): New function. * mpf/sqrt_ui.c: Change rsize calculation to get prec limbs result, previously got prec+1. * tests/mpf/t-sqrt_ui.c: New file. * tests/mpf/Makefile.am (check_PROGRAMS): Add it. * tests/refmpf.c, tests/tests.h (refmpf_add_ulp, refmpf_set_prec_limbs): New functions. * mpz/get_d_2exp.c, mpf/get_d_2exp.c: Remove x86+m68k force to double, mpn_get_d now does this. Remove res==1.0 check for round upwards, mpn_get_d now rounds towards zero. Move exp store to make mpn_get_d a tail call. * configure.in (x86-*-*): Use ABI=32 rather than ABI=standard. Use gcc -m32 when available, to force mode on bi-arch amd64 gcc. * configure.in, acinclude.m4 (x86_64-*-*): Merge into plain x86 setups as ABI=64. Support ABI=32, using athlon code. Use gcc -mcpu=k8, -march=k8. (amd64-*-*): Remove pattern, config.sub only gives x86_64. * doc/gmp.texi (ABI and ISA): Add x86_64 dual ABIs. * mpn/amd64/README: Add reference to ABI spec. 2004-01-17 Niels Möller * mpn/generic/hgcd.c (hgcd_adjust): Backed out mpn_addlsh1_n change for now. * mpn/generic/hgcd.c (hgcd_adjust): Fixed calls of mpn_addlsh1_n. 2004-01-17 Kevin Ryde * tune/README: Remove open/mpn versions of toom3, no longer exist. * tune/powerpc64.asm: Remove unused L(again). * tune/time.c (mftb): Note single mftb possible for powerpc64. * mpn/generic/mode1o.c: Use "c * mpn/generic/hgcd.c (mpn_diff_smaller_p): Use MPN_DECR_U. (hgcd_adjust): Use mpn_addlsh1_n when available. 2004-01-16 Kevin Ryde * configure.in (powerpc64-*-linux*): Try gcc64. Try -m64 with "cflags_maybe" to get it used in all probing. Add sizeof-long-8 test to check the mode is right if -m64 is not applicable. 2004-01-15 Kevin Ryde * configure.in (--with-readline=detect): Check for readline/readline.h and readline/history.h. Report result of detection. 2004-01-14 Niels Möller * tune/speed.c (routine): Disabled speed_mpn_hgcd_lehmer. * tune/common.c (speed_mpn_hgcd_lehmer): Disabled function. * mpn/generic/hgcd.c (mpn_hgcd_lehmer_itch, mpn_hgcd_lehmer) (mpn_hgcd_equal): Deleted functions. * mpn/generic/gcd.c (hgcd_start_row_p): Deleted function. (gcd_schoenhage): Deleted assertion code using mpn_hgcd_lehmer. * mpn/generic/hgcd.c (hgcd_final): Fixed ASSERT typos. (mpn_hgcd): To use Lehmer's algorithm, call hgcd_final directly, not mpn_hgcd_lehmer. * mpn/generic/gcd.c (gcd_schoenhage): Updated for changes to mpn_hgcd and mpn_hgcd_fix. (Schoenhage code is still disabled). * gmp-impl.h (mpn_hgcd_fix): Updated prototype. * mpn/generic/hgcd.c (mpn_hgcd_fix): Replaced a bunch of arguments by a pointer const struct hgcd_row *s. Updated callers. * mpn/generic/hgcd.c (hgcd_start_row_p): Use const for the input. Moved function definition before hgcd_jebelean. (hgcd_jebelean): Interface change, analogous to hgcd2. (mpn_hgcd_fix): Normalize v. Require that v > 0. (hgcd_adjust): Fix bug in carry update. (mpn_hgcd): Reorganized again, to adapt to mpn_hgcd/hgcd_jebelean now sometimes returning 1. Reintroduced hgcd_adjust. * mpn/generic/hgcd.c (hgcd_final): Streamlined logic for the first hgcd2 call. * mpn/generic/hgcd2.c (mpn_hgcd2): Interface change. Return 1 instead of 2, in the no progress case r0=A, r1=B. * mpn/generic/hgcd.c (hgcd_adjust): Changed arguments and return value. Now takes a struct hgcd_row * and the uv size, and returns updated uvsize. (hgcd_final): Special handling of the case hgcd2 returning 1. Now uses hgcd_adjust, instead of a full Euclid division. 2004-01-13 Niels Möller * mpn/generic/hgcd.c (euclid_step, hgcd_case0): Merged into a single function euclid_step. (mpn_hgcd): Reorganized the logic for the second recursive call. Avoid unnecessary Euclid steps. * tests/mpn/t-hgcd.c (hgcd_values): One more test value. * tests/mpn/t-hgcd.c (hgcd_values): Added values that trigged the hgcd_jebelean bug. * mpn/generic/hgcd.c (hgcd_jebelean): Fixed off by one error. (mpn_hgcd): Simplified the logic for the first recursive call. Now it uses only the correct values from the recursive call, and doesn't do tricks with hgcd_adjust (hgcd_adjust will probably be reintroduced later, though). * tests/mpn/t-hgcd.c (mpz_mpn_equal, hgcd_ref_equal) (hgcd_ref_init, hgcd_ref_clear): New functions. (hgcd_ref): Reference implementation of hgcd, using mpz. (one_test): Use hgcd_ref. Don't use mpn_hgcd_lehmer. (main): Skip one_step if both input values are zero. 2004-01-12 Niels Möller * mpn/generic/hgcd.c (hgcd_final): Rewritten, now uses Lehmer steps instead of a division loop. (mpn_hgcd_lehmer): Deleted old Lehmer code, instead just initialize and then call hgcd_final. * tests/tests.h: Added refmpn_free_limbs prototype. * tests/refmpn.c (refmpn_free_limbs): New function. * tests/mpn/t-hgcd.c: Try the same kind of random inputs as for mpz/t-gcd. 2004-01-11 Niels Möller * mpn/generic/hgcd.c (mpn_hgcd_lehmer): Rewritten, after some more analysis of the size reduction for one Lehmer step. * tests/mpn/t-hgcd.c: New file. 2004-01-11 Torbjorn Granlund With Niels Möller: * mpn/generic/hgcd.c (hgcd_normalize): Fix ASSERTs. (hgcd_mul): Normalize R[1].uvp[1]. Add some more ASSERTs. (hgcd_update_uv): Streamline. ASSERT that input and output is normalized. 2004-01-11 Kevin Ryde * mpn/alpha/ev6/slot.pl: New file, derived in part from mpn/x86/k6/cross.pl. * mpn/alpha/alpha-defs.m4 (ASSERT): New macro. * mpn/asm-defs.m4 (m4_ifdef): New macro, avoiding OSF 4.0 m4 bug. (m4_assert_defined): Use it. * mpn/alpha/default.m4, mpn/alpha/unicos.m4 (LDGP): New macro. * mpn/alpha/ev67/gcd_1.asm: Use it to re-establish gp after jsr. * configure.in, demos/calc/Makefile.am: Use -lcurses or -lncurses with readline, when available. * longlong.h (sub_ddmmss) [generic]: Use alal, since the former can be done without waiting for __x, helping superscalar chips, in particular alpha ev5 and ev6. * longlong.h (sub_ddmmss) [ia64]: New macro. * tests/t-sub.c: New file. * tests/Makefile.am (check_PROGRAMS): Add it. * tests/refmpn.c, tests/tests.h (refmpn_sub_ddmmss): New function. 2004-01-09 Kevin Ryde * mpn/x86/p6/mod_34lsub1.asm: New file, derived in part from mpn/x86/mod_34lsub1.asm. * configure.in (IA64_PATTERN): Use -mtune on gcc 3.4. 2004-01-07 Kevin Ryde * gmp-h.in, mp-h.in (__GMP_SHORT_LIMB): Renamed from _SHORT_LIMB, to keep in our namespace. (Not actually used anywhere currently.) Reported by Patrick Pelissier. * mp-h.in: Use "! defined (__GMP_WITHIN_CONFIGURE)" in the same style as gmp-h.in (though mp-h.in is not actually used during configure). * mp-h.in (__GMP_DECLSPEC_EXPORT, __GMP_DECLSPEC_IMPORT) [__GNUC__]: Use __dllexport__ and __dllimport__ to keep out of application namespace. Same previously done in gmp-h.in. 2004-01-06 Kevin Ryde * configfsf.sub, configfsf.guess: Update to 2004-01-05. * configure.in (amd64-*-* | x86_64-*-*): Update comments on what configfsf.sub does. 2004-01-04 Kevin Ryde * mpn/alpha/README (REFERENCES): Add tru64 assembly manuals. (ASSEMBLY RULES): Note what gcc says about !literal! etc. 2004-01-03 Kevin Ryde * mpn/alpha/ev67/gcd_1.asm: New file. * mpn/x86/pentium4/sse2/rsh1add_n.asm: New file, derived in part from mpn/x86/pentium4/sse2/addlsh1_n.asm. * mpn/x86/p6/p3mmx/popham.asm: Note measured speeds. * mpn/ia64/hamdist.asm: Correction to inputs vs locals in alloc (makes no difference to the generated code). Corrections to a couple of comments. * mpn/x86/pentium4/sse2/addlsh1_n.asm (PARAM_CARRY): Remove macro, not used, no such parameter. * mpn/generic/gcd.c: Use for NULL. * doc/gmp.texi (Single Limb Division): Correction to tex expression for (1/2)x1. And minor wording tweaks elsewhere. * gmp-impl.h (mpn_rsh1add_n, mpn_rsh1sub_n): Correction to comments about how carries returned. * longlong.h (umul_ppmm) [generic]: Add comments about squaring (dropped from tasks list) 2003-12-31 Kevin Ryde * demos/perl/GMP.xs (scan0, scan1): Return ~0 for not-found. * demos/perl/GMP.pm: Describe this, remove the note about ULONG_MAX being the same as ~0 (which is not true in old perl). * demos/perl/test.pl: Update tests. * demos/perl/typemap (gmp_UV): New type. * demos/perl/test.pl (fits_slong_p): Comment out uv_max test, it won't necessarily exceed a long. * demos/perl/GMP.pm: Add a remark about get_str to the bugs section. * mpn/generic/sqrtrem.c, mpz/fac_ui.c, tests/mpf/reuse.c: Add casts for K&R. * tests/mpf/t-muldiv.c: Make ulimb, vlimb into ulongs, which is how they're used, for the benefit of K&R calling. * doc/gmp.texi (Square Root Algorithm): Add a summary of the algorithm. And add further index entries in various places. * mpz/lucnum_ui.c, mpz/lucnum2_ui.c: Use mpn_addlsh1_n when available. * gmp-impl.h, mpn/generic/mul_n.c (mpn_addlsh1_n, mpn_sublsh1_n, mpn_rsh1add_n, mpn_rsh1sub_n): Move descriptions to gmp-impl.h with the prototypes, for ease of locating. 2003-12-30 Torbjorn Granlund * tune/tuneup.c (all): Disable calls of tune_gcd_schoenhage and tune_hgcd for now. 2003-12-29 Torbjorn Granlund * tests/mpz/t-gcd.c: Rewrite, based on suggestions by Kevin. * mpn/ia64/mul_1.asm: Amend TODO list. * mpn/sparc64/README: Remove mpn_Xmul_2, done. Add blurb about L1 cache conflicts. * mpn/generic/gcd.c: Disable Schoenhage code for now. 2003-12-29 Kevin Ryde * mpn/generic/mul_fft.c, mpz/root.c, mpq/cmp_ui.c: Add casts for K&R. 2003-12-27 Kevin Ryde * tests/mpz/t-mul.c (mul_kara, mul_basecase): Use __GMP_PROTO. * mpn/generic/gcd.c (NHGCD_SWAP4_2, NHGCD_SWAP3_LEFT), mpn/generic/hgcd.c (HGCD_SWAP4_LEFT, HGCD_SWAP4_RIGHT, HGCD_SWAP4_2, HGCD_SWAP3_LEFT): Aggregate initializers for automatics is an ANSI-ism, avoid. * Makefile.am (AUTOMAKE_OPTIONS): Restore this, giving no directory on ansi2knr to avoid a circular build rule. * configure.in (AM_INIT_AUTOMAKE): Note options also in Makefile.am. * configure.in (cflags_maybe): Don't loop adding cflags_maybe if the user has set CFLAGS. 2003-12-24 Torbjorn Granlund * mpn/generic/gcd.c (gcd_schoenhage_itch): Avoid unary "+". (mpn_gcd): Allocate scratch space on heap for gcd_schoenhage. (mpn_gcd): Don't invoke MPN_NORMALIZE on input operands. 2003-12-23 Kevin Ryde * configure.in (*sparc*-*-*): Test sizeof(long)==4 or 8 for ABIs, to get the right mode when the user sets the CFLAGS. (testlist): Introduce "any__testlist" to apply to all compilers. * demos/perl/typemap (MPZ_ASSUME, MPQ_ASSUME, MPF_ASSUME): Remove output rules, these are only meant for inputs. (MPZ_MUTATE): Remove, not used since changes for magic. * demos/perl/GMP.xs (mpz_class_hv, mpq_class_hv, mpf_class_hv): New variables, initialized in BOOT. * demos/perl/GMP.xs, demos/perl/typemap: Use them and explicit sv_bless, to save a gv_stashpv for every new object. 2003-12-22 Kevin Ryde * mpn/alpha/mode1o.c, mpn/alpha/dive_1.c: Moved from ev5/mode1o.c and ev5/dive_1.c, these are good for ev4, and would like them in a generic alpha build. 2003-12-21 Kevin Ryde * doc/gmp.texi (Integer Logic and Bit Fiddling): Say "bitwise" in mpz_and, mpz_ior and mpz_xor, to avoid any confusion with what C means by "logical". Reported by Rüdiger Schütz. * gmp-h.in (_GMP_H_HAVE_FILE): Note why defined(EOF) is not good. 2003-12-20 Torbjorn Granlund * mpn/generic/hgcd.c (mpn_diff_smaller_p): Use mpn_cmp instead of mpn_sub_n where possible. Use mp_size_t for relevant variables. 2003-12-20 Kevin Ryde * tune/speed.h (SPEED_TMP_ALLOC_LIMBS): Correction to last change, don't want "- 1" on the TMP_ALLOC_LIMBS. * demos/expr/expr.h: Test #ifdef MPFR_VERSION_MAJOR for when mpfr.h is included, not GMP_RNDZ which is now an enum. * demos/expr/exprfra.c (e_mpfr_ulong_p): Use mpfr_integer_p and mpfr_fits_ulong_p. (e_mpfr_get_ui_fits): Use mpfr_get_ui. * mpfr/*: Update to mpfr cvs head 2003-12-20. * configure, config.in: Update to autoconf 2.59. * */Makefile.in, configure, aclocal.m4, ansi2knr.c, install-sh, doc/mdate-sh: Update to automake 1.8. * mkinstalldirs: Remove, not required by automake 1.8. * doc/gmp.texi (Build Options): HTML is a usual target in automake 1.8. * configure.in (AC_PREREQ): Require autoconf 2.59. (AM_INIT_AUTOMAKE): Require automake 1.8. (AC_C_INLINE): Use rather than GMP_C_INLINE, now has #ifndef __cplusplus we want. (gettimeofday): Use AC_CHECK_FUNCS rather than our workaround code, autoconf now ok. * acinclude.m4 (GMP_C_INLINE): Remove. (GMP_H_EXTERN_INLINE): Use AC_C_INLINE. (GMP_PROG_AR): Comment on automake $ARFLAGS. 2003-12-19 Niels Möller * mpn/generic/hgcd.c (mpn_diff_smaller_p): Rewrote function. Tried to explain how it works. (slow_diff_smaller_p, wrap_mpn_diff_smaller_p) [WANT_ASSERT]: Use CPP to wrap assertion checks around all calls to mpn_diff_smaller_p. * mpn/generic/hgcd.c (mpn_addmul2_n_1) [nails]: Fixed carry handling. * mpn/generic/hgcd.c (mpn_diff_smaller_p) [nails]: Use GMP_NUMB_MAX, not MP_LIMB_T_MAX. (mpn_hgcd_itch): Improved size calculation. (mpn_hgcd_max_recursion): Moved function from qstack.c. Should to be recompiled when HGCD_SCHOENHAGE_THRESHOLD is tuned. * mpn/generic/qstack.c (mpn_hgcd_max_recursion): ... moved from here. 2003-12-19 Torbjorn Granlund * tests/mpf/t-get_d.c: Print message before aborting. * mpn/generic/hgcd2.c (mpn_hgcd2): Substitute always-zero variable with 0. Remove bogus comment. * mpn/generic/get_d.c: Make ONE_LIMB case actually work for nails. 2003-12-18 Niels Möller * mpn/generic/hgcd.c (hgcd_update_r): Assert that the output r2 is smaller than the input r1. 2003-12-18 Torbjorn Granlund * mpz/get_d.c: Don't include longlong.h. * tests/mpz/t-mul.c (ref_mpn_mul): Handle un == vn specially, to avoid a dummy r/w outside of allocated area. 2003-12-18 Kevin Ryde * mpn/alpha/unicos.m4 (ALIGN): Add comments on what GCC does. * configure.in (fat setups), acinclude.m4 (GMP_INIT): Obscure include() from automake 1.8 aclocal. * acinclude.m4: Quote names in AC_DEFUN, for automake 1.8 aclocal. 2003-12-17 Niels Möller * tune/common.c (speed_mpn_hgcd, speed_mpn_hgcd_lehmer) [nails]: Enabled code also for GMP_NAIL_BITS > 0. * tune/speed.c [nails]: Enable speed_mpn_hgcd and speed_mpn_hgcd_lehmer. * tune/tuneup.c (tune_hgcd) [nails]: Likewise. * mpn/generic/gcd.c [nails]: Use Schönhage's algorithm also for GMP_NAIL_BITS > 0. * mpn/generic/hgcd.c [nails]: Enable the code for GMP_NAIL_BITS > 0. (MPN_EXTRACT_LIMB) [nails]: Handle nails. (__gmpn_hgcd_sanity): Allocate temporaries on the heap, not on the stack. Also check that r[i] >= r[i+1]. (mpn_hgcd2_lehmer_step) [nails]: Handle nails. (mpn_hgcd_lehmer): When we temporarily have r3 > r2, avoid trigging that assert in __gmpn_hgcd_sanity. (mpn_hgcd): Likewise. * mpn/generic/hgcd2.c (div2) [nails]: Alternative nail-aware version. (SUB_2): New macro of Kevin's, which reduces do sub_ddmmss in the non-nail case. (HGCD2_STEP): Use SUB_2, not sub_ddmmss. Added alternative version for K&R compilers. (mpn_hgcd2) [nails]: Use SUB_2, not sub_ddmmss. New nail-aware code for checking Jebelean's condition. 2003-12-13 Kevin Ryde * mpq/get_d.c: Amend comments per mpn_get_d change. (limb2dbl): Remove, no longer used. * gmp-impl.h (DIVREM_1_NORM_THRESHOLD etc) [nails]: Correction to comments, MP_SIZE_T_MAX means preinv never. * gmp-impl.h (DIVEXACT_1_THRESHOLD, MODEXACT_1_ODD_THRESHOLD) [nails]: Remove overrides, divexact_1 and modexact_1 have been nailified. * mpz/inp_str.c (mpz_inp_str_nowhite): Use ASSERT_ALWAYS for EOF value requirement. * tests/refmpn.c (refmpn_rsh1add_n, refmpn_rsh1sub_n): Parens around GMP_NUMB_BITS - 1 with ">>", to quieten gcc -Wall. * tests/t-constants.c (main), tests/t-count_zeros.c (check_clz), tests/t-modlinv.c (one), tests/mpz/t-jac.c (try_si_zi), tests/mpq/t-get_d.c (check_onebit): : Correction to printfs. * tests/mpn/t-fat.c: Add for memcpy. * tests/mpz/t-scan.c (check_ref): Remove unused variable "isigned". * tests/mpq/t-get_d.c (check_onebit): Remove unused variable "limit". * tests/mpf/t-set_si.c, tests/mpf/t-set_ui.c (check_data): Braces for initializers. * tests/devel/try.c (mpn_divexact_by3_fun, mpn_modexact_1_odd_fun): Correction to return values. * doc/gmp.texi (Miscellaneous Integer Functions): Note mpz_sizeinbase can be used to locate the most significant bit. Reword a bit for clarity. 2003-12-12 Niels Möller * mpn/generic/hgcd.c (__gmpn_hgcd_sanity): Fixed stack buffer overrun. * mpn/generic/hgcd.c: Improved comments. 2003-12-11 Torbjorn Granlund * gmp-impl.h: Change asm => __asm__, tabify. * mpz/get_d_2exp.c: Likewise. * mpf/get_d_2exp.c: Likewise. * tests/cxx/t-ops.cc: #if .. #endif out tests that cause ambiguities. 2003-12-10 Torbjorn Granlund * tests/mpz/t-gcd.c: Generate operands with sizes as a geometric progression, to allow for larger operands and less varying timing. * tune/tuneup.c (tune_gcd_schoenhage): Set param.step_factor. (tune_hgcd): Likewise. 2003-12-10 Kevin Ryde * demos/perl/test.pl: Should be $] for perl version in old perl. * configure.in (sparc64-*-*): Single block of gcc configs for all systems, on unknown systems try both ABI 32 and 64. * configure.in (LIBGMP_LDFLAGS, LIBGMPXX_LDFLAGS): New AC_SUBSTs with options to generate .def files with windows DLLs. * Makefile.am (libgmp_la_LDFLAGS, libgmpxx_la_LDFLAGS): Use them. * mpn/generic/gcd.c: Use ABOVE_THRESHOLD / BELOW_THRESHOLD, to follow convention and cooperate with tune/tuneup.c. * tune/tuneup.c (tune_gcd_schoenhage): Increase max_size to 3000, side default 1000 is approx the crossover point on athlon. * tune/common.c, tune/speed.c, tune/speed.h, tune/speed-ext.c, tune/tuneup.c (SPEED_TMP_ALLOC_LIMBS): Take variable as parameter rather than returning a value, avoids alloca in a function call. * tune/common.c, tune/speed.h (speed_tmp_alloc_adjust): Remove, now inline in SPEED_TMP_ALLOC_LIMBS, and using ptr-NULL for alignment extraction. * gmpxx.h (__gmp_binary_equal, __gmp_binary_not_equal, __gmp_binary_less, __gmp_binary_less_equal, __gmp_binary_greater, __gmp_binary_greater_equal, __gmp_cmp_function): Use mpfr_cmp_si and mpfr_cmp_d. * tests/cxx/t-ops.cc: Exercise this. * demos/perl/Makefile.PL: Don't install sample.pl and test2.pl. * demos/perl/GMP.xs (use_sv): Prefer PV over IV or NV to avoid any rounding. * demos/perl/test.pl: Exercise this. * demos/perl/GMP/Mpf.pm (overload_string): Corrections to $# usage. * demos/perl/test.pl: Exercise this. 2003-12-08 Kevin Ryde * demos/perl/GMP.pm: Correction to canonicalize example. * demos/perl/GMP.xs: New type check scheme, support magic scalars, support UV when available. Remove some unused local variables. (coerce_long): Check range of double. (get_d_2exp): Remove stray printf. * demos/perl/test.pl: Exercise magic, rearrange to make it clearer what's being tested. 2003-12-07 Kevin Ryde * mpn/generic/hgcd.c (mpn_hgcd): Use BELOW_THRESHOLD, to follow the convention of N for strtol. * tests/misc/t-scanf.c (test_sscanf_eof_ok): New function. (check_misc): Use it to suppress tests broken by libc. And should be EOF rather than -1 in various places. 2003-12-06 Torbjorn Granlund * tune/common.c (speed_mpn_hgcd, speed_mpn_hgcd_lehmer): Move SPEED_TMP_ALLOC_LIMBS invocations out from calls. * mpn/generic/get_str.c (mpn_get_str, POW2_P case): Don't append extra '\0' byte. 2003-12-05 Niels Möller * tune/common.c (speed_mpn_hgcd_lehmer, speed_mpn_hgcd): Updated for the renaming hgcd_sanity -> ASSERT_HGCD. * mpn/generic/gcd.c (gcd_schoenhage): TMP_DECL must be the final declaration in the declaration section of a block. * tune/speed.h (mpn_gcd_accel): Added prototype. 2003-12-05 Torbjorn Granlund * randmt.c (__gmp_mt_recalc_buffer): Put parens around "&" expressions inside "!=". * mpf/get_str.c: Remove unused variable "fracn". 2003-12-03 Kevin Ryde * configure.in, Makefile.am (LIBGMP_LDFLAGS, LIBGMPXX_LDFLAGS): New AC_SUBSTs, use them to create .def files with Windows DLLs. * doc/gmp.texi (Notes for Particular Systems): Update notes on mingw DLL with MS C. * mpz/export.c: Allow NULL for countp. * doc/gmp.texi (Integer Import and Export): Describe this. Suggested by Jack Lloyd. * mpn/x86/p6/aors_n.asm: New file, grabbing the K7 code. Superiority of this reported by Patrick Pelissier. 2003-11-30 Kevin Ryde * mpn/alpha/ev67/popcount.asm, mpn/alpha/ev67/hamdist.asm: New files. * mpn/alpha/ev67: New directory. * configure.in (alphaev67, alphaev68, alphaev7*): Use it. * doc/gmp.texi (GMPrefu, GMPpxrefu): Change back to plain ref and pxref, remove macros. (GMPreftopu, GMPpxreftopu): Remove URL parameter, rename to GMPreftop and GMPpxreftop. (Debugging): Remove debauch, seems to have disappeared. (Language Bindings): Corrections to URLs for CLN, Omni F77, Pike. 2003-11-29 Kevin Ryde * demos/perl/GMP/Mpf.pm (overload_string): Use $OFMT to avoid warnings about $#. * demos/perl/GMP.xs (fits_slong_p): Use LONG_MAX+1 to avoid possible rounding of 0x7F..FF in a double on 64-bit systems. * configure.in (ppc601-*-*): Remove this case, it never matched anything, the name adopted is powerpc601. (powerpc601-*-*): Use gcc -mcpu=601, xlc -qarch=601. * configure.in: Introduce ${cc}_cflags_maybe, used if they work. (*sparc*-*-*) [ABI=32]: Add gcc_cflags_maybe=-m32 to force that mode. * doc/gmp.texi (Introduction to GMP): Add AMD64 to optimizations list. (Build Options): Add cpu types alphaev7 and amd64. Update texinfo html cross reference. 2003-11-28 Niels Möller * tune/tuneup.c (tune_hgcd): Disable if GMP_NAIL_BITS > 0. * tune/speed.c (routine): Likewise. * tune/common.c (speed_mpn_hgcd, speed_mpn_hgcd_lehmer): Likewise. * mpn/generic/gcd.c, mpn/generic/hgcd.c, mpn/generic/hgcd2.c [GMP_NAIL_BITS]: Disabled new code if we have nails. * mpn/generic/gcd.c (MPN_LEQ_P): Copied macro definition (needed for compilation with --enable-assert). * tune/tuneup.c (hgcd_schoenhage_threshold, gcd_schoenhage_threshold): New variables. (tune_hgcd, tune_gcd_schoenhage): New functions. (all): Call tune_hgcd and tune_gcd_schoenhage. * tune/common.c (speed_mpn_hgcd, speed_mpn_hgcd_lehmer) (speed_mpn_gcd_accel): New functions. * tune/speed.c (routine): Added mpn_hgcd, mpn_hgcd_lehmer and mpn_gcd _accel. * tune/speed.h: Added corresponding prototypes. * tune/gcd_accel.c: New file. * tune/gcd_bin.c (GCD_SCHOENHAGE_THRESHOLD): Set to MP_SIZE_T_MAX. * tune/Makefile.am (libspeed_la_SOURCES): Added gcd_accel.c. (TUNE_MPN_SRCS_BASIC): Added hgcd.c. * mpn/x86/k7/gmp-mparam.h (HGCD_SCHOENHAGE_THRESHOLD) (GCD_SCHOENHAGE_THRESHOLD): Tuned values. * mpn/generic/gcd.c (mpn_gcd, gcd_binary_odd): Renamed the old mpn_gcd function (which implements accelerated binary gcd) to gcd_binary_odd. (gcd_binary): New function, with the additional book keeping needed when using gcd_binary_odd to compute the gcd of non-odd numbers. (hgcd_tdiv): New function. (gcd_lehmer): New function, currently #if:ed out. (hgcd_start_row_p): New function, duplicated from hgcd.c. (gcd_schoenhage_itch): New function. (gcd_schoenhage): New function. (mpn_gcd): New advertised gcd function, which calls mpn_gcd_binary_odd or mpn_gcd_schoenhage, depending on the size of the input. * mpn/generic/hgcd.c (mpn_hgcd2_lehmer_step): Renamed function (was lehmer_step), and made non-static. Updated callers. * gmp-impl.h (GCD_LEHMER_THRESHOLD): #if:ed out this macro. (mpn_hgcd2_lehmer_step): Added prototype. 2003-11-27 Niels Möller * tests/mpz/t-gcd.c (gcd_values): Moved definition, so that we don't need to forward declare the array. 2003-11-26 Niels Möller * mpn/generic/hgcd.c (mpn_hgcd2_fix): Deleted duplicate definition (the function belongs to hgcd2.c). 2003-11-26 Torbjorn Granlund * tests/mpz/t-gcd.c: Generate random operands up to 32767 bits; decrease # of test to 1000. (gcd_values): Remove oversize test case. 2003-11-26 Niels Möller * gmp-impl.h: Added name mangling for hgcd-related functions. Also use __GMP_PROTO. (MPN_LEQ_P, MPN_EXTRACT_LIMB): Moved macros to hgcd.c. * mpn/generic/hgcd.c, mpn/generic/hgcd2.c, mpn/generic/qstack.c: Adapted to name changes. * tests/mpz/t-gcd.c (main): Added some tests with non-random input. 2003-11-25 Niels Möller * gmp-impl.h (MPN_LEQ_P, MPN_EXTRACT_LIMB): New macros. (struct qstack, struct hgcd2_row, struct hgcd2, struct hgcd_row) (struct hgcd): New structs. Also added prototypes for new hgcd, hgcd2, qstack and gcd functions. * configure.in (gmp_mpn_functions): Added hgcd2, hgcd and qstack. * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Added hgcd2.c, hgcd.c and qstack.c. * mpn/generic/hgcd.c, mpn/generic/hgcd2.c, mpn/generic/qstack.c: New files, needed for the sub-quadratic gcd. 2003-11-25 Kevin Ryde * doc/gmp.texi (Language Bindings): Add Axiom. 2003-11-22 Kevin Ryde * mpn/alpha/README: More notes on assembler syntax variations. * mpn/alpha/alpha-defs.m4, mpn/alpha/unicos.m4 (unop): Should be ldq_u not bis, and move to alpha-defs.m4 since it can be happily used everywhere. * mpn/alpha/alpha-defs.m4, mpn/alpha/default.m4, mpn/alpha/unicos.m4 (bigend): Move to alpha-defs.m4 and base it on HAVE_LIMB_BIG_ENDIAN or HAVE_LIMB_LITTLE_ENDIAN, so as not to hard code system endianness. * mpn/alpha/alpha-defs.m4: New file. * configure.in (alpha*-*-*): Use it. 2003-11-21 Kevin Ryde * mpfr/*: Update to mpfr-2-0-2-branch 2003-11-21. * mpn/alpha/ev5/com_n.asm: Change "not" to "ornot r31", since "not" isn't recognised by on Cray Unicos. Add missing "gp" to PROLOGUE. * mpn/alpha/README: Add a note on "not". 2003-11-19 Torbjorn Granlund * mpn/alpha/aorslsh1_n.asm: Slightly rework feed-in code, avoiding spurious reads beyond operand limits. * mpn/alpha/ev5/com_n.asm: Add ASM_START/ASM_END. * mpn/generic/mul_fft.c (mpn_fft_zero_p): Remove unused function. (mpn_lshift_com): Make static, nailify properly. 2003-11-19 Kevin Ryde * mpn/generic/diveby3.c: Use a "q" variable to make it clearer what the code is doing. * mpn/powerpc32/750/lshift.asm, mpn/powerpc32/750/rshift.asm: New files. * mpn/alpha/ev5/com_n.asm: New file. * doc/gmp.texi (Assembler Functional Units, Assembler Writing Guide): New sections by Torbjorn, tweaked by me. 2003-11-17 Torbjorn Granlund * mpn/powerpc32: Add power4/powerpc970 cycle counts. Use cmpwi instead of cmpi to placate darwin. 2003-11-15 Kevin Ryde * config.guess: Add comments on MacOS "machine" command. * tests/devel/try.c (main): Use gmp_randinit_default explicitly on __gmp_rands, since RANDS doesn't allow seeding. * doc/gmp.texi (Assigning Integers): Remove notes on possible change to disallow whitespace, this would be an incompatible change and really can't be made. (Toom 3-Way Multiplication): Updates for Paul's new code. * mpn/generic/mul_n.c (toom3_interpolate, mpn_toom3_mul_n): Put if/else braces around whole of #if code, for readability. * tests/refmpn.c (refmpn_addlsh1_n, refmpn_sublsh1_n, refmpn_rsh1add_n, refmpn_rsh1sub_n): Add ASSERTs for operand overlaps etc. * mpfr/*: Update to mpfr-2-0-2-branch 2003-11-15. 2003-11-14 Torbjorn Granlund * mpn/alpha/aorslsh1_n.asm: Use Cray-friendly syntax for "br". 2003-11-13 Torbjorn Granlund * mpn/alpha/aorslsh1_n.asm: New file. 2003-11-12 Kevin Ryde * acinclude.m4 (GMP_PROG_CC_WORKS): Add case provoking AIX power2 assembler, test code by Torbjorn. * configure.in (power*-*-*): Add a comment about -mcpu=rios2 fallback. * tune/speed.c (main): Use gmp_randinit_default explicitly on __gmp_rands, since RANDS doesn't allow seeding. * mpfr/*: Update to mpfr-2-0-2-branch 2003-11-12. * gmp-impl.h, randmt.h (__gmp_randinit_mt_noseed): Move prototype to gmp-impl.h, for use by RANDS. * mpn/Makeasm.am (.s, .S, .asm): Quote $< in test -f, per automake. (.obj): Use test -f and $(CYGPATH_W) as per automake. 2003-11-11 Kevin Ryde * configure.in: Make umul and udiv standard-optional objects, rather than under various extra_functions. * mpn/pa32/hppa1_1/pa7100/add_n.asm, mpn/pa32/hppa1_1/pa7100/addmul_1.asm, mpn/pa32/hppa1_1/pa7100/lshift.asm, mpn/pa32/hppa1_1/pa7100/rshift.asm, mpn/pa32/hppa1_1/pa7100/sub_n.asm, mpn/pa32/hppa1_1/pa7100/submul_1.asm: Use LDEF for labels. * mpf/set_str.c: Don't use memcmp for decimal point testing, just a loop is enough and avoids any chance of memcmp reading past the end of the given string. * randmts.c, randmt.h: New files. * Makefile.am (libgmp_la_SOURCES): Add them. * randmt.c: Move seeding to randmts.c, common defines in randmt.h. * gmp-impl.h (RANDS): Use __gmp_randinit_mt_noseed. * tests/misc.c (tests_rand_start): Use gmp_randinit_default explicitly, not RANDS. * mpn/ia64/ia64-defs.m4 (PROLOGUE_cpu): Use 32-byte alignment, for the benefit of itanium 2. * mpn/ia64/gcd_1.asm: Remove own .align 32. * mpn/ia64/ia64-defs.m4 (ALIGN): New define, using IA64_ALIGN_OK. * mpn/ia64/hamdist.asm: Use ALIGN instead of .align. * acinclude.m4 (GMP_ASM_IA64_ALIGN_OK): New macro. * configure.in (IA64_PATTERN): Use it. * mpn/ia64/README: Add notes on gas big endian align problem. 2003-11-10 Torbjorn Granlund * mpn/ia64/mul_1.asm: Rewrite. 2003-11-08 Torbjorn Granlund * mpn/x86/aors_n.asm: Align loop to a multiple of 16. Also align M4_function_n to a multiple of 16, to minimize alignment padding. Update P6 cycle counts reflecting improvements with new alignment. 2003-11-07 Kevin Ryde * gmp-impl.h (HAVE_HOST_CPU_alpha_CIX): New define. (ULONG_PARITY, popc_limb): Use it, to pick up ev7 as well as 67 and 68. * longlong.h (count_leading_zeros, count_trailing_zeros): Ditto. * doc/gmp.texi (Notes for Package Builds): Add notes on multi-ABI system packaging. (ABI and ISA): Add GNU/Linux ABI=64. (Binary GCD): Add notes on 1x1 GCD algorithms. * mpn/alpha/README: Add some literature references. * mpn/ia64/mode1o.asm: Various corrections to initial checkin. * mpn/ia64/ia64-defs.m4 (ASSERT): Correction to arg quoting. 2003-11-05 Torbjorn Granlund * mpn/powerpc64/linux64.m4: New file. * configure.in (POWERPC64_PATTERN): Handle *-*-linux*. Use linux64.m4. * mpn/ia64/logops_n.asm: New file. 2003-11-05 Kevin Ryde * tune/freq.c (freq_sysctl_hw_model): Relax to just look for "%u MHz", for the benefit of sparc cypress under netbsd 1.6.1. * mpfr/*: Update to mpfr-2-0-2-branch 2003-11-05. * mpn/alpha/ev5/dive_1.c: New file. * configure.in (x86_64-*-*): Accept together with amd64-*-*. * tune/speed.c: Check range of -x,-y,-w,-W alignment specifiers. * tune/speed.h (CACHE_LINE_SIZE): Amend comments. 2003-11-04 Torbjorn Granlund * tune/speed.c: Fix typo in testing HAVE_NATIVE_mpn_modexact_1_odd. 2003-11-03 Kevin Ryde * mpn/ia64/hamdist.asm: New file. * mpn/ia64/mode1o.asm: New file. * mpn/ia64/ia64-defs.m4 (ASSERT): New macro. * tests/mpz/t-set_d.c (check_2n_plus_1): New test. 2003-11-01 Kevin Ryde * mpz/fac_ui.c (BSWAP_ULONG) [limb==2*long]: Remove this case, it provokes code gen problems on HP cc. (BSWAP_ULONG) [generic]: Rename __dst variable to avoid conflicts with BITREV_ULONG. Fix by Jason Moxham. * mpn/powerpc32/mode1o.asm: Use 16-bit i*i for early out, no need to truncate divisor. Amend stated 750/7400 speeds, and note operands that give the extremes. * mpz/set_d.c: Don't use a special case for d < MP_BASE_AS_DOUBLE, gcc 3.3 -mpowerpc64 on darwin gets ulonglong->double casts wrong. * mpn/generic/diveby3.c: Show a better style carry handling in the alternative pipelined sample code. Revert this, the longlong.h macros need -mpowerpc64: * acinclude.m4 (GMP_GCC_POWERPC64): New macro. * configure.in (powerpc64-*-darwin*): Use it to exclude -mpowerpc64 when bad. 2003-10-31 Torbjorn Granlund * mpn/powerpc64/mode64/submul_1.asm: Move an instruction to save a cycle on POWER4. * mpn/powerpc64/mode64/divrem_1.asm: Fix several syntax problems revealed on Mac OS X. * mpn/powerpc64/mode64/*.asm: Add cycle counts for POWER4. * mpn/powerpc64/sqr_diagonal.asm: Rewrite to save a cycle on POWER4. 2003-10-31 Kevin Ryde * mpfr/*: Update to mpfr-2-0-2-branch 2003-10-31. * mpn/powerpc64/README: Add subdirectory organisation notes. * tests/mpn/t-get_d.c: Don't use limits.h, LONG_MIN is wrong on gcc 2.95 with -mcpu=ultrasparc. * acinclude.m4 (GMP_GCC_POWERPC64): New macro. * configure.in (powerpc64-*-darwin*): Use it to exclude -mpowerpc64 when bad. * configure.in (powerpc64-*-darwin*) [ABI=mode32]: Use gcc -mcpu flags. * mpn/ia64/divrem_1.asm, mpn/ia64/gcd_1.asm: Use "C" for comments. * mpn/ia64/README, mpn/ia64/ia64-defs.m4: Note this. * mpn/ia64/ia64-defs.m4: Renamed from default.m4, per other defs files. * configure.in (IA64_PATTERN): Update GMP_INCLUDE_MPN. * doc/gmp.texi (Notes for Particular Systems): Remove m68k ABI notes for -mshort and PalmOS, now works. (References): Correction, GMP Square Root proof already there, just wanting URL from RRRR 4475. 2003-10-29 Kevin Ryde * configure.in (sparc*-*-*): Use gcc -m32 when that option works, to force 32-bit mode on dual 32/64 configurations like GNU/Linux. (sparc64-*-linux*): Add support for ABI=64. * mpn/generic/pre_divrem_1.c: In fraction part, use CNST_LIMB(0) with udiv_qrnnd_preinv to avoid warning about shift > type. * mpfr/*: Update to mpfr-2-0-2-branch 2003-10-29. * tests/cxx/t-istream.cc: Avoid tellg() checks if putback() doesn't update that, avoids certain g++ 2.96 problems. * tests/mpn/t-fat.c: New file. * tests/mpn/Makefile.am (check_PROGRAMS): Add it. * configure.in (CPUVEC_INSTALL, ITERATE_FAT_THRESHOLDS): New macros for fat.h. * mpn/x86/fat/fat.c (__gmpn_cpuvec_init): Use CPUVEC_INSTALL instead of memcpy. Correction to location of "initialized" set. Improve various comments. 2003-10-27 Torbjorn Granlund * mpn/sparc64/mul_1.asm: Change addcc => add in a few places. * mpn/sparc64/addmul_1.asm: Likewise. * mpn/sparc32/v9/mul_1.asm: Apply cross-jumping. * mpn/sparc32/v9/addmul_1.asm: Likewise. * mpn/sparc32/v9/submul_1.asm: Likewise. * mpn/sparc32/v9/sqr_diagonal.asm: Likewise. 2003-10-27 Kevin Ryde * tests/cxx/t-misc.cc: Don't use , on g++ 2.95.4 (debian 3.0) -mcpu=ultrasparc LONG_MIN is wrong and kills the compile. * tests/cxx/t-istream.cc: Correction to tellg tests, don't assume streampos is zero based. * configure.in (HAVE_HOST_CPU_FAMILY_alpha): New define for config.h. * mpn/generic/get_d.c: Use it instead of __alpha for alpha workaround, since Cray cc doesn't define __alpha. * mpn/x86/README: Revise PIC coding notes a bit, add gcc visibility attribute. 2003-10-25 Kevin Ryde * mpn/ia64/gcd_1.asm: New file. * tune/many.pl: Allow for PROLOGUE(fun,...), as used on alpha. * doc/gmp.texi (C++ Formatted Input): Describe base indicator handling. * tests/cxx/t-istream.cc: New file. * tests/cxx/Makefile.am: Add it. * cxx/ismpznw.cc: New file, integer input without whitespace ... * cxx/ismpz.cc: ... from here. * gmp-impl.h (__gmpz_operator_in_nowhite): Add prototype. * cxx/ismpq.cc: Rewrite using mpz input routines. Change to accept a separate base indicator on numerator and denominator. Fix base indicator case where "123/0456" would stop at "123/0". * Makefile.am, cxx/Makefile.am: Add cxx/ismpznw.cc. * tests/mpz/t-set_d.c: New file, derived from tests/mpz/t-set_si.c * tests/mpz/Makefile.am (check_PROGRAMS): Add it. * mpn/m68k/lshift.asm, mpn/m68k/rshift.asm: Support 16-bit int and stack alignment. * mpn/m68k/README: Add notes on this. * configure.in (SIZEOF_UNSIGNED): New define in config.m4. * mpn/m68k/m68k-defs.m4 (m68k_definsn): Add cmpw, movew. Reported by Patrick Pelissier. * mpn/m68k/t-m68k-defs.pl: Don't use -> with hashes, to avoid deprecation warnings from perl 5.8. * configure.in (viac3-*-*): Use just x86/pentium in $path not x86/p6. If gcc is to be believed the old C3s don't have cmov. * Makefile.am: Amend comments about not building from libtool convenience libraries. * mpn/asm-defs.m4 (PROLOGUE): Use m4_file_seen, for correct filename in missing EPILOGUE error messages. (m4_file_seen): Amend comments about where used. * Makefile.am (CXX_OBJECTS): Remove $U, C++ files are not subject to ansi2knr rules. * gmp-h.in (mpn_divmod_1): Use __GMP_CAST, to avoid warnings in applications using g++ -Wold-style-cast. * mpn/z8000/README: New file. 2003-10-22 Kevin Ryde * mpn/generic/get_d.c (CONST_1024, CONST_NEG_1023, CONST_NEG_1022_SUB_53): Replace ALPHA_WORKAROUND with a non-gcc-ism, and use on Cray Unicos alpha too, which has the same problem. * configure.in (powerpc64-*-darwin*): Make ABI=32 available as the final fallback, remove mode64 until we know how it will work. * doc/gmp.texi (Build Options): Add powerpc970 to available CPUs. (ABI and ISA): Add mode32 for Darwin. * configure.in (gettimeofday): Use an explicit AC_TRY_LINK, to avoid known autoconf 2.57 problems with gettimeofday in AC_CHECK_FUNCS on HP-UX. * configure.in (powerpc*-*-*): Use ABI=32 instead of ABI=standard for the default 32-bit ABI. Fixes powerpc64-*-aix* which is documented as choices "aix64 32" but had "aix64 standard". * mpfr/*: Update to mpfr-2-0-2-branch 2003-10-22. * doc/gmp.texi (Notes for Particular Systems): Note m68k gcc -mshort and PalmOS calling conventions not supported. Reported by Patrick Pelissier. (References): Add Paul Zimmermann's Inria 4475 paper. 2003-10-21 Torbjorn Granlund * mpn/ia64/submul_1.asm: Slightly reschedule loop to accommodate Itanium 2 getf.sig latency. 2003-10-21 Kevin Ryde * tests/mpn/t-instrument.c: Add mpn_addlsh1_n, mpn_rsh1add_n, mpn_rsh1sub_n, mpn_sub_nc, mpn_sublsh1_n. Typo in mpn_preinv_divrem_1 conditional. 2003-10-20 Torbjorn Granlund * mpn/powerpc64/mode32/add_n.asm: New file. * mpn/powerpc64/mode32/sub_n.asm: New file. * mpn/powerpc64/mode32/mul_1.asm: New file. * mpn/powerpc64/mode32/addmul_1.asm: New file. * mpn/powerpc64/mode32/submul_1.asm: New file. 2003-10-19 Torbjorn Granlund * longlong.h (AMD64): __x86_64__ => __amd64__. (64-bit powerpc): Only define carry-dependent macros if !_LONG_LONG_LIMB. * acinclude.m4 (POWERPC64_PATTERN): Add powerpc970-*-*. * configure.in (POWERPC64_PATTERN): Handle *-*-darwin*. (POWERPC64_PATTERN, *-*-aix*): Prepend powerpc64/mode64 to path_aix64. * mpn/powerpc64/mode64/mul_1.asm: Change cal => addi. * mpn/powerpc64/mode64/addmul_1.asm: Likewise. * mpn/powerpc64/mode64/submul_1.asm: Likewise. * mpn/powerpc64/sqr_diagonal.asm: Likewise. * mpn/powerpc64/mode64/mul_1.asm: Move from "..". * mpn/powerpc64/mode64/addmul_1.asm: Likewise. * mpn/powerpc64/mode64/submul_1.asm: Likewise. * mpn/powerpc64/mode64/divrem_1.asm: Likewise. * mpn/powerpc64/mode64/rsh1sub_n.asm: Likewise. * mpn/powerpc64/mode64/add_n.asm: Likewise. * mpn/powerpc64/mode64/addsub_n.asm: Likewise. * mpn/powerpc64/mode64/sub_n.asm: Likewise. * mpn/powerpc64/mode64/addlsh1_n.asm: Likewise. * mpn/powerpc64/mode64/diveby3.asm: Likewise. * mpn/powerpc64/mode64/rsh1add_n.asm: Likewise. * mpn/powerpc64/mode64/sublsh1_n.asm: Likewise. * mpn/powerpc64/lshift.asm: Handle mode32 ABI. * mpn/powerpc64/rshift.asm: Likewise. * mpn/powerpc64/umul.asm: Likewise. * tune/powerpc64.asm: Make it actually work. 2003-10-19 Kevin Ryde * mpn/generic/get_d.c: Add a workaround for alpha gcc signed constant comparison bug. * gmpxx.h (gmp_randclass gmp_randinit_lc_2exp_size constructor): Throw std::length_error if size is too big. * tests/cxx/t-rand.cc (check_randinit): Exercise this. * mpn/x86/pentium4/sse2/addlsh1_n.asm: New file, derived in part from mpn/x86/pentium4/sse2/add_n.asm. * doc/gmp.texi (C++ Interface Integers, C++ Interface Rationals, C++ Interface Floats): Note std::invalid_argument exception for invalid strings to constructors and operator=. (C++ Interface Random Numbers): Note std::length_error exception for size too big in gmp_randinit_lc_2exp_size. 2003-10-18 Kevin Ryde * mpfr/*: Update to mpfr-2-0-2-branch 2003-10-18. * gmpxx.h (mpz_class, mpq_class, mpf_class, mpfr_class constructors and operator= taking string or char*): Throw std::invalid_argument if string cannot be converted. * tests/cxx/t-constr.cc, tests/cxx/t-assign.cc: Exercise this. * cxx/ismpz.cc, cxx/ismpq.cc, cxx/ismpf.cc: Use istream std::locale ctype facet for isspace when available. Only accept space at the start of the input, same as g++ libstdc++. Use ASSERT_NOCARRY to check result of mpz_set_str etc. * cxx/ismpf.cc: Don't accept "@" for exponent indicator. * tune/speed.c, tune/speed.h, tune/common.c, tune/Makefile.am: Remove _open and _mpn variants of mpn_toom3_mul_n, only one style now. * tune/mul_n_open.c, tune/mul_n_mpn.c: Remove files. * gmp-impl.h (LIMB_HIGHBIT_TO_MASK): New macro. (udiv_qrnnd_preinv2, udiv_qrnnd_preinv2gen): Use it. * tests/mpz/t-import.c, tests/mpz/t-export.c: Use octal for character constants, hex is an ANSI-ism. * mpn/alpha/ev5/mode1o.c: Corrections to ASSERTs, as per mpn/generic/mode1o.c. * mpn/generic/diveby3.c: Add commented out alternative code and notes for taking the multiply off the dependent chain. Amend/clarify some of the other comments. * configure.in (powerpc970-*-*): Use gcc -mcpu=970 when available. (powerpc7400-*-*): Fallback on gcc -mcpu=750 if -mcpu=7400 not available. * doc/gmp.texi (C++ Formatted Input): Note locale digit grouping not supported. (C++ Formatted Input, C++ Formatted Output): Cross reference class interface on overloading. * mpn/m68k/README: Add various ideas from doc/tasks.html. * mpn/m88k/README: New file. 2003-10-16 Torbjorn Granlund * config.sub: Recognize powerpc970. 2003-10-15 Torbjorn Granlund * config.guess: Recognize powerpc970 under MacOS. 2003-10-15 Kevin Ryde * configure.in, acinclude.m4 (GMP_C_RIGHT_SHIFT): New test. * gmp-impl.h (LIMB_HIGHBIT_TO_MASK): New macro. (udiv_qrnnd_preinv2, udiv_qrnnd_preinv2gen): Use it. * mpn/amd64/amd64-defs.m4: New file, with a non-aligning PROLOGUE. * configure.in (amd64-*-*): Use it. * mpn/amd64/addlsh1_n.asm: Add ALIGN(16). * mpfr/*: Update to mpfr cvs 2003-10-15. * mpn/generic/get_d.c: Rewrite, simplifying and truncating towards zero unconditionally. * tests/mpn/t-get_d.c: Add various further tests. * gmp-impl.h (FORCE_DOUBLE): New macro. * gmp-h.in (__mpz_struct): Add comment on __mpz_struct getting into C++ mangled function names. * doc/gmp.texi (Build Options): Update notes for new doc subdir. (Low-level Functions): Note mpn functions don't check for zero limbs etc, it's up to an application to strip. * doc/configuration (Configure): mdate-sh now in doc subdir, add generated fat.h. 2003-10-14 Torbjorn Granlund * mpn/ia64/lorrshift.asm: Rewrite. * mpn/ia64/diveby3.asm: Remove explicit bundling; add branch hints. 2003-10-13 Torbjorn Granlund * mpn/ia64/diveby3.asm: New file. 2003-10-13 Kevin Ryde * mpn/powerpc32/mod_34lsub1.asm: New file. * mpn/powerpc32/diveby3.asm, mpn/powerpc64/diveby3.asm: src[] in second operand of mullw, to allow possible early-out, which the 0xAA..AB inverse cannot give. This improvement noticed by Torbjorn. * acinclude.m4 (GMP_ASM_LSYM_PREFIX): Print to config.log whether local label is purely temporary or appears in object files, for development purposes. * doc/gmp.texi, doc/fdl.texi, doc/texinfo.tex, doc/mdate-sh: Moved from top-level. * doc/Makefile.am: New file. * configure.in (AC_OUTPUT): Add doc/Makefile. * Makefile.am (SUBDIRS): Move doc subdirectory from EXTRA_DIST. (info_TEXINFOS, gmp_TEXINFOS): Moved to doc/Makefile.am. * mpfr/Makefile.am (mpfr_TEXINFOS): fdl.texi now in doc subdir. (TEXINFO_TEX): texinfo.tex now in doc subdir. (AM_MAKEINFOFLAGS): Set -I to doc subdir. * mpz/and.c: For positive/positive, use mpn_and_n, rate a realloc as UNLIKELY. * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): Don't test for high zero limbs. 2003-10-12 Torbjorn Granlund * mpn/powerpc64/diveby3.asm: New file (trivial edits of powerpc32/diveby3.asm). * mpn/powerpc32/diveby3.asm: Update cycle counts with more processors. * mpn/powerpc32/sqr_diagonal.asm: Likewise. * mpn/pa64/add_n.asm: Correct PA8500 cycle counts. * mpn/pa64/sub_n.asm: Likewise. * mpn/m68k/aors_n.asm (INPUT PARAMETERS): Fix typo. * mpn/m68k/lshift.asm: Likewise. * mpn/m68k/rshift.asm: Likewise. * mpn/m68k/README: Correct an URL; add some STATUS comments. * mpn/ia64/aorslsh1_n.asm: Avoid shrp when shl/shr works just as well. * mpn/powerpc32/addlsh1_n.asm: New file. * mpn/powerpc32/sublsh1_n.asm: New file. 2003-10-12 Kevin Ryde * mpn/sparc64/divrem_1.c, mpn/sparc64/mod_1.c: New files. * mpn/sparc64/sparc64.h (HALF_ENDIAN_ADJ, count_leading_zeros_32, invert_half_limb, udiv_qrnnd_half_preinv): New macros. * gmp-impl.h (udiv_qrnnd_preinv2): Use a ? : for getting the n1 bit, so as not to depend on signed right shifts being arithmetic. * mpn/powerpc32/diveby3.asm: New file. * mpn/generic/divrem_1.c: Use CNST_LIMB(0) to avoid warnings from udiv_qrnnd_preinv about shift count when int * mpn/ia64/rsh1aors_n.asm: New file. * mpn/asm-defs.m4: Handle rsh1aors_n. * configure.in (tmp_mulfunc): Handle rsh1aors_n. 2003-10-11 Kevin Ryde * mpn/x86/pentium4/sse2/diveby3.asm: Remove non-PIC RODATA memory access for 0xAAAAAAAB constant. * gmp-impl.h (popc_limb, ULONG_PARITY) [ev67, ev68]: Add gcc asm versions using ctpop. * mpn/x86/k6/aorsmul_1.asm: Tweak some comments, remove M4_description and M4_desc_retval used only in comments. * mpn/x86/k6/mul_basecase.asm: Add comment on using mpn_mul_1. 2003-10-09 Torbjorn Granlund * mpn/powerpc64/addlsh1_n.asm: Tweak for 0.25 c/l better loop speed. * mpn/powerpc64/sublsh1_n.asm: Likewise. 2003-10-09 Kevin Ryde * mpfr/*: Update to mpfr cvs 2003-10-09. * tests/devel/try.c (_SC_PAGESIZE): Define from _SC_PAGE_SIZE on systems which use that, eg. hpux 9. 2003-10-07 Kevin Ryde * tune/freq.c (freq_sysctl_hw_model): Correction to last sscanf change. * configure.in: Check for psp_iticksperclktick in struct pst_processor. * tune/freq.c (freq_pstat_getprocessor): Use this. * tests/devel/try.c (divisor_array): Add a couple of half-limb values. * acinclude.m4 (GMP_PROG_CC_WORKS): Correction to last change, need to set result "yes" when cross compiling. 2003-10-06 Torbjorn Granlund * mpn/generic/mul_n.c: Use __GMPN_ADD_1/_GMPN_SUB_1 instead of mpn_add_1 and mpn_sub_1. * mpn/pa64/aorslsh1_n.asm: Schedule register save and restore code. 2003-10-05 Torbjorn Granlund * mpn/pa64/mul_1.asm: Misc comment cleanups. * mpn/pa64/addmul_1.asm: Likewise. * mpn/pa64/submul_1.asm: Likewise. * mpn/pa64/README: Correct cycle counts. * mpn/pa64/aorslsh1_n.asm: New file. 2003-10-04 Kevin Ryde * tune/freq.c (freq_sysctl_hw_model, freq_sunos_sysinfo, freq_sco_etchw, freq_bsd_dmesg, freq_irix_hinv): Demand matching of MHz etc at end of sscanf format string. In particular need this for freq_bsd_dmesg on i486-pc-freebsd4.7 to avoid the 486 cpu being used for the frequency. * tests/misc.c, tests/tests.h (tests_setjmp_sigfpe, tests_sigfpe_handler, tests_sigfpe_done, tests_sigfpe_target, tests_dbl_mant_bits): New. * configure.in (viac3*-*-*): Add gcc VIA c3 options. * mpfr/*: Update to mpfr cvs 2003-10-04. * tests/refmpn.c (refmpn_addlsh1_n, refmpn_sublsh1_n, refmpn_rsh1add_n, refmpn_rsh1sub_n): Add ASSERTs for operand overlaps. * tests/tests.h (refmpn_addlsh1_n, refmpn_sublsh1_n, refmpn_rsh1add_n, refmpn_rsh1sub_n): Add prototypes. * tests/devel/try.c, tune/many.pl: Add mpn_addlsh1_n, mpn_sublsh1_n, mpn_rsh1add_n, mpn_rsh1sub_n. 2003-10-03 Torbjorn Granlund * tests/refmpn.c (refmpn_addlsh1_n, refmpn_sublsh1_n, refmpn_rsh1add_n, refmpn_rsh1sub_n): New functions. 2003-10-03 Paul Zimmermann * mpn/generic/mul_n.c (toom3_interpolate): Use mpn_add_1/mpn_sub_1 instead of MPN_INCR_/MPN_DECR_U. 2003-10-02 Torbjorn Granlund * configure.in (ia64*-*-hpux*): Fall back to +O1, not +O. 2003-10-02 Kevin Ryde * configure.in (ia64*-*-hpux*): For cc, let +O optimization level fallback if +O3 doesn't work. * acinclude.m4 (GMP_PROG_CC_WORKS): Add a test of __builtin_alloca when available, to pick up Itanium HP-UX cc internal errors in +O2. Provoking code by Torbjorn. 2003-10-01 Torbjorn Granlund * mpn/ia64/gmp-mparam.h: Retune. * mpn/asm-defs.m4: Handle aorslsh1_n. * configure.in (tmp_mulfunc): Handle aorslsh1_n. * mpn/ia64/aorslsh1_n.asm: New file. * mpn/ia64/aors_n.asm: New file, complete rewrite of mpn_add_n and mpn_sub_n. * mpn/ia64/add_n.asm: Replace by aors_n.asm. * mpn/ia64/sub_n.asm: Replace by aors_n.asm. 2003-10-01 Kevin Ryde * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Make bad ARM last byte into a separate case and consider it non-IEEE, since it looks like this is due to some sort of restricted or incorrect software floats. * demos/calc/Makefile.am: Use automake yacc/lex support, seems fine in separate objdir now. * cxx/dummy.cc: Moved from top-level dummy.cc. * Makefile.am (libgmpxx_la_SOURCES): Update to cxx/dummy.cc, correction to comment about this. 2003-09-30 Torbjorn Granlund * demos/pexpr.c: Correct documentation of -split. (TIME): Remove cast of result to double. (main): Change timing variables to int. (main): #ifdef LIMIT_RESOURCE_USAGE, don't convert numbers of more than 100000 digits. 2003-09-28 Torbjorn Granlund * mpn/*/*.asm: Clean up spacing, tabify. * mpn/alpha/rshift.asm: Table cycle counts. * mpn/alpha/lshift.asm: Likewise. * mpn/alpha/ev5/rshift.asm: Likewise. * mpn/alpha/ev5/lshift.asm: Likewise. * mpn/alpha/ev6/add_n.asm: Likewise. * mpn/alpha/ev6/sub_n.asm: Likewise. * mpn/ia64/lorrshift.asm: Amend comments about performance. * mpn/pa64/mul_1.asm: Fix comment typo. * mpn/pa64/addmul_1.asm: Likewise. * mpn/pa64/submul_1.asm: Likewise. * mpn/amd64/addlsh1_n.asm: Save/restore carry using two insn to break recurrency. Add remarks about possible further speedup. * mpn/amd64/sublsh1_n.asm: Likewise. * mpn/amd64/rsh1add_n.asm: Add remarks about possible further speedup. * mpn/amd64/rsh1sub_n.asm: Likewise. 2003-09-27 Torbjorn Granlund * mpn/powerpc64/README: Update with POWER4/PPC970 pipeline info. * mpn/powerpc64/rsh1add_n.asm: New file. * mpn/powerpc64/rsh1sub_n.asm: New file. * mpn/powerpc64/rshift.asm: Rewrite. * mpn/powerpc64/lshift.asm: Rewrite. 2003-09-26 Torbjorn Granlund * mpn/powerpc64/addlsh1_n.asm: New file. * mpn/powerpc64/sublsh1_n.asm: New file. 2003-09-25 Torbjorn Granlund * tune/common.c (speed_mpn_addlsh1_n, speed_mpn_sublsh1_n, speed_mpn_rsh1add_n, speed_mpn_rsh1sub_n): Conditionalize on corresponding HAVE_NATIVE_*. 2003-09-25 Kevin Ryde * mpz/combit.c: Use GMP_NUMB_BITS not BITS_PER_MP_LIMB. * demos/expr/exprfr.c: Allow for mpfr_inf_p, mpfr_nan_p and mpfr_number_p merely returning non-zero, rather than 1 or 0. * demos/expr/exprfr.c, demos/expr/t-expr.c: Add erf, integer_p, zeta. * demos/expr/Makefile.am (LDADD): Update comments on $(LIBM). 2003-09-24 Torbjorn Granlund * tune/speed.c (routine): Add entries for mpn_addlsh1_n, mpn_sublsh1_n, mpn_rsh1add_n, and mpn_rsh1sub_n. * tune/speed.h: Declare speed_mpn_addlsh1_n, speed_mpn_sublsh1_n, speed_mpn_rsh1add_n, and speed_mpn_rsh1sub_n. * tune/common.c (speed_mpn_addlsh1_n, speed_mpn_sublsh1_n, speed_mpn_rsh1add_n, speed_mpn_rsh1sub_n): New functions. * gmp-impl.h: Declare mpn_addlsh1_n, mpn_sublsh1_n, mpn_rsh1add_n, and mpn_rsh1sub_n. * mpn/asm-defs.m4: Add define_mpn's for addlsh1_n, sublsh1_n, rsh1add_n, and rsh1sub_n. * mpn/powerpc64/*.asm: Add cycle counts in consistent style. Misc styling edits. * mpn/amd64/gmp-mparam.h: Retune. * configure.in: Add #undefs for HAVE_NATIVE_mpn_addlsh1_n, HAVE_NATIVE_mpn_sublsh1_n, HAVE_NATIVE_mpn_rsh1add_n, HAVE_NATIVE_mpn_rsh1sub_n. (gmp_mpn_functions_optional): List addlsh1_n, sublsh1_n, rsh1add_n, and rsh1sub_n. * mpn/amd64/addlsh1_n.asm: New file. * mpn/amd64/sublsh1_n.asm: New file. * mpn/amd64/rsh1add_n.asm: New file. * mpn/amd64/rsh1sub_n.asm: New file. 2003-09-24 Kevin Ryde * mpfr/*: Update to mpfr cvs 2003-09-24. * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Remove conftest* temporary files. 2003-09-23 Torbjorn Granlund * gmp-impl.h (MUL_TOOM3_THRESHOLD, SQR_TOOM3_THRESHOLD): Now 128. 2003-09-23 Kevin Ryde * gmp-h.in (gmp_randinit_set): Use __gmp_const rather than const. 2003-09-22 Torbjorn Granlund * tune/mul_n_mpn.c: (__gmpn_sqr_n): New #define. * tune/mul_n_open.c (__gmpn_sqr_n): New #define. * mpn/generic/mul.c (mpn_sqr_n): Move from here... * mpn/generic/mul_n.c (mpn_sqr_n): ...to here. (mpn_sqr_n): Allocate workspace for toom3 using TMP_* mechanism except for very large operands when !WANT_FFT. * mpn/generic/mul_n.c: Add a missing ";". Misc comment fixes. * mpn/generic/mul.c: Remove spurious #include . * mpn/x86/k7/gmp-mparam.h: Retune. * mpn/generic/mul_n.c (mpn_mul_n): Allocate workspace for toom3 using TMP_* mechanism except for very large operands when !WANT_FFT. * gmp-impl.h (MPN_TOOM3_MUL_N_TSIZE, MPN_TOOM3_SQR_N_TSIZE): Define conditionally on WANT_FFT and HAVE_NATIVE_mpn_sublsh1_n. (MPN_TOOM3_MAX_N): New #define. * mpn/amd64/gmp-mparam.h: Retune. * mpn/Makefile.am (TARG_DIST): Add amd64. * mpn/generic/sqr_basecase.c: Use mpn_addlsh1_n when available. * mpn/generic/mul_n.c: Use proper form for HAVE_NATIVE macros. 2003-09-22 Kevin Ryde * mpfr/*: Update to mpfr cvs 2003-09-22. 2003-09-21 Kevin Ryde * mpn/x86/pentium4/sse2/gmp-mparam.h (USE_PREINV_DIVREM_1, USE_PREINV_MOD_1): Set to 1 for new asm versions. * mpfr/*: Update to mpfr cvs 2003-09-21. 2003-09-21 Paul Zimmermann * mpn/generic/mul_n.c (mpn_toom3_mul_n): Conditionally use mpn_sublsh1_n, mpn_rsh1add_n and mpn_rsh1sub_n, in addition to mpn_addlsh1_n. Avoid all copying, at the expense of some additional workspace. * gmp-impl.h (MPN_TOOM3_MUL_N_TSIZE, MPN_TOOM3_SQR_N_TSIZE): Accommodate latest toom3 code. 2003-09-19 Kevin Ryde * mpn/x86/pentium4/sse2/divrem_1.asm, mpn/x86/pentium4/sse2/mod_1.asm: New files. 2003-09-16 Kevin Ryde * tune/speed.c (run_one): Don't scale the -1.0 not-available return. Print "n/a" for times not-available. 2003-09-13 Paul Zimmermann * mpn/generic/mul_n.c (toom3_interpolate): New function. (mpn_toom3_mul_n, mpn_toom3_sqr_n): Call toom3_interpolate. 2003-09-12 Torbjorn Granlund * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): Remove unused variables. (mpn_toom3_mul_n, mpn_toom3_sqr_n): Use offset `+ 1', not `+ 2' in last MPN_DECR_U calls. 2003-09-12 Paul Zimmermann * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): Rewrite. 2003-09-12 Torbjorn Granlund * gmp-impl.h (MPN_KARA_MUL_N_TSIZE, MPN_KARA_SQR_N_TSIZE): Reformulate to use the same form as MPN_TOOM3_MUL_N_TSIZE. (MPN_TOOM3_MUL_N_TSIZE, MPN_TOOM3_SQR_N_TSIZE): Update for new Toom3 code requirements. * mpn/generic/mul_n.c (evaluate3, interpolate3, add2Times): Remove. (USE_MORE_MPN): Remove. 2003-08-31 Kevin Ryde * mpfr/*: Update to mpfr cvs 2003-08-31. 2003-08-30 Kevin Ryde * mpfr/*: Update to mpfr cvs 2003-08-30. 2003-08-29 Torbjorn Granlund * mpn/amd64/copyi.asm: New file. * mpn/amd64/copyd.asm: New file. * mpn/amd64/README: New file. 2003-08-28 Torbjorn Granlund * mpn/amd64/lshift.asm: New file. * mpn/amd64/rshift.asm: New file. * mpn/amd64/gmp-mparam.h: Retune. 2003-08-23 Kevin Ryde * tune/freq.c (freq_getsysinfo): Correction to speed_cycletime value established. * mpz/rootrem.c, gmp-h.in, gmp.texi (mpz_rootrem): Don't return exactness indication, can get that from testing the remainder. * mpn/x86/k7/aors_n.asm, mpn/x86/k7/mmx/copyi.asm: Amend to comments about loads and stores and what speed should be possible. 2003-08-22 Torbjorn Granlund * mpn/amd64/add_n.asm: New file. * mpn/amd64/sub_n.asm: New file. * mpn/amd64/mul_1.asm: New file. * mpn/amd64/addmul_1.asm: New file. * mpn/amd64/submul_1.asm: New file. 2003-08-19 Kevin Ryde * longlong.h (add_ssaaaa, sub_ddmmss) [hppa 64]: Move down into main __GNUC__ block. Exclude for _LONG_LONG_LIMB (ie. ABI=2.0n) since these forms are only for ABI=2.0w. * longlong.h (count_leading_zeros) [__mcpu32__]: Check __mcpu32__ to avoid bfffo on GCC 3.4 in CPU32 mode. Reported by Bernardo Innocenti. * longlong.h (count_trailing_zeros) [x86_64]: Use "%q0" to force 64-bit register destination. Pointed out by Torbjorn. * mpz/combit.c: Correction to carry handling when extending a negative, and use __GMPN_ADD_1. Correction to complement limb for a negative when there's a non-zero low limb. * tests/mpz/bit.c (check_clr_extend, check_com_negs): Exercise these. * demos/perl/GMP.xs, demos/perl/GMP.pm, demos/perl/test.pl: Add get_d_2exp. * demos/perl/GMP.xs, demos/perl/GMP.pm, demos/perl/GMP/Rand.pm, demos/perl/test.pl: Add gmp_urandomb_ui, gmp_urandomm_ui. (GMP::Rand::randstate): Accept a randstate object to copy. * demos/perl/GMP.xs, demos/perl/GMP.pm, demos/perl/GMP/Mpz.pm, demos/perl/test.pl: Add combit, rootrem. 2003-08-19 Torbjorn Granlund * tune/Makefile.am (EXTRA_DIST): Add amd64.asm. 2003-08-17 Kevin Ryde * gmpxx.h [__MPFR_H]: Include full for inlines. * tests/cxx/t-headfr.cc: New file, exercising this. * tests/cxx/Makefile.am: Add it. * tests/cxx/t-constr.cc: Include config.h for WANT_MPFR. * gmpxx.h: Correction to temp variable type in mpf -> mpfr assignment. Reported by Derrick Bass. * tests/cxx/t-assign.cc (check_mpfr): Exercise this. * configure.in (WANT_MPFR): AC_DEFINE this, for the benefit of tests/cxx/t-*.cc. (Was always meant to have been defined.) * tests/cxx/Makefile.am (INCLUDES): Add -I$(top_srcdir)/mpfr. * gmpxx.h: __gmp_default_rounding_mode -> __gmpfr_default_rounding_mode (struct __gmp_hypot_function): Correction to mpfr_hypot addition. * tests/cxx/t-misc.cc (check_mpfr_hypot): Corrections to mpfr/long tests. 2003-08-16 Torbjorn Granlund * configure.in (amd64): New. * mpn/amd64/gmp-mparam.h: New file. * tune/amd64.asm: New file, derived in part from tune/pentium.asm. 2003-08-15 Kevin Ryde * tune/freq.c (freq_irix_hinv): Reinstate, for the benefit of IRIX 6.2. (freq_attr_get_invent): Conditionalize on INFO_LBL_DETAIL_INVENT too. 2003-08-14 Kevin Ryde * mpq/get_d.c: Use mpn_get_d. * tests/mpq/t-get_d.c (check_onebit): New test. * gmp.texi (Notes for Particular Systems): Under x86 cpu types, note i386 is a fat binary, remove pentium4 recommendation since i386 is now quite reasonable for p4. (Notes for Particular Systems): Under Windows DLLs, remove caveat about --enable-cxx now ok, update .lib creation for new libtool, remove .exp not needed for MS C. (Notes for Package Builds): i386 is a fat binary. (Reentrancy): Remove SCO ctype.h note, don't want to list every system misfeature, and was quite possibly for non-threading mode anyway. (Autoconf): Remove notes on gmp 2 detection, too old to want to encourage anyone to use. (Karatsuba Multiplication): Correction to threshold increase/decrease for a and b terms. Reported by Richard Brent and Paul Zimmermann. Also add various further index entries. * tune/freq.c (freq_attr_get_invent): New function. (freq_irix_hinv): Remove, in favour or freq_attr_get_invent. * configure.in (AC_CHECK_FUNCS): Add attr_get. (AC_CHECK_HEADERS): Add invent.h, sys/attributes.h, sys/iograph.h. 2003-08-03 Kevin Ryde * tune/tuneup.c (tune_mul): Use MUL_KARATSUBA_THRESHOLD_LIMIT. 2003-08-02 Kevin Ryde * mpn/asm-defs.m4: Tweak some comments, add hpux11 to m4wrap 0xFF problem systems. * configure.in (*-*-sco3.2v5*): Remove lt_cv_archive_cmds_need_lc=no, since libtool no longer uses it. This was a workaround fixing ctype.h in SCO 5 shared libraries; not sure if libtool now gets it right on its own, let's hope so. * configure.in, acinclude.m4 (GMP_PROG_HOST_CC): Remove, libtool no longer demands HOST_CC. * configure.in: When C or C++ compiler not found, refer user to config.log. * configure.in (i386-*-*): Turn i386 into a fat binary build. * mpn/x86/fat/fat.c, mpn/x86/fat/fat_entry.asm, mpn/x86/fat/gmp-mparam.h, mpn/x86/fat/gcd_1.c, mpn/x86/fat/mode1o.c: New files. * gmp-impl.h (struct cpuvec_t) [x86 fat]: New structure. * longlong.h (COUNT_LEADING_ZEROS_NEED_CLZ_TAB) [x86 fat]: Define. * mpn/asm-defs.m4 (foreach): New macro. * mpn/x86/x86-defs.m4 (CPUVEC_FUNCS_LIST): New define. * mpn/x86/sqr_basecase.asm: New file, primarily as a fallback for fat binaries. * mpn/x86/p6/gmp-mparam.h, mpn/x86/p6/mmx/gmp-mparam.h: Add comments about fat binary SQR_KARATSUBA_THRESHOLD for p6 and p6/mmx. * configure.in: Add various supports for fat binaries, via fat_path, fat_functions and fat_thresholds variables. * acinclude.m4 (GMP_STRIP_PATH): Mung $fat_path too. (GMP_FAT_SUFFIX, GMP_REMOVE_FROM_LIST): New macros. * gmp-impl.h: Add various supports for fat binaries. (DECL_add_n etc): New macros. (mpn_mul_basecase etc): Define only if not already defined. * mpn/asm-defs.m4 (m4_config_gmp_mparam): Mention fat binary. (MPN): Use m4_unquote, for the benefit of fat binary name expansion. * doc/configuration: Notes on fat binaries. * gmp-impl.h (MUL_TOOM3_THRESHOLD_LIMIT): Define always. (MUL_KARATSUBA_THRESHOLD_LIMIT): New define. * mpn/generic/mul.c, mpn/generic/mul_n.c: Use these. * tune/divrem1div.c, tune/divrem1inv.c, tune/mod_1_div.c, tune/mod_1_inv.c: Define OPERATION_divrem_1 and OPERATION_mod_1, to tell fat.h what's being done. * config.guess (alpha-*-*): Update comments on what configfsf.guess does and doesn't do for us. 2003-07-31 Kevin Ryde * config.guess: Remove $dummy.o files everywhere, in case vendor compilers produce that even when not asked. * demos/perl/GMP.xs (class_or_croak): Rename "class" parameter to avoid C++ keyword. (coerce_ulong, coerce_long): Move croaks to stop g++ 3.3 complaining about uninitialized variables. * demos/perl/INSTALL: Add notes on building with a DLL. * longlong.h (count_trailing_zeros) [x86_64]: Ensure bsfq destination is a 64-bit register. Diagnosed by Francois G. Dorais. 2003-07-31 Torbjorn Granlund * longlong.h [ppc]: Remove nested test for vxworks. 2003-07-24 Kevin Ryde * gmpxx.h (struct __gmp_binary_multiplies): Use mpz_mul_si for mpz*long and long*mpz. * tests/cxx/t-ops.cc (check_mpz): Exercise mpz*long and mpz*ulong. * cxx/ismpf.cc: Use std::locale decimal point when available. Expect localeconv available always. * tests/cxx/t-locale.cc: Enable check_input tests. * gmpxx.h (struct __gmp_hypot_function): Use mpfr_hypot. * tests/cxx/t-misc.cc (check_mpfr_hypot): New tests. * tests/cxx/t-assign.cc, tests/cxx/t-binary.cc, tests/cxx/t-ops.cc, tests/cxx/t-prec.cc, tests/cxx/t-ternary.cc, tests/cxx/t-unary.cc: Include config.h for WANT_MPFR. * tests/mpz/bit.c (check_single): Correction to a diagnostic print. 2003-07-24 Niels Möller * mpz/combit.c: New file. * Makefile.am, mpz/Makefile.am: Add it. * gmp-h.in (mpz_combit): Add prototype. * tests/mpz/bit.c (check_single): Exercise mpz_combit. 2003-07-16 Kevin Ryde * mpn/generic/get_d.c: Correction to infinity handling for large exp. 2003-07-14 Kevin Ryde * mpz/get_d.c, mpz/get_d_2exp.c, mpf/get_d.c, mpf/get_d_2exp.c: Use mpn_get_d. * mpn/generic/get_d.c: New file, based on mpz/get_d.c and insert-dbl.c. * configure.in, mpn/Makefile.am: Add it. * gmp-impl.h (mpn_get_d): Add prototype. * tests/mpn/t-get_d.c: New file. * tests/mpn/Makefile.am: Add it. * tests/mpz/t-get_d_2exp.c (check_onebit, check_round): Test negatives. (check_onebit): Add a few more bit sizes. * tests/misc.c, tests/tests.h (tests_isinf): New function. 2003-07-12 Kevin Ryde * configure.in (GMP_PROG_CXX_WORKS): Include $CPPFLAGS, same as automake does in the actual build. * acinclude.m4 (GMP_PROG_CXX_WORKS): In the namespace test, declare namespace before trying to use. In std iostream test, provoke a failure from Compaq C++ in pre-standard mode. 2003-07-08 Kevin Ryde * acinclude.m4 (GMP_PROG_CC_WORKS): Use separate compiles for various known problems, and indicate to the user the reason for rejecting. (GMP_PROG_CXX_WORKS): Ditto, and insist on being able to execute each compiled program. 2003-07-05 Kevin Ryde * config.sub: Add comments to our alias transformations. * configfsf.sub, configfsf.guess: Update to 2003-07-04. * acinclude.m4 (GMP_PROG_CC_WORKS, GMP_PROG_CC_WORKS_LONGLONG): Show failing program in config.log, per other autoconf tests. * configure.in (i786-*-*): Recognise as pentium4, per configfsf.sub. 2003-06-28 Kevin Ryde * mpz/get_d_2exp.c, mpf/get_d_2exp.c: Avoid res==1.0 when floats round upwards. * tests/mpz/t-get_d_2exp.c: New file. * tests/mpz/Makefile.am (check_PROGRAMS): Add it. * tests/mpf/t-get_d_2exp.c: New file. * tests/mpf/Makefile.am (check_PROGRAMS): Add it. * tests/x86call.asm, test/tests.h (x86_fldcw, x86_fstcw): New functions. * tests/misc.c, tests/tests.h (tests_hardware_getround, tests_hardware_setround): New functions. 2003-06-25 Kevin Ryde * mpn/sparc64/dive_1.c: New file. * mpn/sparc64/sparc64.h: New file. * mpn/sparc64/mode1o.c: Remove things now in sparc64.h. * mpfr/*: Update to mpfr cvs 2003-06-25. * acinclude.m4 (GMP_PROG_CC_WORKS): In last change provoking gnupro gcc, don't use ANSI style function definition. 2003-06-22 Kevin Ryde * mpn/pa32/hppa1_1/udiv.asm: Remove .proc, .entry, .exit and .procend, handled by PROLOGUE and EPILOGUE. Comment out .callinfo, per other asm files. * gmpxx.h (mpz_class __gmp_binary_divides, __gmp_binary_modulus): Fix long/mpz and long%mpz for dividend==LONG_MIN divisor==-LONG_MIN. (mpz_class __gmp_binary_modulus): Fix mpz%long for negative dividend. * tests/cxx/t-ops.cc (check_mpz): Add test cases for these, merging operator/ and operator% sections for clarity. 2003-06-21 Kevin Ryde * mpfr/*: Update to mpfr cvs 2003-06-21. * acinclude.m4 (GMP_PROG_CC_WORKS): Add code by Torbjorn provoking an ICE from gcc 2.9-gnupro-99r1 under -O2 -mcpu=ev6. * configure.in (alpha*-*-* gcc_cflags_cpu): Fallback on -mcpu=ev56 for this compiler. * gmpxx.h (get_d): Remove comments about long double, double is correct for get_d, a future long double form would be get_ld. 2003-06-19 Kevin Ryde * mpfr/*: Update to mpfr cvs 2003-06-19. * mpn/generic/dive_1.c: Share src[0] fetch among all cases. No need for separate final umul_ppmm in even case, make it part of the loop. * mpz/get_d_2exp.c, mpq/set_si.c, mpq/set_ui.c: Nailify. * mpf/iset_si.c: Rewrite using mpf/set_si.c code, in particular this nailifies it. * tests/mpf/t-set_si.c: Nailify tests. * mpf/iset_ui.c: Nailify, as per mpf/set_ui.c * tests/mpf/t-set_ui.c: New file. * tests/mpf/Makefile.am (check_PROGRAMS): Add it. 2003-06-15 Kevin Ryde * mpfr/*: Update to mpfr cvs 2003-06-15. * mpn/x86/k6/mode1o.asm: Remove a bogus ASSERT. 2003-06-12 Kevin Ryde * configure.in (--enable-assert): Emit WANT_ASSERT to config.m4. * mpn/powerpc32/powerpc-defs.m4, mpn/x86/x86-defs.m4 (ASSERT): Check WANT_ASSERT is defined. * mpn/sparc32/v9/udiv.asm: Amend heading, this file is for sparc v9. * tests/cxx/Makefile.am (TESTS_ENVIRONMENT): In libtool openbsd hack, discard error messages from cp, for the benefit of --disable-shared or systems not using names libgmp.so.*. * tests/devel/try.c (try_one): When overlapping, copy source data after filling dst. Previously probably used only DEADVAL in overlapping cases. 2003-06-11 Torbjorn Granlund * mpf/random2.c: Rewrite. Ignore sign of exp parameter. 2003-06-10 Kevin Ryde * mpn/sparc64/mode1o.c: New file. 2003-06-09 Torbjorn Granlund * mpn/powerpc32/lshift.asm: Add more cycle counts. * mpn/powerpc32/rshift.asm: Add more cycle counts. * mpn/ia64/addmul_1.asm: Reformat comments for 80 columns. * gmp-impl.h (udiv_qrnnd_preinv1): New name for udiv_qrnnd_preinv. (udiv_qrnnd_preinv2): New name for udiv_qrnnd_preinv2norm. (udiv_qrnnd_preinv): New #define, making udiv_qrnnd_preinv2 the default. * tune/speed.c: Corresponding changes. * tune/speed.h: Likewise. * tune/common.c: Likewise. * mpf/get_str.c: Simplify `off' computation. * longlong.h: Tabify. 2003-06-09 Kevin Ryde * gmp.texi (ABI and ISA): FreeBSD has sparc64 too, just say "BSD" to cover all flavours. * configure.in: Ditto in some comments. * mpfr/*: Update to mpfr cvs 2003-06-09. * tests/cxx/Makefile.am (LDADD): Add -L$(top_builddir)/$(LIBS), for the benefit of gcc 3.2 on itanium2-hp-hpux11.22. * tune/many.pl (mul_2): Add speed routine settings. (MAKEFILE): Close when done, for the benefit of development hackery. 2003-06-08 Kevin Ryde * mpfr/*: Update to mpfr cvs 2003-06-08. * mpn/x86/x86-defs.m4 (femms): Remove fallback to emms. (cmovCC, psadbw): Remove simulated versions. (cmov_available_p, psadbw_available_p): Remove. This trickery was only ever for development purposes on machines without those instructions. Removing it simplifies gmp and in particular avoids complications for fat binary builds. Development can be done with a wrapper around "as" if really needed. * mpn/x86/divrem_1.asm: Don't use loop_or_decljnz, now K6 has its own mpn/x86/k6/divrem_1.asm. Amend K6 comments now moved to there. * mpn/x86/x86-defs.m4 (loop_or_decljnz): Remove, no longer used. * mpn/x86/k6/divrem_1.asm: New file, derived from mpn/x86/divrem_1.asm. * mpn/x86/k6/pre_mod_1.asm: Remove comments now in mpn/x86/mod_1.asm. * mpn/x86/mod_1.asm: Put mpn_mod_1c after mpn_mod_1 for better branch prediction. Put done_zero at end for less wastage in alignment. Use decl+jnz unconditionally since in fact it's ok on k6. Amend comments. 2003-06-07 Kevin Ryde * mpn/generic/mode1o.c: Fix ASSERTs on return value. * gmp.texi (Build Options): Add viac3 and viac32 cpu types. (ABI and ISA): Note on sparcv9 ABI=32 vs ABI=64 speed. More indexing. * configfsf.guess, configfsf.sub: Update to 2003-06-06. * config.guess: Remove $RANDOM hack supporting netbsd 1.4, not needed by new configfsf.guess. 2003-06-06 Torbjorn Granlund * mpn/ia64/submul_1.asm: Add branch over .align block. 2003-06-05 Torbjorn Granlund * longlong.h (add_ssaaaa) [pa64]: Output zero operand as register 0. Allow more immediate operands. (sub_ddmmss) [pa64]: Likewise. (add_ssaaaa) [pa32]: Likewise. (sub_ddmmss) [pa32]: Likewise. * mpn/pa64: Change ".level 2.0W" to ".level 2.0w" to please picky GNU assembler. 2003-06-05 Kevin Ryde * gmp.texi (Integer Special Functions): In mpz_array_init, fix type shown for integer_array and give an example use. 2003-06-04 Torbjorn Granlund * mpf/set_str.c (mpf_set_str): Work around gcc 2 bug triggered on alpha. 2003-06-03 Kevin Ryde * mpn/x86/pentium/README: Add 7 c/l mmx mul_1, tweak wordings. * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Use octal char constants in test program, hex is not supported by K&R. 2003-06-02 Torbjorn Granlund * mpn/mips64/divrem_1.asm: New file. 2003-06-01 Torbjorn Granlund * mpn/powerpc32/lshift.asm: Reformat code. * mpn/powerpc32/rshift.asm: Reformat code. 2003-05-30 Kevin Ryde * tests/misc.c (tests_start): Set stdout and stderr to unbuffered, to avoid any chance of losing output on segv etc. 2003-05-28 Torbjorn Granlund * mpf/get_str.c: Move label `done' to match TMP_MARK and TMP_FREE. Remove redundant variable prec. 2003-05-26 Torbjorn Granlund * tests/mpz/convert.c: Test bases up to 62. * tests/mpf/t-conv.c: Test bases up to 62. * demos/pexpr.c: Don't iterate to get accurate timing. * mpf/set_str.c (mpn_pow_1_highpart): Cleanup. * mp_dv_tab.c: Fix typo. * mpf/get_str.c: Rewrite (now sub-quadratic). 2003-05-22 Kevin Ryde * tests/mpn/t-divrem_1.c: New file. * tests/mpn/Makefile.am: Add it. 2003-05-22 Torbjorn Granlund * config.sub: Recognize viac3* processors. 2003-05-20 Torbjorn Granlund * mpn/sparc64/addmul_2.asm: New file. 2003-05-19 Torbjorn Granlund * configure.in: Recognize alphaev7* as alphaev67. * config.guess: Recognize viac3* processors. * configure.in: Set up path for viac3* processors. * acinclude.m4 (X86_PATTERN): Include viac3* processors. 2003-05-19 Kevin Ryde * tune/freq.c (freq_pstat_getprocessor): New function. (freq_all): Use it. * configure.in (AC_CHECK_HEADERS): Add sys/pstat.h. (AC_CHECK_FUNCS): Add pstat_getprocessor. 2003-05-15 Kevin Ryde * mpn/generic/mul_fft.c (mpn_mul_fft_decompose): Remove "inline", since the code is a bit too big. gcc doesn't actually inline when alloca (TMP_ALLOC) is used anyway. 2003-05-13 Kevin Ryde * gmp.texi (Notes for Particular Systems): Libtool directory is .libs not _libs for mingw dll. Reported by Andreas Fabri. 2003-05-07 Kevin Ryde * acinclude.m4 (GMP_PROG_CC_WORKS): Add code to generate sse2/xmm code from gcc -march=pentium4, to check the assembler supports that. (GMP_GCC_PENTIUM4_SSE2, GMP_OS_X86_XMM): New macros. * configure.in (pentium4-*-*): Use them to see if gcc -march=pentium4 (with sse2) is ok. 2003-05-06 Kevin Ryde * mpz/com.c: Rate size==0 as UNLIKELY, fix comment to mpn_add_1. * tune/freq.c (): Include only when needed for getsysinfo(), to avoid a problem with this file on AIX 5.1. 2003-05-03 Torbjorn Granlund * mpf/set_str.c: Do not ignore supposedly superfluous digits (in part reverting last change). 2003-05-03 Kevin Ryde * gmp.texi: Use @code for files in @cindex entries, it looks nicer than @file. * Makefile.am: Note gmp 4.1.1 and 4.1.2 version info. * configure.in, acinclude.m4 (GMP_CRAY_OPTIONS): New macro for Cray system setups, letting AC_REQUIRE do its job instead of a hard coded AC_PROG_EGREP. * config.guess: Amend fake RANDOM to avoid ". configfsf.guess" which segfaults on Debian "ash" 0.4.16. 2003-05-01 Kevin Ryde * configure.in (AC_CHECK_FUNCS): Add getsysinfo. (AC_CHECK_HEADERS): Add sys/sysinfo.h and machine/hal_sysinfo.h. * tune/freq.c (freq_getsysinfo): New function. (freq_all): Use it. (freq_sysctlbyname_i586_freq, freq_sysctlbyname_tsc_freq, freq_sysctl_hw_cpufrequency, freq_sysctl_hw_model): Set speed_cycletime before trying to print it, when verbose. 2003-04-28 Torbjorn Granlund * mpf/set_str.c: Major overhaul. (mpn_pow_1_highpart): New helper function, meat extracted from mpf_set_str. 2003-04-24 Kevin Ryde * acinclude.m4 (GMP_GCC_ARM_UMODSI): Quote result string against m4. * configure, ltmain.sh, aclocal.m4: Update to libtool 1.5. * longlong.h (add_ssaaaa) [all]: Remove first "%" commutative in each, since gcc only supports one per asm. * printf/doprnt.c: Add M for mp_limb_t. * tests/misc/t-printf.c: Exercise this. * tests/mpz/t-cmp_d.c: Test infinities. * tests/mpf/t-cmp_d.c: New file. * tests/mpf/Makefile.am: Add it. * mpz/cmp_d.c, mpz/cmpabs_d.c, mpf/cmp_d.c: NaN invalid, Inf bigger than any value. * mpz/set_d.c, mpq/set_d.c, mpf/set_d.c: Nan or Inf invalid. * configure.in (AC_CHECK_FUNCS): Add raise. * invalid.c: New file. * Makefile.am: Add it. * gmp-impl.h (__gmp_invalid_operation): Add prototype. (DOUBLE_NAN_INF_ACTION): New macro. * tests/trace.c, tests/tests.h (d_trace): New function. * tests/misc.c, tests/tests.h (tests_infinity_d): New function. * tests/misc.c (mpz_erandomb, mpz_errandomb): Use gmp_urandomm_ui. * tune/tuneup.c, tune/common.c, tests/devel/try.c: Cast various mp_size_t values for printf %ld in case mp_size_t==int. Use gmp_printf for mp_limb_t values. * gmp.texi (Nomenclature and Types): Add mp_exp_t, mp_size_t, gmp_randstate_t. Note ulong for bit counts and size_t for byte counts. Don't bother with @noindent. (Debugging): New valgrind is getting MMX/SSE. (Integer Comparisons): mpz_cmp_d and mpz_cmpabs_d on NaNs and Infs. (Float Comparison): mpf_cmp_d behaviour on NaNs and Infs. (Low-level Functions): Note with mpn_hamdist what hamming distance is. (Formatted Output Strings): Add type M. (Internals): Remove remarks on ulong bits and size_t bytes. Move int field remarks to ... (Integer Internals, Float Internals): ... here. 2003-04-19 Kevin Ryde * configure.in (*sparc*-*-* ABI=32): Add umul to extra_functions. * mpn/x86/p6/mul_basecase.asm: New file. 2003-04-18 Kevin Ryde * configure.in (m68060-*-*): Fallback to gcc -m68000 when -m68060 not available, and don't use mpn/m68k/mc68020 asm routines. (Avoids 32x32 mul and 64/32 div which trap to the kernel on 68060. Advice by Richard Zidlicky.) * mpn/m68k/README: Update notes on directory usage. * tests/cxx/Makefile.am (TESTS_ENVIRONMENT): Add a hack to let the test programs run with a shared libgmpxx on openbsd 3.2. * gmp.texi (Language Bindings): Add Guile. 2003-04-12 Kevin Ryde * configure.in (cygwin*, mingw*, pw32*, os2*): Add -Wl,--export-all-symbols to GMP_LDFLAGS, no longer the default in latest mingw and libtool. * acinclude.m4 (GMP_ASM_COFF_TYPE): New macro. * configure.in (x86s): Use it. * mpn/x86/x86-defs.m4 (COFF_TYPE): New macro. (PROLOGUE_cpu): Use it, for the benefit of mingw DLLs. * gmp-impl.h (mpn_copyi, mpn_copyd): Add __GMP_DECLSPEC. * gmp.texi (Known Build Problems): Remove windows test program .exe repeated built, fixed by new libtool. Remove MacOS C++ shared library creation, fixed by new libtool. (Notes for Package Builds, Known Build Problems): Remove DESTDIR notes on libgmpxx, fixed in new libtool. 2003-04-10 Torbjorn Granlund * configure.in: Match turbosparc. * config.guess: Recognize turbosparc (just for *bsd for now). 2003-04-09 Kevin Ryde * mpf/mul_ui.c [nails]: Call mpf_mul to handle v > GMP_NUMB_MAX. * tests/mpz/t-mul.c (main): Don't try FFT sizes when FFT disabled via MP_SIZE_T_MAX, eg. for nails. * tests/cxx/t-ternary.cc: Split up tests to help compile speed and memory usage. * tests/devel/try.c: Print seed under -R, add -E to reseed, use ulong for seed not uint. * gmp.texi: Add @: after various abbreviations, more index entries. (leftarrow): New macro, for non-tex. (Random State Initialization): Remove commented gmp_randinit_lc, not going to be implemented. (Random Number Algorithms): New section. (References): Add Matsumoto and Nishimura on Mersenne Twister, add Bertot, Magaud and Zimmermann on GMP Square Root. 2003-04-06 Kevin Ryde * tests/mpz/t-gcd_ui.c: New file. * tests/mpz/Makefile.am: Add it. * mpz/gcd_ui.c: Correction to return value on longlong limb systems, limb might not fit a ulong. 2003-04-04 Kevin Ryde * configure, aclocal.m4, ltmain.sh: Update to libtool cvs snapshot 2003-04-02. 2003-04-02 Kevin Ryde * configure.in (*-*-cygwin*): No longer force lt_cv_sys_max_cmd_len, libtool has addressed this now. (AC_PROVIDE_AC_LIBTOOL_WIN32_DLL): Remove this, libtool _LT_AC_LOCK no longer needs it. * acinclude.m4 (GMP_PROG_AR): Also set ac_cv_prog_AR and ac_cv_prog_ac_ct_AR when adding flags to AR, so they're not lost by libtool's call to AC_CHECK_TOOL. 2003-04-01 Kevin Ryde * configure, aclocal.m4, ltmain.sh: Update to libtool cvs snapshot 2003-03-31. * configure.in (AC_PROG_F77): Add a dummy AC_PROVIDE to stop libtool running F77 probes. * randlc2x.c (gmp_rand_lc_struct): Add comments about what exactly is in each field. (randseed_lc): Rename seedp to seedz to avoid confusion with seedp in the lc function. Suggested by Pedro Gimeno. (gmp_randinit_lc_2exp): Use __GMP_ALLOCATE_FUNC_TYPE. No need for "+1" in mpz_init2 of _mp_seed. Don't bother with mpz_init2 for _mp_a. 2003-03-29 Kevin Ryde * configure.in (m68k-*-*): Use -O2, no longer need to fallback to -O. * acinclude.m4 (GMP_GCC_M68K_OPTIMIZE): Remove macro. * configure.in (AC_CHECK_TYPES): Add notes on why tested. * gmp.texi (GMPrefu, GMPpxrefu, GMPreftopu, GMPpxreftopu): New macros, use them for all external references to get URLs into HTML output. (Random State Initialization): Add gmp_randinit_set. (Random State Miscellaneous): New section. 2003-03-29 Kevin Ryde * randbui.c, randmui.c: New files. * Makefile.am: Add them. * gmp-h.in (gmp_urandomb_ui, gmp_urandomm_ui): Add prototypes. * tests/rand/t-urbui.c, tests/rand/t-urmui.c: New files. * tests/rand/Makefile.am: Add them. * gmp-impl.h (gmp_randstate_srcptr): New typedef. (gmp_randfnptr_t): Add randiset_fn. * randiset.c: New file. * Makefile.am: Add it. * gmp-h.in (gmp_randinit_set): Add prototype. * randlc2x.c, randmt.c: Add gmp_randinit_set support. * tests/rand/t-iset.c: New file. * tests/rand/Makefile.am: Add it. * tests/misc.c, tests/tests.h (call_rand_algs): New function. 2003-03-27 Kevin Ryde * mpz/bin_uiui.c: Use plain "*" for kacc products rather than umul_ppmm since high not needed, except for an ASSERT now amended. 2003-03-26 Kevin Ryde * demos/expr/exprfr.c (cbrt, cmpabs, exp2, gamma, nextabove, nextbelow, nexttoward): New functions. * demos/expr/t-expr.c: Exercise these. * mpfr/*: Update to mpfr cvs 2003-03-26. * gmp-impl.h (MPZ_REALLOC): Use UNLIKELY, to expect no realloc. * tune/time.c (cycles_works_p): Scope variables down to relevant part to avoid warnings about unused. * configfsf.guess, configfsf.sub: Update to 2003-02-22. * config.guess: Fake a $RANDOM variable when running configfsf.guess, to workaround a problem on m68k NetBSD 1.4.1. * mpz/fac_ui.c: Remove unused variable "z1". * tune/freq.c (freq_irix_hinv): Allow "Processor 0" line from IRIX 6.5. 2003-03-24 Torbjorn Granlund * randlc2x.c (randget_lc): Remove write-only variable rn. * mpf/eq.c: Remove write-only variable usign. * gen-psqr.c (main): Remove write-only variable numb_bits. 2003-03-17 Torbjorn Granlund * Makefile.am (libgmp_la_SOURCES): Add mp_dv_tab.c. (libmp_la_SOURCES): Add mp_dv_tab.c. * mpn/alpha/invert_limb.asm: Add a few comments. * mp_dv_tab.c: New file, defining __gmp_digit_value_tab. * mpz/set_str.c: Get rid of function digit_value_in_base and use table __gmp_digit_value_tab instead. * mpz/inp_str.c: Likewise. * mpf/set_str.c: Likewise. * mpbsd/min.c: Likewise. * mpbsd/xtom.c: Likewise. * mpz/set_str.c: Allow bases <= 62. Return error for invalid bases. * mpz/inp_str.c: Likewise. * mpf/set_str.c: Likewise. * mpz/out_str.c: Likewise. * mpz/get_str.c: Likewise. * mpf/get_str.c: Likewise. * mpz/inp_str.c: Restructure to allocate more string space just before needed. * mpbsd/min.c: Likewise. * longlong.h (__udiv_qrnnd_c): Remove redundant casts. (32-bit sparc): Test HAVE_HOST_CPU_supersparc in addition to various sparc_v8 spellings. 2003-03-17 Kevin Ryde * mpfr/*: Update to mpfr cvs 2003-03-17. 2003-03-15 Kevin Ryde * Makefile.am (EXTRA_libgmp_la_SOURCES): Use this for TMP_ALLOC sources, instead of a libdummy.la. 2003-03-16 Torbjorn Granlund * config.guess: Recognize supersparc and microsparc for *BSD systems. Generalize some superscalar recognition patterns. 2003-03-14 Torbjorn Granlund * mpn/sparc64/udiv.asm: New file. 2003-03-13 Torbjorn Granlund * mpn/sparc64: Table cycle counts. Update some comments. * mpn/powerpc64/divrem_1.asm: New file. 2003-03-10 Torbjorn Granlund * mpn/generic/mul.c (mpn_mul): Don't blindly expect MUL_KARATSUBA_THRESHOLD to be a constant. 2003-03-07 Torbjorn Granlund * mpn/generic/mul.c (mpn_mul): New operand splitting code for avoiding cache misses when un >> MUL_KARATSUBA_THRESHOLD > vn. (MUL_BASECASE_MAX_UN): New #define, default to 500 for now. 2003-03-07 Kevin Ryde * Makefile.am: Put gmp.h and mp.h under $(exec_prefix)/include. * gmp.texi (Build Options): Add notes on this. Reported by Vincent Lefèvre. 2003-03-06 Kevin Ryde * configure.in (alpha*-*-* gcc): Add asm option before testing -mcpu, for the benefit of gcc 2.9-gnupro-99r1 on alphaev68-dec-osf5.1 which doesn't otherwise put the assembler in the right mode for -mcpu=ev6. 2003-03-05 Torbjorn Granlund * mpn/powerpc32/powerpc-defs.m4: Set up renaming for v registers. * mpz/powm.c (redc): Instead of repeated mpn_incr_u invocations, accumulate carries and add at the end. (mpz_powm): Trim tp allocation, now as redc doesn't need carry guard. 2003-02-25 Torbjorn Granlund * mpn/x86/pentium4/copyd.asm: Correct header comment. * mpn/arm/addmul_1.asm: Correct cycle counts. * mpn/arm/submul_1.asm: Likewise. 2003-02-20 Kevin Ryde * demos/factorize.c (factor_using_pollard_rho): Test k>0 to avoid infinite loop if k=0 and gcd!=1 reveals a factor. Reported by John Pongsajapan. * gmp.texi, fdl.texi: Update to FDL version 1.2. 2003-02-18 Torbjorn Granlund * mpn/arm/mul_1.asm: Fix typo introduced in last change. 2003-02-17 Torbjorn Granlund * mpn/ia64/gmp-mparam.h: Retune. * mpn/sparc64/copyi.asm: Add some header comments. * mpn/sparc64/copyd.asm: Likewise. * mpn/arm/mul_1.asm: Put vl operand last for umull/umlal. Add some header comments. * mpn/arm/addmul_1.asm: Rewrite. * mpn/arm/submul_1.asm: Rewrite. * mpn/arm/gmp-mparam.h: Retune. 2003-02-16 Torbjorn Granlund * mpn/arm/copyi.asm: New file. * mpn/arm/copyd.asm: New file. 2003-02-16 Kevin Ryde * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Tolerate incorrect last data byte seen on an arm system. 2003-02-15 Torbjorn Granlund * mpn/arm/gmp-mparam.h: Retune. 2003-02-13 Torbjorn Granlund * mpn/powerpc32/750/com_n.asm: Add more cycle counts. 2003-02-13 Kevin Ryde * configure.in (AC_PREREQ): Bump to 2.57. * configure.in, acinclude.m4 (GMP_GCC_WA_OLDAS): New macro, applying -Wa,-oldas only when necessary. * configure.in (powerpc*-*-*): Don't use -Wa,-mppc with gcc, it overrides options recent gcc adds for -mcpu, making generated code fail to assemble. * tune/tuneup.c (mpn_fft_table): Remove definition, it's in mul_fft.c. 2003-02-12 Torbjorn Granlund * mpn/x86/pentium4/sse2/gmp-mparam.h: Retune. * mpn/x86/k7/gmp-mparam.h: Retune. * mpn/x86/k6/gmp-mparam.h: Retune. * mpn/x86/p6/gmp-mparam.h: Retune. * mpn/x86/p6/mmx/gmp-mparam.h: Retune. * tests/mpz/t-mul.c (main): Rewrite FFT testing code. 2003-02-10 Torbjorn Granlund * config.guess: Recognize "power2" systems. * mpn/powerpc64/gmp-mparam.h: Fix indentation. * mpn/power/gmp-mparam.h: Retune. * mpn/alpha/ev6/nails/gmp-mparam.h: Retune. * mpn/sparc64/gmp-mparam.h: Retune. * mpn/pa64/gmp-mparam.h: Retune. * mpn/sparc32/v8/supersparc/gmp-mparam.h: Retune. * mpn/sparc32/v8/gmp-mparam.h: Retune. * mpn/mips64/gmp-mparam.h: Retune. * mpn/alpha/ev6/gmp-mparam.h: Retune. * mpn/powerpc32/gmp-mparam.h: Retune. * mpn/powerpc32/750/gmp-mparam.h: Retune. * mpn/alpha/ev5/gmp-mparam.h: Retune. * mpn/m68k/gmp-mparam.h: Retune. * mpn/cray/gmp-mparam.h: Set GET_STR_PRECOMPUTE_THRESHOLD. * configure.in: Undo this, problem doesn't happen any more: (mips64*-*-*): Pass just -O1 to cc, to work around compiler bug. 2003-02-03 Kevin Ryde * gmp-impl.h (MPN_NORMALIZE, MPN_NORMALIZE_NOT_ZERO): Add parens around macro parameters. Reported by Jason Moxham. 2003-02-01 Kevin Ryde * gmp.texi (Low-level Functions): No overlap permitted by mpn_mul_n. Reported by Jason Moxham. (Formatted Input Strings): Correction to strtoul cross reference formatting. (BSD Compatible Functions): Add index entry for MINT. 2003-01-29 Torbjorn Granlund * gmp-impl.h (mpn_mul_fft): Now returns int. 2003-01-29 Paul Zimmermann * mpn/generic/mul_fft.c: Major rewrite. 2003-01-25 Kevin Ryde * config.guess (powerpc*-*-*): Remove $dummy.core file when mfpvr fails on NetBSD. (trap): Remove $dummy.core on abnormal termination too. * mpfr/*: Update to mpfr cvs 2003-01-25. 2003-01-24 Torbjorn Granlund * mpn/ia64/README: Update cycle counts to match current code. 2003-01-18 Kevin Ryde * mpfr/*: Update to mpfr cvs 2003-01-18. 2003-01-17 Torbjorn Granlund * gmp.texi: Canonicalize URLs. 2003-01-15 Kevin Ryde * gmp.texi (Notes for Particular Systems): Add hardware floating point precision mode. * mpfr/*, configure, aclocal.m4, config.in: Update to mpfr cvs 2003-01-15. 2003-01-11 Kevin Ryde * mpfr/*: Update to mpfr cvs 2003-01-11. 2003-01-09 Kevin Ryde * mpfr/get_str.c: Update to mpfr cvs 2003-01-09. * doc/configuration: Various updates. 2003-01-06 Torbjorn Granlund * mpn/alpha/copyi.asm: Avoid `nop' mnemonic, unsupported on Cray. * mpn/alpha/copyd.asm: Likewise. 2003-01-05 Kevin Ryde * demos/expr/t-expr.c (check_r): Tolerate mpfr_set_str new return value. * configure, aclocal.m4 (*-*-osf4*, *-*-osf5*): Regenerate with libtool patch to avoid bash printf option problem when building shared libraries with cxx. * configure.in (pentium4-*-*): Use "-march=pentium4 -mno-sse2" since sse2 causes buggy code from gcc 3.2.1 and is only supported on new enough kernels. * acinclude.m4 (GMP_PROG_NM): Add some notes about failures, per report by Krzysztof Kozminski. * gmp-h.in (mpz_mdivmod_ui, mpz_mmod_ui): Add parens around "r". * gmp-h.in (__GMP_CAST): New macro, clean to g++ -Wold-style-cast. (GMP_NUMB_MASK, mpz_cmp_si, mpq_cmp_si, mpz_odd_p, mpn_divexact_by3, mpn_divmod): Use it. Reported by Krzysztof Kozminski. (mpz_odd_p): No need for the outermost cast to "int". * tests/cxx/t-cast.cc: New file. * tests/cxx/Makefile.am: Add it. 2003-01-04 Kevin Ryde * mpfr/set_str.c: Update to mpfr cvs 2003-01-04. * demos/expr/exprfra.c (e_mpfr_number): Tolerate recent mpfr_set_str returning count of characters accepted. 2003-01-03 Torbjorn Granlund * mpn/alpha/copyi.asm: New file. * mpn/alpha/copyd.asm: New file. 2003-01-03 Kevin Ryde * demos/expr/t-expr.c: Use __gmpfr on some mpfr internals that have changed. * mpfr/*, aclocal.m4, config.in, configure: Update to mpfr cvs 2003-01-03. * gmp.texi (Introduction to GMP): Mention release announcements mailing list, and put home page and ftp before mailing lists. 2002-12-28 Torbjorn Granlund * mpn/generic/mul_fft.c (mpn_fft_next_size): Simplify. 2002-12-28 Kevin Ryde * acinclude.m4 (M68K_PATTERN): New macro. (GMP_GCC_M68K_OPTIMIZE): Use it to avoid m6811 and friends. * configure.in: Ditto. * tests/mpz/t-import.c, tests/mpz/t-export.c: Use '\xHH' to avoid warnings about char overflows. * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Ditto. 2002-12-28 Pedro Gimeno * randmt.c (randseed_mt, default_state): Fix off-by-one bug on padding. (randseed_mt): Add ASSERT checking result of mpz_export. 2002-12-24 Kevin Ryde * gmp.texi (Integer Import and Export): Clarify treatment of signs, reported by Kent Boortz. * randmt.c: Use gmp_uint_least32_t. (randseed_mt): Add nails to mpz_export in case mt[i] more than 32 bits. * gmp-impl.h (gmp_uint_least32_t): New typedef, replacing GMP_UINT32. * configure.in (AC_CHECK_TYPES): Add uint_least32_t. (AC_CHECK_SIZEOF): Add unsigned short. 2002-12-22 Kevin Ryde * gmp-impl.h (ULONG_PARITY) [generic C]: Mask result to a single bit. (ULONG_PARITY) [_CRAY, __ia64]: New macros. * tests/t-parity.c: New test. * tests/Makefile.am (check_PROGRAMS): Add it. * longlong.h (count_trailing_zeros) [ia64]: New macro. * tests/t-count_zeros.c (check_various): Remove unused variable "n". * mpn/x86/README: Revise notes on PIC, PLT and GOT. * demos/perl/GMP.xs, demos/perl/GMP.pm, demos/perl/test.pl: Add "mt" to GMP::Rand::randstate. 2002-12-22 Pedro Gimeno * randmt.c (randseed_mt): Fix bug that might cause the generator to return all zeros with certain seeds. Fix WARM_UP==0 case. (gmp_randinit_mt): Initialize to a known state by default. (randget_mt): Remove check for uninitialized buffer: no longer needed. (recalc_buffer): Use ?: instead of two-element array. * tests/rand/t-mt.c: New test. * tests/rand/Makefile.am (check_PROGRAMS): Add it. 2002-12-21 Kevin Ryde * cxx/osdoprnti.cc: Use and rather than and . No need for . * demos/expr/expr.c, demos/expr/exprfa.c, demos/expr/exprfra.c, demos/expr/exprza.c: Use mp_get_memory_functions, not __gmp_allocate_func etc. * demos/expr/t-expr.c: Don't use gmp-impl.h. (numberof): New macro. * gmp-h.in, gmp-impl.h (__gmp_allocate_func, __gmp_reallocate_func, __gmp_free_func): Move declarations to gmp-impl.h * mp_get_fns.c: New file. * Makefile.am (libgmp_la_SOURCES, libmp_la_SOURCES): Add it. * gmp-h.in (mp_get_memory_functions): Add prototype. * gmp.texi (Custom Allocation): Add mp_get_memory_functions, refer to "free" not "deallocate" function. * gmpxx.h (struct __gmp_alloc_cstring): Use mp_get_memory_functions, not __gmp_free_func. * gmp-impl.h [__cplusplus]: Add for strlen. (gmp_allocated_string): Hold length in a field. * cxx/osdoprnti.cc, cxx/osmpf.cc: Use this. 2002-12-20 Torbjorn Granlund * tests/mpz/t-perfsqr.c (check_sqrt): Print more variables upon failure. * mpn/generic/rootrem.c: In Newton loop, pad qp with leading zero. 2002-12-19 Torbjorn Granlund * mpn/generic/rootrem.c: Allocate 1.585 (log2(3)) times more space for pp temporary to allow for worst case overestimate of root. Add some asserts. * tests/mpz/t-root.c: Generalize and speed up. 2002-12-19 Kevin Ryde * tests/cxx/t-rand.cc (check_randinit): Add gmp_randinit_mt test. * gmp-h.in: Don't bother trying to support Compaq C++ in pre-standard I/O mode. * gmp.texi (Notes for Particular Systems): Compaq C++ must be used in "standard" iostream mode. 2002-12-18 Torbjorn Granlund * mpn/alpha/mod_34lsub1.asm: Add code for big-endian, using existing little-endian code only if HAVE_LIMB_LITTLE_ENDIAN is defined. 2002-12-18 Kevin Ryde * configure.in (HAVE_LIMB_BIG_ENDIAN, HAVE_LIMB_LITTLE_ENDIAN): New defines in config.m4. 2002-12-17 Torbjorn Granlund * printf/printffuns.c (gmp_fprintf_reps): Make it actually work for padding > 256. 2002-12-17 Kevin Ryde * tune/freq.c: Add for memcmp. * mpz/pprime_p.c: Use MPN_MOD_OR_MODEXACT_1_ODD. * gmp.texi (Formatted Output Strings): %a and %A are C99 not glibc. (Formatted Input Strings): Type "l" is for double too. Hex floats are accepted for mpf_t. (Formatted Input Functions): Describe tightened parse rule, clarify return value a bit. * scanf/doscan.c: Add hex floats, tighten matching to follow C99, for instance "0x" is no longer acceptable to "%Zi". Rename "invalid" label to avoid "invalid" variable, SunOS cc doesn't like them the same. * tests/misc/t-scanf.c: Update tests. * tests/misc/t-locale.c (check_input): Don't let "0x" appear from fake decimal point. * config.guess (sparc*-*-*): Look at BSD sysctl hw.model to recognise ultrasparcs. * mpfr/tests/dummy.c: New file. * mpfr/tests/Makefile.am (libfrtests_a_SOURCES): Add it. 2002-12-14 Kevin Ryde * mpbsd/Makefile.am (nodist_libmpbsd_la_SOURCES): Move these mpz sources to libmpbsd_la_SOURCES directly, automake 1.7.2 now gets the ansi2knr setups right for sources in other directories. * mpfr/tests/Makefile.am: Add libfrtests.a in preparation for new mpfr. 2002-12-13 Kevin Ryde * mpfr/Makefile.am (mpfr_TEXINFOS, AM_MAKEINFOFLAGS): Allow for fdl.texi in recent mpfr. * configure.in (AC_PROG_EGREP): Ensure this is run outside the Cray conditional AC_EGREP_CPP. * configure.in (alpha*-*-*): Use gcc -Wa,-oldas if it works, to avoid problems with new compaq "as" on OSF 5.1. * mpn/Makefile.am (EXTRA_DIST): Remove Makeasm.am, automake 1.7.2 does it automatically. * acinclude.m4 (AC_LANG_FUNC_LINK_TRY(C)): Remove this hack, fixed by autoconf 2.57. * configure.in (AC_CONFIG_LIBOBJ_DIR): Set to mpfr, for the benefit of new mpfr using LIBOBJ. * configure.in: (AM_INIT_AUTOMAKE): Use "gnu no-dependencies $(top_builddir)/ansi2knr". * */Makefile.am (AUTOMAKE_OPTIONS): Remove, now in configure.in. * configure, config.in, INSTALL.autoconf: Update to autoconf 2.57. * */Makefile.in, configure, aclocal.m4, install-sh, mkinstalldirs: Update to automake 1.7.2. * gmp.texi (Build Options): Add hppa64 to cpu types. (ABI and ISA): Add gcc to hppa 2.0. (Debugging): Add maximum debuggability config options. (Language Bindings): Add Arithmos, reported by Johan Vervloet. (Formatted Output Strings): 128 bits is about 40 digits, ll is only for long long not long double. (Formatted Input Strings): ll is only for long long not long double. * mpz/divis.c, mpz/divis_ui.c, mpz/cong.c, mpz/cong_ui.c: Allow d=0, under the rule n==c mod d iff exists q satisfying n=c+q*d. * gmp.texi (Integer Division): Describe this. Suggested by Jason Moxham. 2002-12-13 Pedro Gimeno * randlc2x.c (lc): Remove check for seedn < an, which is now superfluous. Add ASSERT to ensure it's correct. Add ASSERT to check precondition of __GMPN_ADD. (gmp_randinit_lc_2exp): Avoid reallocation by allocating one extra bit for both seed and a. Simplify seedn < p->_cn case. * tests/rand/t-lc2exp.c (check_bigs): Test negative seeds. 2002-12-12 Torbjorn Granlund * mpn/pa32/pa-defs.m4 (PROLOGUE_cpu): Zap spurious argument to `.proc'. Add empty `.callinfo'. 2002-12-11 Torbjorn Granlund * mpn/x86/pentium4/sse2/addmul_1.asm: Don't reuse `ret' symbol for a label. 2002-12-11 Kevin Ryde * configure.in (hppa*-*-*): Don't use gcc -mpa-risc-2-0 in ABI=1.0. * mpn/pa32/pa-defs.m4: New file, arranging for .proc/.procend. * configure.in (hppa*-*-*): Use it. * printf/doprnt.c: Comments on "ll" versus "L". * tests/mpz/t-div_2exp.c: Reduce tests, especially the random ones. 2002-12-11 Torbjorn Granlund * mpz/get_d.c (limb2dbl): New macro for conversion to `double'. Define it to something non-trivial for 64-bit hppa. * mpq/get_d.c: Likewise. * mpf/get_d.c: Likewise. * mpn/x86/pentium4/sse2/addmul_1.asm: Unroll to save one c/l. 2002-12-09 Kevin Ryde * tune/Makefile.am: Don't use -static under --disable-static, it tends not to work. * configure.in (ENABLE_STATIC): New AM_CONDITIONAL. * gmp-h.in: Use instead of with Compaq C++ in pre-standard I/O mode. * tests/mpz/t-jac.c, tests/mpz/t-scan.c: Reduce tests. 2002-12-08 Kevin Ryde * configure.in (*-*-ultrix*): Remove forcible --disable-shared, believe this was a generic problem with libtool, now gone. 2002-12-08 Torbjorn Granlund * gmp-impl.h (USE_LEADING_REGPARM): Disable for PIC code generation. 2002-12-07 Torbjorn Granlund * tests/cxx/t-misc.cc (check_mpq): Use 0/1 for canonical 0 in mpq_cmp_ui calls. * configure.in (hppa2.0*-*-*): Pass +O2 instead of +O3 to work around compiler bug with mpfr/tests/tdiv. 2002-12-07 Kevin Ryde * configure.in (hppa2.0*-*-* ABI=2.0n): Make -mpa-risc-2-0 optional. New hppa-level-2.0 test using GMP_HPPA_LEVEL_20 to detect assembler support for 2.0n. * acinclude.m4 (GMP_PROG_CC_WORKS): Add code that provokes an error from gcc -mpa-risc-2-0 if the assembler doesn't know 2.0 instructions. (GMP_HPPA_LEVEL_20): New macro. 2002-12-07 Pedro Gimeno * gmp-impl.h (gmp_randfnptr_t.randseed_fn) Return void. (LIMBS_PER_ULONG, MPN_SET_UI): New macros. (MPZ_FAKE_UI): Rename couple of parameters. * randlc2x.c (gmp_rand_lc_struct): _mp_c and _mp_c_limbs replaced with mpn style _cp and _cn. All callers changed. (randseed_lc): Fix limbs(seed) > bits_to_limbs(m2exp) case. Remove return value. (gmp_randinit_lc_2exp): Attempt to avoid redundant reallocation. * randmt.c (mangle_seed): New function by Kevin. (randseed_mt): Use it instead of mpz_powm, for performance. Remove return value. Remove commented out code (an inferior alternative to mpz_export). * randsdui.c (gmp_randseed_ui): Use MPZ_FAKE_UI. * tests/rand/t-lc2exp.c (check_bigm, check_bigs): New tests. * tests/rand/t-urndmm.c: Add L to constants in calls, for K&R. 2002-12-06 Torbjorn Granlund * configure.in: Remove -g. (hppa*-*-*): Pass -Wl,+vnocompatwarnings with +DA2.0. 2002-12-05 Torbjorn Granlund * mpn/pa64/sqr_diagonal.asm: Remove .entry, .proc, .procend. * mpn/pa64/udiv.asm: Likewise. 2002-12-05 Kevin Ryde * mpn/pa64/sub_n.asm: Remove space in "sub, db" which gas objects to. * mpn/pa64/*.asm, tune/hppa2.asm: Use ".level 2.0" for 2.0n, since gas doesn't like ".level 2.0N". * configure.in (hppa*-*-*): Group path and flags choices, for clarity. (hppa1.0*-*-*): Use gcc -mpa-risc-1-0 when available. (hppa2.0*-*-*): Ditto -mpa-risc-2-0. (*-*-hpux*): Exclude ABI=2.0w for hpux[1-9] and hpux10, rather than the converse of allowing it for hpux1[1-9]; ie. list the bad systems rather than try to guess the good systems. (hppa2.0*-*-*) [ABI=2.0n ABI=2.0w]: Add gcc to likely compilers. (hppa*-*-*) [gcc]: Test sizeof(long) to differentiate a 32-bit or 64-bit build of the compiler. (hppa64-*-*): Add this as equivalent to hppa2.0-*-*. * acinclude.m4 (GMP_C_TEST_SIZEOF): New macro. * tests/tests.h (ostringstream::str): Must null-terminate ostrstream::str() for the string constructor. 2002-12-04 Torbjorn Granlund * mpn/pa32/hppa1_1/udiv.asm: Don't wrap symbol to INT64 in L() stuff. * longlong.h (mpn_udiv_qrnnd_r based udiv_qrnnd): Fix typo. * mpn/powerpc32/powerpc-defs.m4: Define float registers with `f' prefix. 2002-12-04 Kevin Ryde * gmp.texi (Floating-point Functions): Note the mantissa is binary and decimal fractions cannot be represented exactly. Suggested by Serge Winitzki. (Known Build Problems): Note libtool stripping options when linking. Reported by Vincent Lefevre. * acinclude.m4 (GMP_ASM_LABEL_SUFFIX): Don't make an empty result a failure, that's a valid result. (GMP_ASM_GLOBL): Establish this from the host cpu type. (IA64_PATTERN): New macro. (GMP_PROG_EXEEXT_FOR_BUILD, GMP_C_FOR_BUILD_ANSI, GMP_CHECK_LIBM_FOR_BUILD): Remove temporary files created. * configure.in: Use IA64_PATTERN. 2002-12-03 Torbjorn Granlund * tune/hppa.asm: Use config.m4. * tune/hppa2.asm: Likewise. * tune/hppa2w.asm: Likewise. * mpn/pa64: Use LDEF. 2002-12-03 Kevin Ryde * INSTALL: Use return rather than exit in the example programs. Suggested by Richard Dawe. * gmp.texi (Build Options): Move non-unix notes to ... (Notes for Particular Systems): ... here. Mention MS Interix, reported by Paul Leyland. (C++ Interface Random Numbers): Add gmp_randinit_mt to examples. * acinclude.m4 (GMP_ASM_LABEL_SUFFIX): Must test empty suffix first, for the benefit of hppa hp-ux. (GMP_ASM_UNDERSCORE): Grep the output of "nm" instead of trying to construct an asm file, and in case of failure fallback on no underscore and a warning. * longlong.h (count_leading_zeros, count_trailing_zeros) [ev67, ev68]: Restrict __asm__ ctlz and cttz to __GNUC__. * gen-psqr.c (HAVE_CONST, const): New macros. * tests/cxx/t-rand.cc (check_randinit): Add gmp_randinit_mt. 2002-12-02 Torbjorn Granlund * gmp-impl.h: Split popc_limb again, combined version gives too many compiler warnings. 2002-12-01 Torbjorn Granlund * mpn/generic/gcdext.c (div1): Disable unused function. * mpz/root.c: Don't include stdlib.h or longlong.h. * mpz/rootrem.c: Likewise. * extract-dbl.c: abort => ASSERT_ALWAYS. * mpz/set_d.c: Likewise. * mpn/generic/tdiv_qr.c: Likewise. * gen-psqr.c (f_cmp_fraction, f_cmp_divisor): Change parameter to `const void *', to match qsort spec. 2002-12-01 Kevin Ryde * gmp.texi (Integer Division): Fix a couple of @math's for tex. Use @dots in more places. * tests/cxx/t-locale.cc: Test non std::locale systems too. * tests/cxx/clocale.c: New file, reinstating what was localeconv.c, and subverting nl_langinfo too. * tests/cxx/Makefile.am (t_locale_SOURCES): Add it. * tests/tests.h (ostringstream, istringstream): Provide fakes of these if not available. * tests/cxx/t-locale.cc, tests/cxx/t-ostream.cc: Remove . * configure.in (AC_CHECK_HEADERS) [C++]: Add . 2002-11-30 Torbjorn Granlund * printf/doprnt.c (__gmp_doprnt): Comment out a `break' to shut up compiler warnings. * mpn/ia64/invert_limb.asm: Add `many' hints to return insns. * mpn/ia64/divrem_1.asm: Allocate more local registers; put b0 in one of them. * mpn/ia64/popcount.asm: Properly restore register ar.lc. * longlong.h (umul_ppmm) [ia64]: Form both product parts in asm. * mpz/bin_uiui.c: Cast umul_ppmm operands. * scanf/doscan.c (gmpscan): Remove unused label store_get_digits. * gmp-impl.h: #undef MIN and MAX before #defining. * mpn/ia64/copyi.asm: Add `;' after bundle declarators. * mpn/ia64/copyd.asm: Likewise. * mpn/ia64/divrem_1.asm: Add some syntax to placid the HP-UX assembler. 2002-11-30 Kevin Ryde * configure.in (AC_CHECK_HEADERS): Add nl_types.h. * tests/misc/t-locale.c: Use this, for nl_item on netbsd 1.4.1. 2002-11-29 Torbjorn Granlund * tests/devel/addmul_1.c: Provide prototype for mpn_print. (OPS): Account for function overhead. * tests/devel/{submul_1.c,mul_1.c,add_n.c,sub_n.c}: Likewise. * mpn/ia64/addmul_1.asm: Rewrite. 2002-11-28 Torbjorn Granlund * mpn/ia64/sqr_diagonal.asm: Don't allocate any registers. * mpn/ia64/submul_1.asm: Adapt to Itanium 2. * mpn/ia64/mul_1.asm: Fix typo in HAVE_ABI_32 code. * mpn/ia64/add_n.asm: Rewrite. * mpn/ia64/sub_n.asm: Rewrite. 2002-11-28 Kevin Ryde * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Use this rather than libdummy. * tests/Makefile.am (EXTRA_libtests_la_SOURCES): Use this for x86call.asm and x86check.c rather than libdummy. 2002-11-27 Torbjorn Granlund * tests/mpz/t-mul.c: Implement reference Karatsuba multiplication. Rewrite testing scheme to run fewer really huge tests. 2002-11-26 Torbjorn Granlund * tests: Decrease repetition count for some of the slowest tests. * mpn/ia64/divrem_1.asm: New file. 2002-11-25 Torbjorn Granlund * mpfr/tests/tdiv.c: Decrease number of performed tests. 2002-11-23 Torbjorn Granlund * mpn/ia64/mul_1.asm: Rewrite. 2002-11-23 Kevin Ryde * mpn/ia64/README: Add some references. * gmp.texi (Build Options): Add itanium and itanium2, mention DocBook and XML from makeinfo, add texinfo top level cross reference. (Integer Division): Try to clarify 2exp functions a bit. (C++ Interface Floats): Giving bad string to constructor is undefined. (C++ Interface Integers, C++ Interface Rationals): Ditto, and show default base in prototype, not the description. * config.sub, config.guess, configure.in (itanium, itanium2): New cpu types. * tests/misc/t-printf.c, tests/misc/t-scanf.c (check_misc): Suppress %zd test on glibc prior to 2.1, it's not supported. 2002-11-22 Torbjorn Granlund * mpn/ia64/copyi.asm: Optimize for Itanium 2. * mpn/ia64/copyd.asm: Likewise. 2002-11-20 Torbjorn Granlund * mpn/ia64/sqr_diagonal.asm: New file. * mpn/ia64/submul_1.asm: Handle vl == 0 specially. 2002-11-20 Kevin Ryde * tests/cxx/t-locale.cc: Test with locales imbued into stream, use , eliminated some C-isms. istream tests disabled, not yet locale-ized. * tests/cxx/Makefile.am (t_locale_SOURCES): Remove localeconv.c. * tests/cxx/localeconv.c: Remove file. * configure.in (AC_CHECK_TYPES) [C++]: Add std::locale. * printf/doprntf.c: Add decimal point parameter, remove localeconv use. * gmp-impl.h (__gmp_doprnt_mpf): Update prototype, bump symbol to __gmp_doprnt_mpf2 to protect old libgmpxx. * cxx/osmpf.cc: Use this with ostream locale decimal_point facet. * printf/doprnt.c: Ditto, with GMP_DECIMAL_POINT. * gmp-h.in: More comments on __declspec for windows DLLs. * mpf/set_str.c, scanf/doscan.c: Cast through "unsigned char" for decimal point string, same as input chars. * configure.in (AC_CHECK_HEADERS): Add langinfo.h. (AC_CHECK_FUNCS): Add nl_langinfo. * gmp-impl.h (GMP_DECIMAL_POINT): New macro. * mpf/out_str.c, mpf/set_str.c, scanf/doscan.c: Use it, and don't bother with special code for non-locale systems. * tests/misc/t-locale.c: Subvert nl_langinfo too. * configure.in, acinclude.m4 (GMP_ASM_X86_GOT_UNDERSCORE): New macro. * mpn/x86/x86-defs.m4 (_GLOBAL_OFFSET_TABLE_): New macro, inserting extra underscore for OpenBSD. * mpn/x86/README (_GLOBAL_OFFSET_TABLE_): Update notes. Reported by Christian Weisgerber. * tests/cxx/t-rand.cc (check_randinit): New function, collecting up constructor tests. * tests/cxx/t-ostream.cc: Use instead of , use compare instead of strcmp. * gmpxx.h (__gmp_randinit_lc_2exp_size_t): Return type is int. 2002-11-18 Kevin Ryde * tune/speed.c (r_string): Use CNST_LIMB with bits, spotted by Torbjorn. 2002-11-19 Torbjorn Granlund * mpn/ia64/mul_1.asm: Remove redundant cmp from prologue code. Streamline prologue. * mpn/ia64/addmul_1.asm: Likewise. * mpn/ia64/submul_1.asm: New file. * mpn/ia64/submul_1.c: Remove. 2002-11-17 Torbjorn Granlund * mpn/generic/popham.c: New file, using new faster algorithm. * mpn/generic/popcount.c: Remove. * mpn/generic/hamdist.c: Remove. * mpn/ia64/addmul_1.asm: Don't clobber callee-saves register f16. * mpn/ia64/mul_1.asm: Likewise. * mpn/ia64/addmul_1.asm: Add pred.rel declarations. Resolve RAW hazards for condition code registers, duplicating code as needed. Add prediction to all branches. * mpn/ia64/mul_1.asm: Likewise. * mpn/ia64/add_n.asm: Likewise. * mpn/ia64/sub_n.asm: Likewise. * mpn/ia64/copyi.asm: Likewise. * mpn/ia64/copyd.asm: Likewise. * mpn/generic/random2.c: Add a cast to silence some compilers. 2002-11-16 Torbjorn Granlund * mpz/powm.c: Cap allocation by limiting k to 10 (512 precomputed values). 2002-11-16 Kevin Ryde * configure.in, gmp.texi: Remove powerpc64 ABI=32L, doesn't work and is unlikely to ever do so. * configure.in: Allow ABI=32 for powerpc64. Reported by David Edelsohn. 2002-11-14 Kevin Ryde * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Add addmul_2.c addmul_3.c addmul_4.c addmul_5.c addmul_6.c addmul_7.c addmul_8.c. * gmp-h.in (__GMP_DECLSPEC_EXPORT, __GMP_DECLSPEC_IMPORT) [__GNUC__]: Use __dllexport__ and __dllimport__ to keep out of application namespace. 2002-11-14 Gerardo Ballabio * gmpxx.h (__gmp_randinit_default_t, __gmp_randinit_lc_2exp_t, __gmp_randinit_lc_2exp_size_t): Use extern "C" { typedef ... }, for the benefit of g++ prior to 3.2. 2002-11-12 Kevin Ryde * gmpxx.h (gmp_randclass constructors): Patch from Roberto Bagnara to use extern "C" on C function pointer arguments. 2002-11-09 Kevin Ryde * configure.in, Makefile.am, printf/Makefile.am, printf/repl-vsnprintf.c: Handle vsnprintf replacement with C conditionals. * acinclude.m4 (AC_LANG_FUNC_LINK_TRY(C)): Workaround troubles recent HP cc +O3 causes for AC_CHECK_FUNCS. * gmp.texi (Notes for Particular Systems): Add Sparc app regs. (Debugging): Note gcc -fstack options to detect overflow. (Formatted Output Strings, Formatted Input Strings): Format strings are not multibyte. 2002-11-06 Torbjorn Granlund * mpn/generic/tdiv_qr.c: Remove a bogus assert. 2002-11-05 Torbjorn Granlund * mpn/generic/tdiv_qr.c: Remove two dead mpn_divrem_2 calls. 2002-11-04 Kevin Ryde * acinclude.m4 (GMP_C_INLINE): Don't define "inline" for C++. * demos/expr/expr-impl.h (stdarg.h): Test __DECC same as gmp.h. * mpbsd/mtox.c, printf/obprintf.c, printf/obvprintf.c, scanf/vsscanf.c, demos/expr/expr.c, demos/expr/exprf.c, demos/expr/exprfa.c, demos/expr/exprfr.c, demos/expr/exprq.c, demos/expr/exprz.c, demos/expr/exprza.c: Add for strlen and memcpy. 2002-11-02 Kevin Ryde * longlong.h: Test __x86_64__ not __x86_64. Reported by Andreas Jaeger. * mpz/import.c, mpz/export.c: Use char* subtract from NULL to get pointer alignment, for the benefit of Cray vector systems. * cxx/ismpf.cc: Use . * tests/cxx/t-locale.cc: No need to conditionalize . * scanf/doscan.c: Don't use isascii, rely on C99 ctype.h. * gmp.texi (Build Options): Describe CC_FOR_BUILD, cross reference texinfo manual. (ABI and ISA): Add powerpc620 and powerpc630 to powerpc64, add NetBSD and OpenBSD sparc64. (Notes for Package Builds): Cross reference libtool manual. (Notes for Particular Systems): Add OpenBSD to non-MMX versions of gas. (Known Build Problems): Add MacOS X C++ shared libraries. 2002-10-31 Kevin Ryde * gmp-impl.h, tune/speed.c, tune/speed.h, tune/common.c, tune/many.pl, tests/devel/try.c, tests/tests.h, tests/refmpn.c (mpn_addmul_5, mpn_addmul_6, mpn_addmul_7, mpn_addmul_8): Add testing and measuring. * configure.in (config.in): Add #undefs of HAVE_NATIVE_mpn_addmul_5, HAVE_NATIVE_mpn_addmul_6, HAVE_NATIVE_mpn_addmul_7, HAVE_NATIVE_mpn_addmul_8. (gmp_mpn_functions_optional): Add addmul_5 addmul_6 addmul_7 addmul_8. * tests/devel/try.c (ASSERT_CARRY): Remove, now in gmp-impl.h (try_one): Do dest setups after sources, for benefit of dst0_from_src1. 2002-11-01 Torbjorn Granlund * mpn/generic/tdiv_qr.c: Avoid quadratic behaviour for sub-division when numerator is more than twice the size of the denominator. Simplify loop logic for the same case. Clean up a few comments. 2002-10-29 Torbjorn Granlund * configure.in (*-cray-unicos*): Pass -hnofastmd again. 2002-10-25 Torbjorn Granlund * tests/tadd.c: Disable test of denorms. 2002-10-23 Linus Nordberg * gmp.texi (Introduction to GMP): Update section about mailing lists. 2002-10-23 Kevin Ryde * gmp-h.in (__GMP_ATTRIBUTE_PURE): Suppress this when __GMP_NO_ATTRIBUTE_CONST_PURE is defined. * gmp-impl.h (ATTRIBUTE_CONST): Ditto. * tune/common.c: Use __GMP_NO_ATTRIBUTE_CONST_PURE. * tune/speed.h, tune/many.pl: Remove ATTRIBUTEs from prototypes. * tune/speed.h: Remove various "dummy" variables attempting to keep "pure" calls live, no longer necessary. They weren't sufficient for recent MacOS cc anyway. 2002-10-21 Torbjorn Granlund * mpn/cray/ieee/addmul_1.c: Handle overlap as in mul_1.c. * mpn/cray/ieee/submul_1.c: Likewise. 2002-10-19 Kevin Ryde * configure.in (sparcv9 etc -*-*bsd*): Add support for NetBSD and OpenBSD sparc64. Reported by Christian Weisgerber. (AC_CHECK_HEADERS): Add sys/param.h for sys/sysctl.h on *BSD. * demos/calc/calc.y: Change ={ to {, needed for bison 1.50. * longlong.h (count_leading_zeros, count_trailing_zeros) [x86_64]: Should be UDItype. * mpz/set_str.c, mpf/set_str.c, mpbsd/xtom.c, scanf/sscanffuns.c: Cast chars through "unsigned char" to zero extend, required by C99 ctype.h. 2002-10-18 Torbjorn Granlund * tests/mpz/t-root.c: Test also mpz_rootrem. * mpn/generic/rootrem.c: Avoid overflow problem when n is huge. * mpz/root.c: Avoid overflow problems in allocation computation; also simplify it. Misc cleanups. * mpz/rootrem.c: New file. * Makefile.am, mpz/Makefile.am, gmp-h.in: Add them. 2002-10-17 Torbjorn Granlund * gmp-impl.h (popc_limb): Combine variants. 2002-10-14 Kevin Ryde * configure.in (AC_CHECK_HEADERS): Add sys/time.h for sys/resource.h test, needed by SunOS, and next autoconf will insist headers actually compile. 2002-10-08 Kevin Ryde * tune/time.c (speed_time_init): Allow for Cray times() apparently being a cycle counter. * dumbmp.c (mpz_get_str): Fix buf size allocation. * tests/trace.c, tests/tests.h (mp_limb_trace): New function. * tune/speed-ext.c (SPEED_EXTRA_PROTOS): Use __GMP_PROTO. * tests/devel/try.c (malloc_region): Add a cast for SunOS cc. * configure.in (AC_CHECK_FUNCS): Add strerror. (AC_CHECK_DECLS): Add sys_errlist, sys_nerr. * tune/time.c, tests/devel/try.c: Use them. 2002-10-05 Kevin Ryde * configure.in (AC_CHECK_HEADERS): Test float.h, not in SunOS cc. * printf/repl-vsnprintf.c: Use this. * configure.in (*sparc*-*-*): Collect up various options for clarity, use gcc -mcpu=supersparc and ultrasparc3, use cc -xchip, don't use -xtarget=native, use cc configs with acc, merge SunOS bundled cc and SunPRO cc configs. * gmp-impl.h (gmp_randfnptr_t): Use __GMP_PROTO. (MPZ_REALLOC): Cast _mpz_realloc return value to mp_ptr, for the benefit of SunOS cc which requires pointers of the same type on the two legs of a ?:. * dumbmp.c (mpz_realloc): Add a cast to avoid a warning from SunOS cc. * acinclude.m4: Allow for i960 b.out default cc output. * gmp.texi (Random State Initialization): Add gmp_randinit_mt. (Perfect Square Algorithm): Describe new mpn_mod_34lsub1 use. (Factorial Algorithm): Describe Jason's new code. (Binomial Coefficients Algorithm): Ideas about improvements moved to doc/projects.html. (Contributors): Add Jason Moxham and Pedro Gimeno. 2002-10-03 Kevin Ryde * gen-psqr.c: New file. * Makefile.am, mpn/Makefile.am: Use it to generate mpn/perfsqr.h. * mpn/generic/perfsqr.c: Use generated data, put mod 256 data into limbs to save space, use mpn_mod_34lsub1 when good. * tests/mpn/t-perfsqr.c: New file. * tests/mpn/Makefile.am (check_PROGRAMS): Add it. * tests/mpz/t-perfsqr.c (check_modulo): New test. (check_sqrt): New function holding current tests. * configure.in (AC_INIT): Modernize to package name and version here rather than AM_INIT_AUTOMAKE, add bug report email. (AC_CONFIG_SRCDIR): New macro. * gmp-impl.h (ROUND_UP_MULTIPLE): Fix for non-power-of-2 moduli (not normal in current uses), clarify the comments a bit. 2002-09-30 Kevin Ryde * mpn/Makeasm.am (.s.lo): Add --tag=CC for the benefit of CCAS!=CC, same as .S.lo and .asm.lo. * Makefile.am (gen-fac_ui, gen-fib, gen-bases): Quote source files in test -f stuff to avoid Sun make rewriting them. 2002-09-28 Kevin Ryde * tests/devel/try.c, tune/speed.c: Avoid strings longer than C99 guarantees. * tests/refmpn.c, tests/tests.h (refmpn_zero_extend, refmpn_normalize, refmpn_sqrtrem): New functions. * tests/devel/try.c (TYPE_SQRTREM): Use refmpn_sqrtrem. (compare): Correction to tr->dst_size subscripting. * dumbmp.c: Add several new functions, allow for initial n * dumbmp.c (mpz_pow_ui, mpz_addmul_ui, mpz_root): New functions. * gen-fac_ui.c: New file. * mpz/fac_ui.c: Rewrite. 2002-09-26 Kevin Ryde * tests/cxx/localeconv.c: New file, split from t-locale.cc. * tests/cxx/t-locale.cc: Use it. * tests/cxx/Makefile.am (t_locale_SOURCES): Add it. * tests/cxx/Makefile.am: Updates for Gerardo's new test programs. 2002-09-26 Gerardo Ballabio * gmpxx.h (__gmp_cmp_function): Bug fixes in double/mpq and double/mpfr comparisons. * tests/cxx/t-assign.cc, tests/cxx/t-binary.cc, tests/cxx/t-constr.cc, tests/cxx/t-ternary.cc, tests/cxx/t-unary.cc: Revise and add various tests, including some for mpfr, some split from t-expr.cc. * tests/cxx/t-locale.cc: Modernize include files. * tests/cxx/t-ostream.cc: Modernize include files, use cout rather than printf for diagnostics. * tests/cxx/t-misc.cc, tests/cxx/t-rand.cc: New file, split from t-allfuns.cc. * tests/cxx/t-ops.cc: New file, some split from t-allfuns.cc. * tests/cxx/t-prec.cc: New file. * tests/cxx/t-allfuns.cc, tests/cxx/t-expr.cc: Remove files. 2002-09-25 Torbjorn Granlund * configure.in (*-cray-unicos*): Remove -hscalar0, it causes too much performance loss. Let's trust Cray to fix their compilers. 2002-09-24 Torbjorn Granlund * mpn/powerpc32/add_n.asm: Rewrite. * mpn/powerpc32/sub_n.asm: Rewrite. 2002-09-24 Pedro Gimeno * randlc2x.c: Prepare for nails by changing type of _mp_c to mpz_t, make _mp_seed fixed-size, disallow SIZ(a)==0 to optimize comparisons for mpn_mul. * gmp-impl.h (MPZ_FAKE_UI): New macro. * randmt.c: Some constants made long for K&R compliance; remove UL at the end of other constants; use mp_size_t where appropriate; use mpz_export to split the seed. * gmp-impl.h: Remove type cast in RNG_FNPTR and RNG_STATE, to allow them to be used as lvalues. * randclr.c, randlc2x.c, randmt.c, randsd.c: All callers changed. * mpz/urandomm.c: Replace mpn_cmp with MPN_CMP. * tests/rand/gen.c: Get rid of gmp_errno. 2002-09-24 Kevin Ryde * gmp.texi (Custom Allocation): Keep allocate_function etc out of the function index by using @deftypevr. More index entries. 2002-09-24 Gerardo Ballabio * gmpxx.h (mpfr_class constructors from strings): Precision was set incorrectly, fixed. 2002-09-23 Torbjorn Granlund * mpf/urandomb.c: Don't crash for overlarge nbits argument. Let nbits==0 mean to fill number with random bits. 2002-09-21 Torbjorn Granlund * mpn/alpha/mod_34lsub1.asm: Add r31 dummy operand to `br' instruction. 2002-09-20 Gerardo Ballabio * gmpxx.h (__gmp_binary_equal, __gmp_binary_not_equal): Fix broken mpq/double functions. 2002-09-18 Torbjorn Granlund * randmt.c (randget_mt): Fix typo. 2002-09-18 Kevin Ryde * gmp-impl.h (_gmp_rand): Avoid evaluating "state" more than once, for the benefit places calling it with RANDS. * randmt.c (randseed_mt): Use mpz_init for mod and seed1, for safety. * tune/tuneup.c (sqr_karatsuba_threshold): Initialize to TUNE_SQR_KARATSUBA_MAX so mpn_sqr_n works for randmt initialization. * gmp.texi (Integer Comparisons): Remove mention of non-existent mpz_cmpabs_si, reported by Conrad Curry. * tune/speed.c, tune/speed.h, tune/common.c: Add gmp_randseed, gmp_randseed_ui and mpz_urandomb. 2002-09-18 Pedro Gimeno * tests/rand/gen.c: Add mt, remove lc and bbs. * Makefile.am (libgmp_la_SOURCES): Add randmt.c, remove randlc.c and randraw.c. * randmt.c: New file. * gmp-h.in (gmp_randinit_mt): Add prototype. * randdef.c: Use gmp_randinit_mt. * gmp-impl.h (RNG_FNPTR, RNG_STATE): New macros. (gmp_randfnptr_t): New structure. (_gmp_rand): Now a macro not a function. * gmp-h.in (__gmp_randata_lc): Remove, now internal to randlc2x.c. (__gmp_randstate_struct): Revise comments on field usage. * randsd.c, randclr.c: Use function pointer scheme. * randsdui.c: Use gmp_randseed. * randraw.c: Remove file. * randlc2x.c: Collect up lc_2exp related code from randsd.c, randclr.c and randraw.c, use function pointer scheme, integrate seed==0/a==0 into main case and fix case where bits(a) < m2exp. * randlc.c: Remove file, never documented and never worked. * gmp-h.in (gmp_randinit_lc): Remove prototype. 2002-09-16 Torbjorn Granlund * mpn/alpha/mod_34lsub1.asm: New file. 2002-09-16 Kevin Ryde * configure.in, acinclude.m4 (GMP_C_RESTRICT): Remove this, not currently used, and #define restrict upsets Microsoft C headers on win64. Reported by David Librik. * configure.in (x86): Add gcc 3.2 -march and -mcpu flags, remove some unnecessary -march=i486 fallbacks. * gmp.texi (Notes for Particular Systems): Note cl /MD is required for Microsoft C and MINGW to cooperate on I/O. Explained by David Librik. (Language Bindings): Add linbox. * gmp.texi (Language Bindings): 2002-09-12 Kevin Ryde * mpz/aorsmul_i.c: Allow for w==x overlap with nails. Test BITS_PER_ULONG > GMP_NUMB_BITS rather than GMP_NAIL_BITS != 0. * tests/mpz/t-aorsmul.c: Test this. * tune/common.c: mpn_mod_34lsub1 only exists for GMP_NUMB_BITS%4==0 * tune/speed.c: Add mpn_mod_34lsub1. 2002-09-10 Pedro Gimeno * rand.c: Remove old disabled BBS code. * mpf/urandomb.c: Use BITS_TO_LIMBS. 2002-09-10 Kevin Ryde * gmp.texi (Multiplication Algorithms): FFT is now enabled by default. 2002-09-10 Pedro Gimeno * mpz/urandomm.c: Use mpn level functions, avoid an infinite loop if _gmp_rand forever returns all "1" bits. * tests/rand/t-urndmm.c: New file * tests/rand/Makefile.am (check_PROGRAMS): Add it. * gmp-impl.h (BITS_TO_LIMBS): New macro. * mpz/urandomb.c: Use it, and use MPZ_REALLOC. 2002-09-08 Kevin Ryde * acinclude.m4 (GMP_GCC_WA_MCPU): New macro. * configure.in (alpha*-*-*): Use it to avoid -Wa,-mev67 if gas isn't new enough to know ev67. Reported by David Bremner. 2002-07-30 Gerardo Ballabio * gmpxx.h (__gmpz_value etc): Remove, use mpz_t etc instead. (__gmp_expr): Reorganise specializations, use __gmp_expr not mpz_class etc. (mpfr evals): Remove mode parameter, was always __gmp_default_rounding_mode anyway. 2002-09-07 Kevin Ryde * gmp-h.in, mp-h.in: Use #ifdef for tests, for the benefit of applications using gcc -Wundef. * longlong.h: Define COUNT_LEADING_ZEROS_NEED_CLZ_TAB for all alphas, since mpn/alpha/cntlz.asm always goes into libgmp.so, even for ev67 and ev68 which don't need it. Reported by David Bremner. * gmp.texi (Demonstration Programs): New section, expanding on what was under "Build Options". (Converting Floats): Don't need \ for _ in @var within @math. Add and amend various index entries. * demos/qcn.c: Add -p prime limit option. 2002-08-30 Kevin Ryde * mpz/pprime_p.c: Handle small negatives with isprime, in particular must do so for n==-2. * tests/mpz/t-pprime_p.c: New file. * tests/mpz/Makefile.am: Add it. 2002-08-26 Torbjorn Granlund * gmp.texi (Converting Floats): Fix typo in mpf_get_d_2exp docs, reported by Paul Zimmermann. 2002-08-26 Kevin Ryde * configure.in: Echo the ABI being tried for the compilers. (powerpc*-*-*): Use powerpc64/aix.m4 for ABI=aix64 too. (AC_CHECK_FUNCS): Add strtol, for tests/rand/gen.c. 2002-08-24 Kevin Ryde * configure.in (HAVE_HOST_CPU_, HAVE_HOST_CPU_FAMILY_, HAVE_NATIVE_): Setup templates for these using AH_VERBATIM rather than acconfig.h, preferred by latest autoconf. Prune lists to just things used. * acconfig.h: Remove file. * mpn/powerpc32/mode1o.asm: Forgot ASM_START. * tune/time.c (have_cgt_id): Renamed from HAVE_CGT_ID so avoid confusion with autoconf outputs, and turn it into a "const" variable. 2002-08-23 Torbjorn Granlund * configure.in: Choose powerpc32/aix.m4 or powerpc64/aix.m4 based on ABI, not configuration triple. * mpz/pprime_p.c: Partially undo last change--handle small and negative numbers in the same test. 2002-08-22 Kevin Ryde * gmp-impl.h (MUL_FFT_THRESHOLD, SQR_FFT_THRESHOLD): Note mpn/generic/mul_fft.c is not nails-capable, and don't bother setting other FFT data for nails. * configfsf.guess: Update to 2002-08-19. * configfsf.sub: Update to 2002-08-20. * config.guess (powerpc*-*-*): Use a { } construct to suppress SIGILL message on AIX. 2002-08-20 Kevin Ryde * gmp.texi (Build Options): Add ia64 under cpu types. (ABI and ISA): Describe IRIX 6 ABI=o32. (Notes for Particular Systems): Remove -march=pentiumpro, now ok. (Known Build Problems): Binutils 2.12 is ok for libgmp.a. (Emacs): New section. (Language Bindings): Update MLton URL, reported by Stephen Weeks. (Prime Testing Algorithm): New section. Don't put a blank line after @item in @table since it can make a page break between the heading and the entry. Misc tweaks elsewhere, in particular more index entries. * mpz/millerrabin.c: Need x to be size+1 for change to urandomm. * gmp-impl.h: Comments on the use of __GMP_DECLSPEC. * tune/time.c (freq_measure_mftb_one): Use struct_timeval, for the benefit of mingw. * tests/refmpn.c, tests/tests.h (ref_addc_limb, ref_subc_limb): Renamed from add and sub, following gmp-impl.h ADDC_LIMB and SUBC_LIMB. 2002-08-17 Kevin Ryde * mpn/powerpc32/mode1o.asm: New file. * configure.in, acinclude.m4 (GMP_ASM_POWERPC_PIC_ALWAYS): New macro. * mpn/asm-defs.m4: Use it to help setting up PIC. * configure.in (AC_PREREQ): Bump to 2.53. * mpn/powerpc32/powerpc-defs.m4 (ASSERT): New macro. (PROLOGUE_cpu): New macro, giving ALIGN(4) not 8. 2002-08-16 Torbjorn Granlund * mpn/m68k/lshift.asm: Fix typo in !scale_available_p code. * mpn/m68k/rshift.asm: Likewise. 2002-08-16 Kevin Ryde * configure.in (--enable-profiling=instrument): New option. * gmp.texi (Profiling): Describe it. * mpn/x86/x86-defs.m4 (PROLOGUE_cpu, call_instrument, ret_internal): Add support. (call_mcount): Share PIC setups with call_instrument. * mpn/x86/*.asm: Use ret_internal. * mpn/asm-defs.m4 (m4_unquote): New macro. * tests/mpn/t-instrument.c: New file. * tests/mpn/Makefile.am: Add it. * mpn/alpha/umul.asm: Add ASM_END. 2002-08-12 Kevin Ryde * mpz/pprime_p.c: Fake up a local mpz_t to take abs(n), rather than using mpz_init etc. * mpz/millerrabin.c: Use mpz_urandomm for uniform selection of x, reported by Jason Moxham. Exclude x==n-1, ie. -1 mod n. Use gmp_randinit_default. * mpn/alpha/umul.asm: Use "r" registers, for the benefit of Unicos. * tests/devel/try.c: Add mpn_copyi and mpn_copyd. 2002-08-09 Kevin Ryde * Makefile.am: Remove configure.lineno from DISTCLEANFILES and gmp.tmp from MOSTLYCLEANFILES, automake does these itself now. * */Makefile.in, aclocal.m4, configure, install-sh, missing, mkinstalldirs: Update to automake 1.6.3. * mpn/ia64/README: Some notes on assembler syntax. * mpn/ia64/add_n.asm, mpn/ia64/sub_n.asm: Add .body. * mpn/ia64/add_n.asm, mpn/ia64/addmul_1.asm, mpn/ia64/mul_1.asm, mpn/ia64/sub_n.asm: Position .save ar.lc just before relevant instruction. * mpn/ia64/addmul_1.asm, mpn/ia64/mul_1.asm: Add .save ar.pfs and pr. * mpn/ia64/copyd.asm, mpn/ia64/copyi.asm: Correction to .body position. * mpn/ia64/lorrshift.asm: Add .prologue stuff. * configure.in (*-*-unicos*): Remove forcible --disable-shared, libtool gets this right itself now. 2002-08-07 Kevin Ryde * mpn/x86/pentium/mmx/hamdist.asm: New file, adapted from mpn/x86/pentium/mmx/popham.asm. * mpn/x86/pentium/mmx/popham.asm: Remove file, not faster than plain mpn/x86/pentium/popcount.asm for the popcount. * mpn/alpha/umul.asm: Use PROLOGUE/EPILOGUE, rename it mpn_umul_ppmm. * configure.in (alpha*-*-*): Add umul to extra_functions. * mpz/remove.c: Make src==0 return 0, not do DIVIDE_BY_ZERO. 2002-08-05 Torbjorn Granlund * acconfig.h: Remove spurious undefs for mpn_divrem_newton and mpn_divrem_classic. 2002-08-05 Kevin Ryde * tests/refmpn.c, tests/tests.h, tests/misc/t-printf.c, tests/mpf/t-trunc.c, tests/mpn/t-mp_bases.c, tests/mpn/t-scan.c, tests/mpq/t-cmp_ui.c, tests/mpz/bit.c, tests/mpz/t-aorsmul.c, tests/mpz/t-powm_ui.c tests/mpz/t-root.c, tests/mpz/t-scan.c: More care with long and mp_size_t parameters, for the benefit of K&R. * demos/perl/GMP.pm, demos/perl/GMP.xs, demos/perl/GMP/Mpz.pm, demos/perl/test.pl: Add mpz_import and mpz_export. * demos/perl/GMP.pm: Remove "preliminary" warning. * mpn/lisp/gmpasm-mode.el: Set add-log-current-defun-header-regexp to pick up m4 defines etc. * Makefile.am (libgmpxx_la_DEPENDENCIES): libgmp.la should be here, not libgmpxx_la_LIBADD, for the benefit of "make -j2". * mpn/ia64/*.asm [hpux ABI=32]: Extend 32-bit operands to 64-bits, not optimal and might not be sufficient, but seems to work. 2002-08-03 Kevin Ryde * gmp.texi (Profiling): Use a table and expand for clarity. (Integer Special Functions): New section for mpz_array_init, _mpz_realloc, mpz_getlimbn and mpz_size, to discourage their use. * configure.in (*-*-msdosdjgpp*): Remove forcible --disable-shared, libtool gets this right itself now. 2002-07-30 Kevin Ryde * mpn/powerpc32/lshift.asm, mpn/powerpc32/rshift.asm: Lose final mr, and make final stwu into an stw. * gmp.texi (Known Build Problems): An easier workaround for DESTDIR, using LD_LIBRARY_PATH. (C++ Interface MPFR): Remove mpfrxx.h. * mpfrxx.h: Remove file. * Makefile.am: Remove mpfrxx.h. * tests/cxx/Makefile.am: Add Gerardo's new test programs. 2002-07-30 Gerardo Ballabio * gmpxx.h: Use mpz_addmul etc for ternary a+b*c etc. Reorganise some macros for maintainability. Merge mpfrxx.h. * tests/cxx/t-constr.cc, tests/cxx/t-expr.cc: Various updates. * tests/cxx/t-assign.cc, tests/cxx/t-binary.cc, tests/cxx/t-ternary.cc, tests/cxx/t-unary.cc: New files. 2002-07-27 Kevin Ryde * longlong.h (count_trailing_zeros) [ia64 __GNUC__]: Don't use __builtin_ffs for now, doesn't seem to work. * configure.in: Establish CONFIG_SHELL to avoid a problem with AC_LIBTOOL_SYS_MAX_CMD_LEN on ia64-*-hpux*. * tune/speed.h (SPEED_ROUTINE_MPN_GCD_FINDA): Don't let calls to mpn_gcd_finda go dead. * mpn/generic/tdiv_qr.c: Inline mpn_rshift and MPN_COPY of 2 limbs. 2002-07-24 Kevin Ryde * demos/primes.c: Use __GMP_PROTO and don't use signed, for the benefit of K&R. * demos/calc/calclex.l: Add for strcmp. * mpn/ia64/invert_limb.asm: Use .rodata which works on ia64-*-hpux* and should be standard, rather than worrying about RODATA. * gmp.texi (Function Classes): Add cross references. (Integer Import and Export): Fix return value grouping. * mpn/lisp/gmpasm-mode.el (gmpasm-comment-start-regexp): Add // for ia64. Add notes on what the various styles are for. * mpn/ia64/default.m4 (ASM_START): Define to empty, not dnl, so as not to kill text on the same line. (EPILOGUE_cpu): Force a newline after "#", so as not to suppress macro expansion in the rest of the EPILOGUE line. 2002-07-21 Kevin Ryde * tune/speed.h: Fix some missing _PROTOs. * Makefile.am (DISTCLEANFILES): Add configure.lineno. * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Define HAVE_DOUBLE_IEEE_BIG_ENDIAN and HAVE_DOUBLE_IEEE_LITTLE_ENDIAN in config.m4 too. * mpn/ia64/invert_limb.asm: Add big-endian data. * tests/mpz/t-jac.c (try_si_zi): Correction to "a" parameter type. 2002-07-20 Kevin Ryde * mpz/bin_ui.c, mpz/jacobi.c, mpz/pprime_p.c, mpn/generic/divis.c: More care with long and mp_size_t parameters, for the benefit of K&R. * gmp-impl.h (invert_limb): Use parens around macro arguments. (mpn_invert_limb): Give prototype and define unconditionally. * gmp-impl.h (CACHED_ABOVE_THRESHOLD, CACHED_BELOW_THRESHOLD): New macros. * mpn/generic/sb_divrem_mn.c: Use them to help gcc let preinv code go dead when not wanted. 2002-07-17 Kevin Ryde * tests/refmpz.c (refmpz_hamdist): Ensure mp_size_t parameters are that type, for the benefit of hpux ia64 bundled cc ABI=64. * configure.in (ia64*-*-hpux*): Need +DD64 in cc_64_cppflags to get the right headers for ansi2knr. * acinclude.m4 (GMP_TRY_ASSEMBLE, GMP_ASM_UNDERSCORE): Use $CPPFLAGS with $CCAS and when linking, as done by the makefiles. (GMP_ASM_X86_MMX, GMP_ASM_X86_SSE2): Show $CPPFLAGS in diagnostics. * gmp-impl.h (ieee_double_extract): Setup using HAVE_DOUBLE_IEEE_*. (GMP_UINT32): New define, 32 bit type for ieee_double_extract. * configure.in: Add AC_CHECK_SIZEOF unsigned. * configure.in, acinclude.m4 (GMP_IMPL_H_IEEE_FLOATS): Remove. (GMP_C_DOUBLE_FORMAT): Instead warn about unknown float here. * configure.in, acinclude.m4 (GMP_C_SIZES): Remove. * acinclude.m4 (GMP_INCLUDE_GMP_H_BITS_PER_MP_LIMB): Remove this scheme, not required. * configure.in (unsigned long, mp_limb_t): Run AC_CHECK_SIZEOF for these unconditionally, check mp_limb_t against gmp-mparam.h values. * gmp-impl.h (BYTES_PER_MP_LIMB, BITS_PER_MP_LIMB): Define based on SIZEOF_MP_LIMB_T if not provided by gmp-mparam.h. (BITS_PER_ULONG): Define here now. * gmp.texi (ABI and ISA): Add HP-UX IA-64 choices. (Random State Initialization): Typo in m2exp described for gmp_randinit_lc_2exp_size. (Formatted Output Functions): Clarify gmp_obstack_printf a bit. (Formatted Input Strings): Typo in %n summary. * mpz/inp_raw.c (NTOH_LIMB_FETCH): Use simple generic default, since endianness detection is now cross-compile friendly. * mpz/out_raw.c (HTON_LIMB_STORE): Ditto. * mpz/fib_ui.c: Nailify. * mpz/random.c: Nailify. * mpfr/acinclude.m4 (MPFR_CONFIGS): Patch by Vincent for an apparent float rounding gremlin on powerpc. 2002-07-15 Kevin Ryde * Makefile.am (PRINTF_OBJECTS): Avoid ending in a backslash, hpux ia64 make doesn't like that. * mpn/ia64/*.asm: Add .sptk to unconditional branches, add ";" after .mib etc, for the benefit of hpux. * configure.in (ia64*-*-*): Use ABI=64 on non-HPUX systems, for consistency. * gmp-impl.h (ieee_double_extract): Test __sparc__, used by gcc 3.1. Reported by nix@esperi.demon.co.uk. * mpfr/mpfr-math.h (_MPFR_NAN_BYTES etc): Ditto. 2002-07-13 Kevin Ryde * mpn/powerpc32/rshift.asm: Rewrite, transformed from lshift.asm. * tune/tuneup.c (DIVEXACT_1_THRESHOLD, MODEXACT_1_ODD_THRESHOLD): Always zero for native mpn_divexact_1, mpn_modexact_1_odd. * gmp-h.in (__GMP_EXTERN_INLINE): Don't use this during configure, ie. __GMP_WITHIN_CONFIGURE, to avoid needing dependent routines. * acinclude.m4 (GMP_H_EXTERN_INLINE): Consequent changes. * gmp-impl.h, mpn/asm-defs.m4 (mpn_addmul_2, mpn_addmul_3, mpn_addmul_4): Add prototypes and defines. * gmp.texi (Number Theoretic Functions): Clarify return value. Reported by Peter Keller. 2002-07-10 Kevin Ryde * configure.in, acinclude.m4 (GMP_PROG_LEX): Remove this in favour of AM_PROG_LEX, now ok when lex is missing. * longlong.h (count_leading_zeros) [pentiummmx]: Don't use __clz_tab variant under LONGLONG_STANDALONE. (count_trailing_zeros) [ia64 __GNUC__]: Use __builtin_ffs. * gmp-impl.h (popc_limb): Add an ia64 asm version. (DItype): Use HAVE_LONG_LONG to choose long long, avoiding _LONGLONG which is in gcc but means something unrelated in MS Visual C 7.0. Reported by David Librik. * mpz/divexact.c: Add an ASSERT that den divides num. * mpn/asm-defs.m4 (LDEF): New macro. (INT32, INT64): Use it. * mpn/pa32/*.asm: Use it. * mpn/pa32/README: Update notes on labels. * tests/refmpn.c, tests/tests.h, tests/t-bswap.c (ref_bswap_limb): Renamed from refmpn_bswap_limb. * tests/t-bswap.c: Add tests_start/tests_end for randomization. * tests/refmpn.c, tests/tests.h (ref_popc_limb): New function. * tests/t-popc.c: New file. * tests/Makefile.am: Add it. * mpn/ia64/invert_limb.asm: Use RODATA since ".section .rodata" is not accepted by ia64-*-hpux*. * acinclude.m4 (GMP_ASM_BYTE): New macro. (GMP_ASM_ALIGN_LOG, GMP_ASM_W32): Use it. (GMP_ASM_LABEL_SUFFIX): Use test compiles, not $host. (GMP_ASM_GLOBL): Ditto, and add .global for ia64-*-hpux*. (GMP_ASM_GLOBL_ATTR): Use GMP_ASM_GLOBL result, not $host. (GMP_ASM_LSYM_PREFIX): Allow any "a-z" nm symbol code, add ".text" to test program, required by ia64-*-hpux*. (GMP_ASM_LABEL_SUFFIX): Make LABEL_SUFFIX just the value, not a "$1:", the former being how it's currently being used in fact. * configure.in, acinclude.m4 (GMP_PROG_CC_WORKS_LONGLONG): New macro. * configure.in (ia64-*-hpux*): Add 32 and 64 bit ABI modes. 2002-07-06 Kevin Ryde * tests/cxx/t-allfuns.cc: New file. * tests/cxx/Makefile.am: Add it. * mpz/clrbit.c, mpz/setbit.c: Only MPN_NORMALIZE if high limb changes to zero. Use _mpz_realloc return value. * gmp.texi (Build Options, C++ Formatted Output, C++ Formatted Input): Cross reference to Headers and Libraries for libgmpxx stuff. (Low-level Functions): mpn_divexact_by3 result based on GMP_NUMB_BITS. mpn_set_str takes "unsigned char *", reported by Mark Sofroniou. (C++ Interface General): Describe linking with libgmpxx and libgmp. 2002-07-01 Kevin Ryde * tune/tuneup.c, gmp-impl.h: Eliminate the array of thresholds in one(), tune just one at a time and let the callers hand dependencies. Eliminate the second_start_min hack, handle SQR_KARATSUBA_THRESHOLD oddities in tune_sqr() instead. * mpn/pa64/umul.asm, mpn/pa64/udiv.asm, mpn/asm-defs.m4, acconfig.h, longlong.h, tune/speed.c, tune/speed.h, tune/common.c, tune/many.pl, tests/devel/try.c: Introduce mpn_umul_ppmm_r and mpn_udiv_qrnnd_r rather than having variant parameter order for mpn_umul_ppmm and mpn_udiv_qrnnd on pa64. * gmp-h.in (mpz_export): Remove a spurious parameter name. * gmp-impl.h (mpn_rootrem): Use __MPN. 2002-06-29 Kevin Ryde * longlong.h (udiv_qrnnd) [hppa32]: Remove mpn_udiv_qrnnd version, the general mechanism for that suffices. * mpf/inp_str.c: Fix returned count of chars read, reported by Paul Zimmermann. Also fix a memory leak for invalid input. * tests/mpf/t-inp_str.c: New file. * tests/mpf/Makefile.am (check_PROGRAMS): Add it. * tests/devel/try.c (mpn_mod_34lsub1): Only exists for GMP_NUMB_BITS%4==0. (SIZE2_FIRST): Respect option_firstsize2 for "fraction" case. * mpn/generic/diveby3.c: Further nailifications. * gmp-impl.h (MODLIMB_INVERSE_3): Allow for GMP_NUMB_BITS odd. (GMP_NUMB_CEIL_MAX_DIV3, GMP_NUMB_CEIL_2MAX_DIV3): New constants. * tests/t-constants.c: Check them. * gmp-h.in (__GMP_CRAY_Pragma): New macro. (__GMPN_COPY_REST): Use it. * gmp-impl.h (CRAY_Pragma): Use it. 2002-06-25 Kevin Ryde * mpz/import.c, mpz/export.c: Cast data pointer through "char *" in alignment tests, for the benefit of Cray vector systems. * configure.in (x86-*-*): Remove -march=pentiumpro check, seems ok with current code. * acinclude.m4 (GMP_GCC_MARCH_PENTIUMPRO, GMP_GCC_VERSION_GE): Remove macros, no longer needed * acinclude.m4 (GMP_ASM_RODATA): Remove temporary files. * configure.in (GMP_ASM_GLOBL_ATTR): Reposition to avoid duplication through AC_REQUIRE. 2002-06-23 Kevin Ryde * tests/mpz/t-fib_ui.c (check_fib_table): Check table values, not just that they're non-zero. * acinclude.m4 (GMP_GCC_ARM_UMODSI): Match bad "gcc --version" output exactly, rather than parsing it with GMP_GCC_VERSION_GE. (GMP_ASM_UNDERSCORE): Use GLOBL_ATTR. * mpn/pa32/udiv.asm, mpn/pa32/hppa1_1/udiv.asm, mpn/pa64/udiv.asm: Renamed from udiv_qrnnd.asm, for consistency with other udiv's. * mpn/pa64/umul.asm: Renamed from umul_ppmm.asm likewise. * configure.in (hppa*-*-*): Update extra_functions. (NAILS_SUPPORT): Remove umul_ppmm, udiv_qrnnd, udiv_fp, udiv_nfp from nails-neutral list, no longer needed. * gmp-h.in (__DECC): Add notes on testing this for ANSI-ness. (__GMP_EXTERN_INLINE): Add static __inline for DEC C. (mpz_mod_ui): Move up to main section, it's still documented. 2002-06-22 Kevin Ryde * mpz/jacobi.c, mpz/kronsz.c, mpz/kronuz.c, mpz/kronzs.c, mpz/kronzu.c: Allow for odd GMP_NUMB_BITS, tweak a few variable setups. * gmp-impl.h (JACOBI_STRIP_LOW_ZEROS): New macro. * mpn/generic/mod_34lsub1.c: Nailify. * tests/devel/try.c (CNST_34LSUB1): Nailify. * gmp-impl.h (ADDC_LIMB): New macro. * gmpxx.h (mpf_class::get_str): Make exponent mp_exp_t&, default base=10 and ndigits=0. (mpz_class::set_str, mpq_class::set_str, mpf_class::set_str): Add versions accepting "const char *". * mpfrxx.h (mpfr_class::get_str, mpfr_class::set_str): Ditto, and uncommenting set_str and operator=. * gmp.texi (C++ Interface Integers, C++ Interface Rationals) (C++ Interface Floats): Update. * gmp-impl.h (modlimb_invert): Merge the <=64bits and general versions. (const, signed): Move to near top of file, fixes --enable-alloca=debug on K&R. * gen-fib.c: New file, derived from mainline in mpn/generic/fib2_ui.c. * dumbmp.c (mpz_init_set_ui): New function. * Makefile.am, mpn/Makefile.am: Generate fib_table.h, mpn/fib_table.c. * gmp-impl.h: Use fib_table.h, add __GMP_DECLSPEC to __gmp_fib_table (for the benefit of tests/mpz/t-fib_ui.c). * mpn/generic/fib2_ui.c: Remove __gmp_fib_table and generating code. * Makefile.am: Add mp.h to BUILT_SOURCES, distclean all BUILT_SOURCES, use += more. * acinclude.m4 (GMP_ASM_M68K_INSTRUCTION, GMP_ASM_M68K_BRANCHES): Don't let "unknown" get into the cache variables. (GMP_ASM_TEXT): See what assembles, don't hard-code hpux and aix. (GMP_PROG_EXEEXT_FOR_BUILD): Add ,ff8 for RISC OS, per autoconf cvs. (GMP_PROG_CPP_FOR_BUILD): Restructure per AC_PROG_CPP, print correct result if CPP_FOR_BUILD overrides the cache variable. (GMP_PROG_CC_FOR_BUILD_WORKS): New macro split from GMP_PROG_CC_FOR_BUILD. Allow for "conftest" default compiler output. * configure.in, acinclude.m4 (GMP_PROG_HOST_CC): Reinstate this, separating HOST_CC establishment from GMP_PROG_CC_FOR_BUILD. * configure.in (mpn_objs_in_libgmp): Move mpn/mp_bases.lo ... * Makefile.am (MPN_OBJECTS): ... to here, add $U, and arrange MPN_OBJECTS to be common between libgmp and libmp. 2002-06-20 Torbjorn Granlund * mpn/generic/mul_n.c (TOOM3_MUL_REC, TOOM3_SQR_REC): Don't check if basecase is to be invoked when *_TOOM3_THRESHOLD is more than 3 times the corresponding *_THRESHOLD. 2002-06-20 Kevin Ryde * mpn/ia64/submul_1.c: Add missing TMP_DECL, TMP_MARK, TMP_FREE. Reported by Paul Zimmermann. * configure.in, acinclude.m4 (AC_DEFINE): Make templates read "Define to 1", for clarity as per autoconf. * acinclude.m4 (GMP_OPTION_ALLOCA): Group WANT_TMP templates. 2002-06-20 Gerardo Ballabio * gmpxx.h, mpfrxx.h: Remove mpz_classref, let mpq_class::get_num and mpq_class::get_den return mpz_class& as per the documentation. Reported by Roberto Bagnara. 2002-06-18 Kevin Ryde * tests/rand/t-lc2exp.c: New file. * tests/rand/Makefile.am: Add it, and use tests/libtests.la. * randraw.c (lc): Pad seed==0 case with zero limbs, return same (m2exp+1)/2 bits as normal, right shift "c" result as normal. * configure.in: Don't bother with line numbers in some diagnostics. (*-*-mingw*): Use -mno-cygwin if it works, suggested by delta trinity. * tests/mpz/Makefile.am, tests/mpq/Makefile.am, tests/misc/Makefile.am, (CLEANFILES): Set to *.tmp for test program temporaries, to get t-scanf.tmp and reduce future maintenance. 2002-06-16 Torbjorn Granlund * mpn/generic/get_str.c (mpn_dc_get_str): Pass scratch memory area in new `tmp' parameter. Trim allocation needs by reusing input parameter. 2002-06-15 Torbjorn Granlund * mpn/sparc32/v9/udiv.asm: New file. 2002-06-15 Kevin Ryde * acinclude.m4 (GMP_GCC_VERSION_GE): Correction to recognising mingw gcc 3.1 version number. Reported by Jim Fougeron. * configure.in (AC_PROVIDE_AC_LIBTOOL_WIN32_DLL): New define, to make AC_LIBTOOL_WIN32_DLL work with autoconf 2.53. * acinclude.m4 (GMP_C_SIZES): Establish BITS_PER_MP_LIMB as a value, not an expression, for the benefit of the gen-bases invocation. * config.guess (CC_FOR_BUILD): Try c99, same as configfsf.guess. 2002-06-15 Paul Zimmermann * mpfr/set_q.c: Allow for 1 bit numerator or denominator. 2002-06-14 Kevin Ryde * configure.in (AC_C_BIGENDIAN): Use new style action parameters. * randlc2x.c: Allow for a<0, allow for c>=2^m2exp. * randraw.c (lc): Allow for a==0. * mpn/sparc32/udiv.asm: Renamed from udiv_fp.asm. Don't know if float is the best way for v7, but it's what configure has chosen since gmp 3. * configure.in (*sparc*-*-* ABI=32): extra_functions="udiv" for all, in particular sparc32/v8/udiv.asm is faster (on ultrasparc2) than udiv_fp previously used for v9 chips. * gen-bases.c: New file, derived from mpn/mp_bases.c. * dumbmp.c: New file, mostly by Torbjorn, some by me. * configure.in, acinclude.m4 (GMP_PROG_CC_FOR_BUILD, GMP_PROG_CPP_FOR_BUILD, GMP_PROG_EXEEXT_FOR_BUILD, GMP_C_FOR_BUILD_ANSI, GMP_CHECK_LIBM_FOR_BUILD): New macros. (GMP_PROG_HOST_CC): Remove, superceded by GMP_PROG_CC_FOR_BUILD. * Makefile.am: Run gen-bases to create mp_bases.h and mpn/mp_bases.c. * gmp-impl.h: Use mp_bases.h. * mpn/mp_bases.c: Remove file. * mpn/Makefile.am: mp_bases.c now in nodist_libmpn_la_SOURCES. * tests/mpz/t-cmp_d.c (check_one_2exp): Use volatile to force to double, fixes gcc 3.1 with -O4. Reported by Michael Lee. * configure.in (AC_C_VOLATILE): New macro. * tests/misc/t-scanf.c: (fromstring_gmp_fscanf): Add missing va_end. Don't mix varargs and fixed args functions, not good on x86_64. Reported by Marcus Meissner. * Makefile.am (EXTRA_DIST): Remove mpfr/README, now in mpfr/Makefile.in * configure, config.in, INSTALL.autoconf: Update to autoconf 2.53. * */Makefile.in, install-sh, mdate-sh, missing, aclocal.m4, configure: Update to automake 1.6.1. * configfsf.guess, configfsf.sub: Update to 2002-05-29. 2002-06-12 Kevin Ryde * acinclude.m4 (GMP_GCC_VERSION_GE): Recognise mingw gcc 3.1 version. (GMP_PROG_CC_WORKS): Allow for a_out.exe, as per autoconf. (GMP_GCC_NO_CPP_PRECOMP, GMP_ASM_UNDERSCORE): Ditto, plus a.exe. 2002-06-09 Torbjorn Granlund * randraw.c (lc): Remove broken ASSERT_ALWAYS. * mpn/x86: Update gmp-mparam.h files with current measures *_THRESHOLD values. * mpn/x86/p6/mmx/gmp-mparam.h: New file. 2002-06-09 Kevin Ryde * mpn/x86/*/gmp-mparam.h (USE_PREINV_DIVREM_1): Add tuned settings. * acconfig.h (HAVE_NATIVE_mpn_preinv_divrem_1): New template. * tests/refmpn.c, tests/tests.h (refmpn_chars_per_limb, refmpn_big_base): New functions. * tests/mpn/t-mp_bases.c: Use them, and don't test big_base_inverted unless it's being used. * gmp.texi (Notes for Particular Systems): Using Microsoft C with DLLs. (Known Build Problems): Notes on MacOS and GCC. (Integer Logic and Bit Fiddling): Use ULONG_MAX for maximum ulong. (Low-level Functions): mpn_get_str accepts base==256. (Formatted Output Functions): Note output is not atomic. (Internals): Note mp_size_t for limb counts. * mp-h.in, gmp-h.in (mp_ptr, mp_srcptr, mp_size_t, mp_exp_t): Remove these types from mp.h, not needed. * mpfr/tests/tadd.c, mpfr/tests/tmul.c (check): Apply a hack to the parameter order to make sparc gcc 2.95.2 happy. * doc/configuration: Notes on bootstrapping. 2002-06-08 Kevin Ryde * mpfr/tests/tsqrt.c, mpfr/tests/tsqrt_ui.c: Suppress tests if sqrt is not affected by mpfr_set_machine_rnd_mode. * mpfr/mul_2si.c: Workaround a mips gcc 2.95.3 bug under -O2 -mabi=n32. * configure.in (alphev56): Fix to use ev5 path. 2002-06-06 Kevin Ryde * gmp-h.in: Use __gmp_const not const, in a number of places. * configure.in (sparc): Use ABI=32 instead of ABI=standard on v7 and v8, for consistency with v9 choices. (sparc64): Restrict GMP_ASM_SPARC_REGISTER to ABI=64. (x86): Move MMX $path munging to before printout. (CCAS): Move upward to support this. * gmp-impl.h (modlimb_invert): Merge macros for specific limb sizes, add a version for arbitrary limb size, use GMP_NUMB_BITS. (modlimb_invert, MODLIMB_INVERSE_3): Fix comments to say GMP_NUMB_BITS. * gmp-h.in (__GMP_LIKELY, __GMP_UNLIKELY): New macros. (mpz_getlimbn, mpz_perfect_square_p, mpz_popcount): Use them, make the fetch or mpn call likely, unconditionally calculate the alternative so as to avoid an "else" clause. * gmp-impl.h (LIKELY, UNLIKELY): Aliases. * configure.in, mpfr/tests/Makefile.am: Add $LIBM to $LIBS for MPFR_CONFIGS so it detects fesetround, and let it go through to $MPFR_LIBS. * mpfr/rnd_mode.c: Use gmp-impl.h to get MPFR_HAVE_FESETROUND. * tests/mpz/t-sizeinbase.c: Disable fake bits test, such pointer setups are bogus and have been seen failing on hppa. * tests/misc.c, tests/refmpz.c, tests.tests.h, tests/mpz/t-cong.c: Rename mpz_flipbit to refmpz_combit and move from misc.c to refmpz.c. 2002-06-05 Torbjorn Granlund * tests/mpz/t-powm_ui.c Print proper routine name in error message. 2002-06-03 Kevin Ryde * tune/time.c, tune/freq.c, tune/speed.h: Add powerpc mftb support. (FREQ_MEASURE_ONE): Move to speed.h, fix tv_sec factor. (freq_measure): Use for mftb measuring too. * tune/powerpc.asm, tune/powerpc64.asm: New files. * configure.in, tune/Makefile.am: Add them. * gmp-impl.h (popc_limb): Add versions for Cray and fallback for arbitrary limb size. * mpn/sparc32/sparc-defs.m4: New file. * configure.in (sparc*-*-*): Use it. * acinclude.m4 (GMP_ASM_SPARC_REGISTER): New macro. * configure.in (sparc64): Use it. Also, use -Wc,-m64 for linking. * mpn/sparc64/add_n.asm, mpn/sparc64/addmul_1.asm, mpn/sparc64/copyd.asm, mpn/sparc64/copyi.asm, mpn/sparc64/lshift.asm, mpn/sparc64/mul_1.asm, mpn/sparc64/rshift.asm, mpn/sparc64/sqr_diagonal.asm, mpn/sparc64/sub_n.asm, mpn/sparc64/submul_1.asm: Use REGISTER for .register. 2002-06-01 Kevin Ryde * mpz/powm_ui.c: Fix for result range in certain circumstances. * mpn/x86/k6/diveby3.asm: Speedup to 10 c/l, same as divexact_1. Anomaly pointed out by Alexander Kruppa. 2002-05-31 Torbjorn Granlund * mpz/export.c: Cast pointer via `unsigned long' when checking alignment to avoid compiler warnings. 2002-05-29 Kevin Ryde * gmp-impl.h (BSWAP_LIMB): Versions for m68k, powerpc, and arbitrary limb size. * configure.in, acconfig.h (HAVE_HOST_CPU_FAMILY_m68k): New define. 2002-05-27 Torbjorn Granlund * mpn/generic/mul_basecase.c: Improve MAX_LEFT handling, returning when possible. Add code for mpn_addmul_5 and mpn_addmul_6. 2002-05-25 Kevin Ryde * tune/tuneup.c: Misc nailifications, and disable preinv thresholds with nails. * tune/speed.h: Use GMP_NUMB_HIGHBIT with mpn_sb_divrem_mn and mpn_divrem_2. * mpz/powm.c (redc): Nailify q. * tests/mpn/t-scan.c: Reduce the amount of testing, to go faster. 2002-05-23 Torbjorn Granlund * Version 4.1 released. * mpn/alpha/ev6/nails/gmp-mparam.h: New file. * tests/devel/add_n.c (refmpn_add_n): Nailify. * tests/devel/sub_n.c (refmpn_sub_n): Nailify. * tests/devel/addmul_1.c (refmpn_addmul_1): Nailify. * tests/devel/submul_1.c (refmpn_submul_1): Nailify. * mpn/alpha/ev6/nails/add_n.asm: New file. * mpn/alpha/ev6/nails/sub_n.asm: New file. * mpn/alpha/ev6/nails/mul_1.asm: New file. * mpn/alpha/ev6/nails/submul_1.asm: New file. 2002-05-22 Torbjorn Granlund * mpn/alpha/ev6/nails/addmul_1.asm: New file. * mpz/inp_str.c (mpz_inp_str_nowhite): Nailify. * mpn/generic/mul_basecase.c: Update pointers before conditional MAX_LEFT break statements. 2002-05-21 Torbjorn Granlund * tests/mpz/t-gcd.c: Test mpz_gcd_ui. * mpz/lcm_ui.c: Nailify. * mpz/gcd_ui.c: Nailify. Make it work as documented, allowing NULL to be passed for result parameter. Fix gcd(0,0) case. * mpz/set_str.c: Nailify. * randlc2x.c (gmp_randinit_lc_2exp): Nailify. From Jakub Jelinek: * longlong.h (add_ssaaaa,sub_ddmmss) [64-bit sparc]: Make it actually work. 2002-05-18 Torbjorn Granlund * mpf/ui_div.c: Shut up compiler warning. * mpn/generic/mul_basecase.c: Use mpn_addmul_2, mpn_addmul_3, and mpn_addmul_4, as available. * mpn/alpha/ev6/nails/addmul_2.asm: Adjust NAILS_SUPPORT decls. * mpn/alpha/ev6/nails/addmul_3.asm: Likewise * mpn/alpha/ev6/nails/addmul_4.asm: Likewise. * configure.in (*-cray-unicos*): Back again to -hscalar0. (gmp_mpn_functions_optional): Add mul_3, mul_4, addmul_2, addmul_3, and addmul_4. * acconfig.h: Add #undefs for new optional mpn functions. 2002-05-18 Kevin Ryde * gmp.texi (Integer Import and Export): Mention Cray unfilled words. * mpz/set_d.c, mpq/set_d.c: Use LIMBS_PER_DOUBLE for the output of __gmp_extract_double. Reported by Henrik Johansson. 2002-05-17 Torbjorn Granlund * mpn/alpha/ev6/nails/addmul_2.asm: New file. * mpn/alpha/ev6/nails/addmul_3.asm: New file. * mpn/alpha/ev6/nails/addmul_4.asm: New file. * mpn/generic/dump.c: Rewrite and nailify. 2002-05-16 Kevin Ryde * mpfr/Makefile.am (EXTRA_DIST): Add BUGS file. 2002-05-15 Torbjorn Granlund * configure.in (*-cray-unicos*): Remove -hscalar0, add -hnofastmd as workaround for compiler bug. (mips64*-*-*): Pass just -O1 to cc, to work around compiler bug. 2002-05-14 Torbjorn Granlund * configure.in (*-cray-unicos*): Pass -hscalar0 to work around compiler bug for mpz/import.c. 2002-05-11 Torbjorn Granlund * mpz/import.c: Cast pointer via `unsigned long' when checking alignment to avoid compiler warnings. * mpn/generic/rootrem.c: Adjust allocation of qp temporary area. 2002-05-09 Kevin Ryde * mpz/import.c: Corrections to size store, special case tests, and general case ACCUMULATE. * tests/mpz/t-import.c, tests/mpz/t-export.c: More test data. 2002-05-09 Torbjorn Granlund * mpn/generic/rootrem.c: Use temp space for root, copy value in place before returning. * mpz/root.c: Don't allocate extra limb for root value. * mpz/perfpow.c: Undo last change. 2002-05-08 Torbjorn Granlund * gmp-impl.h (powerpc BSWAP_LIMB_FETCH): Rename local variable to make it not clash with caller. * mpn/generic/rootrem.c: New file. * configure.in (gmp_mpn_functions): Add rootrem and pow_1. * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Add rootrem.c and pow_1.c * gmp-impl.h (mpn_rootrem): Add declaration. * mpz/perfpow.c: Amend allocations for mpn_rootrem requirements. * mpz/root.c: Rewrite to use mpn_rootrem. 2002-05-08 Kevin Ryde * gmp-impl.h (MUL_KARATSUBA_THRESHOLD etc): Remove forced nail values. * mpf/fits_u.h, mpf/fits_s.h, tests/mpf/t-fits.c: Ignore fraction part, making the code match the documentation. * gmpxx.h (struct __gmp_binary_minus): Use mpz_ui_sub. 2002-05-07 Kevin Ryde * mpn/powerpc32/README: New file. * mpz/root.c: Use unsigned long with mpz_sub_ui not mp_limb_t. * tune/README: Misc updates including sparc32/v9 smoothness, low res timebase, and mpn_add_n operand overlaps. * tune/many.pl: Add udiv.asm support. * gmp.texi (Build Options): A couple of --build better as --host. (Known Build Problems, Notes for Package Builds): Add DESTDIR problem. (Compatibility with older versions): Compatible with 4.x versions. (Converting Integers): Remove mpz_get_ui + mpz_tdiv_q_2exp decompose. (Integer Import and Export): New section. (Miscellaneous Integer Functions): Clarify mpz_sizeinbase returns 1 for operand of 0. (Language Bindings): Add GNU Pascal. (Low-level Functions): Add GMP_NUMB_MAX. * tests/mpz/t-import.c, tests/mpz/t-export.c, tests/mpz/t-get_d.c: New tests. * tests/mpz/Makefile.am: Add them. * mpz/import.c, mpz/export.c: New files. * Makefile.am, mpz/Makefile.am, gmp-h.in: Add them. * gmp-h.in, gmp-impl.h (GMP_NUMB_MAX): Move to gmp.h. * gmp-impl.h (CNST_LIMB): Add cast to mp_limb_t to ensure unsigned. (CRAY_Pragma, MPN_REVERSE, MPN_BSWAP, MPN_BSWAP_REVERSE, ASSERT_ALWAYS_LIMB, ASSERT_ALWAYS_MPN): New macros. (MPZ_CHECK_FORMAT): Use ASSERT_ALWAYS_MPN. 2002-05-07 Torbjorn Granlund * mpz/aors_ui.h: Nailify. * tests/mpz/t-addsub.c: New file. * tests/mpz/Makefile.am (check_PROGRAMS): Add t-addsub. * mpz/ui_sub.c: New file. * mpz/Makefile.am (libmpz_la_SOURCES): Add ui_sub.c. * Makefile.am (MPZ_OBJECTS): Ditto. * gmp-h.in (mpz_ui_sub): Add declaration. * gmp-impl.h (MPZ_REALLOC): Rewrite to allow the use of _mpz_realloc return value. * gmp-h.in (mpn_pow_1): Add declaration. * mpn/generic/pow_1.c: Handle exp <= 1. Reverse rp/tp parity scheme for bn == 1 arm. * Rename MP_LIMB_T_HIGHBIT => GMP_LIMB_HIGHBIT. 2002-05-06 Torbjorn Granlund * demos/pexpr.c (main): Don't call mpz_sizeinbase with negative base. * randraw.c (lc): Remove an unused variable. * mpn/generic/get_str.c: Clarify an algorithm description. * tests/mpf/t-trunc.c: Nailify. * tests/mpf/t-set_si.c: Disable for nails. * mpf/cmp_si.c: Nailify. * mpf/cmp_ui.c: Nailify. * mpf/div.c: Nailify. * mpf/div_2exp.c: Nailify. * mpf/div_ui.c: Nailify. * mpf/eq.c: Nailify. * mpf/get_d.c: Nailify. * mpf/get_d_2exp.c: Nailify. * mpf/get_si.c: Nailify. * mpf/get_str.c: Nailify. * mpf/get_ui.c: Nailify. * mpf/mul_2exp.c: Nailify. * mpf/random2.c: Nailify. * mpf/set_q.c: Nailify. * mpf/set_si.c: Nailify. * mpf/set_str.c: Nailify. * mpf/set_ui.c: Nailify. * mpf/sub.c: Nailify. * mpf/ui_div.c: Nailify. * mpf/ui_sub.c: Nailify. * mpf/urandomb.c: Nailify. * gmp-impl.h (__GMPF_BITS_TO_PREC, __GMPF_PREC_TO_BITS): Nailify. * mpz/get_si.c: Misc variable name changes. * mpf/fits_u.h: Rewrite - nailify. * mpf/fits_s.h: Likewise. * mpz/mod.c: Disambiguate if-statement with extra {}. * mpf/int_p.c: Fix type of size variables. * mpf/get_ui: Likewise. * mpf/get_si: Likewise. * mpq/equal.c: Likewise. * mpq/get_d.c: Likewise. * mpz/cmp_d.c: Likewise. * mpz/cmpabs_d.c: Likewise. * mpz/divis_2exp.c: Likewise. * mpz/kronuz.c: Likewise. * mpz/kronzu.c: Likewise. * mpz/kronzs.c: Likewise. * mpz/kronsz.c: Likewise. * mpz/scan0.c: Likewise. * mpz/scan1.c: Likewise. * mpz/tstbit.c: Likewise. * mpz/cong_2exp.c: Likewise. * mpz/divis.c: Likewise. 2002-05-04 Torbjorn Granlund * mpn/generic/gcd.c: Additional nailify changes. 2002-05-04 Kevin Ryde * gmp-h.in (__GNU_MP_VERSION): Set to 4.1. * Makefile.am (-version-info): Bump for new release. 2002-04-30 Torbjorn Granlund * mpn/generic/divrem_1.c: Additional nailify changes. * mpn/generic/mod_1.c: Likewise. * tests/mpq/t-get_d.c: Print floats with all 16 digits. * mpq/get_d.c: Nailify. * tests/mpq/t-set_f.c: Disable for nails. * mpz/get_d.c: Nailify. * gmp-impl.h (LIMBS_PER_DOUBLE, MP_BASE_AS_DOUBLE): Nailify. * gmp-h.in (__GMPZ_FITS_UTYPE_P): Cast maxval to before shifting it. * extract-dbl.c: Nailify. 2002-04-29 Torbjorn Granlund * mpq/md_2exp.c (mord_2exp): Nailify. * mpq/cmp_ui.c: Nailify. * mpq/cmp.c (mpq_cmp): Nailify. * mpn/generic/gcd.c: Nailify. GNUify code layout. * mpn/generic/gcdext.c: Nailify. Misc changes. * tests/mpz/t-sqrtrem.c: Let argv[1] mean # of repetitions. * tests/mpz/t-gcd.c: Likewise. * mpz/gcd.c: Nailify. * mpn/generic/random.c: Nailify. * gmp-impl.h (modlimb_invert): Nailify. 2002-04-27 Torbjorn Granlund * mpn/generic/gcdext.c (div2): Remove qh parameter. (mpn_gcdext): Streamline double-limb code. Move GCDEXT_THRESHOLD check to after initial division. 2002-04-27 Kevin Ryde * gmp-impl.h (JACOBI_MOD_OR_MODEXACT_1_ODD): Allow for odd GMP_NUMB_BITS. * tune/time.c (sgi_works_p): Allow for 64-bit counter, and fix SGI_CYCLECNTR_SIZE handling. * demos/expr/exprfr.c: Add nan and inf constants. * demos/expr/t-expr.c: Exercise them. 2002-04-26 Torbjorn Granlund * mpz/cmp_ui.c: Fix overflow conditions for nails. * gmp-h.in (mpz_get_ui): Fix typo from last change. * mpz/n_pow_ui.c: Adjust allocation for nails. (GMP_NUMB_HALFMAX): Renamed from MP_LIMB_T_HALFMAX. Fix umul_ppmm invocation for for nails. 2002-04-24 Torbjorn Granlund * mpn/generic/gcdext.c: Simplify by using mpn_tdiv_qr instead of mpn_divmod. 2002-04-24 Kevin Ryde * configure.in (*-*-cygwin*): Give a sensible default command line limit, to avoid blowups reported by Jim Fougeron on windows 9x. (--enable-nails): Make the default 2, since mp_bases has data for that. * mpfr/mpfr-math.h (__mpfr_nan): Use a "double" for the bytes, to avoid a mis-conversion on alpha gcc 3.0.2. (_MPFR_INFP_BYTES, _MPFR_INFM_BYTES): Should be a zero mantissa. 2002-04-23 Torbjorn Granlund * mpz/dive_ui.c: Fix typo. * mpz/fits_s.h: Rewrite. * mpz/jacobi.c: Nailify. * mpz/kronuz.c: Additional nailify changes. * mpz/kronsz.c: Likewise. 2002-04-23 Kevin Ryde * demos/expr/Makefile.am (LDADD): Add $(LIBM) for the benefit of mpfr. * mpz/divis_ui.c, mpz/cong_ui.c: Nailify. * mpn/generic/bdivmod.c, mpz/divexact.c, mpz/dive_ui.c: Nailify. * mpn/generic/sb_divrem_mn.c, mpn/generic/divrem.c, mpn/generic/divrem_2.c: Nailify ASSERTs. * mpn/x86/k6/mmx/logops_n.asm, mpn/x86/k6/mmx/com_n.asm: Nailify. * mpz/inp_raw.c, mpz/out_raw.c: Nailify. * mpz/kronzu.c, mpz/kronuz.c, mpz/kronzs.c, mpz/kronsz.c: Nailify. * mpn/generic/divis.c, mpz/cong.c, mpz/cong_2exp.c: Nailify. * gmp-impl.h (NEG_MOD): Nailify. * gmp-impl.h, mpn/mp_bases.c: Add back GMP_NUMB_BITS==30 bases data. * mpfr/get_d.c: Patch from Paul to avoid problem with constant folding in gcc on OSF. * mpn/lisp/gmpasm-mode.el: Remove mention of defunct LF macro. 2002-04-22 Torbjorn Granlund * demos/pexpr.c: Handle "binomial" operator. * mpz/cmp_ui.c: Move assignments of `up' out of conditionals. * mpn/generic/gcdext.c: Fix fencepost error in STAT code. * gmp-impl.h (mpn_com_n): Nailify. * tests/mpz/t-cdiv_ui.c: New file. * tests/mpz/Makefile.am (check_PROGRAMS): Add t-cdiv_ui. * mpz/cdiv_qr_ui.c: Nailify. * mpz/cdiv_q_ui.c: Nailify. * mpz/cdiv_r_ui.c: Nailify. * mpz/cdiv_ui.c: Nailify. * tests/misc/t-printf.c (CHECK_N): Add cast to allow `char' to be an unsigned type. * tests/misc/t-scanf.c: Likewise. * mpz/mul_i.h: Rework nails code to handle parameter overlap. * tests/mpz/t-set_f.c: Disable for nails. 2002-04-21 Torbjorn Granlund * mpz/set_si.c: Add cast to support LONG_LONG_LIMB. * mpz/iset_si.c: Likewise. * mpz/bin_ui.c: Nailify. * mpz/bin_uiui.c: Nailify. * mpz/cmpabs_ui.c: Nailify. * tests/mpz/t-aorsmul.c: Nailify. * mpz/aorsmul_i.c (mpz_addmul_ui, mpz_submul_ui): Nailify better. 2002-04-20 Torbjorn Granlund * tests/mpz/t-fdiv_ui.c: Check mpz_fdiv_ui. * tests/mpz/t-tdiv_ui.c: Check mpz_tdiv_ui. * mpz/tdiv_ui.c: Rewrite nails code. * mpz/fdiv_ui.c: Nailify. * tests/mpz/t-tdiv_ui.c: Check returned remainders. * tests/mpz/t-fdiv_ui.c: Merge in recent t-tdiv_ui changes. * mpz/tdiv_q_ui.c: Remove spurious TMP_* calls. * mpz/fdiv_qr_ui.c: Nailify. * mpz/fdiv_q_ui.c: Nailify. * mpz/fdiv_r_ui.c: Nailify. * mpz/get_si.c: Misc nailify changes to shut up compiler warnings. * mpz/ui_pow_ui.c: Fix typo in last change. 2002-04-20 Kevin Ryde * tests/misc/t-printf.c, tests/misc/t-scanf.c: Check all %n types. * mpn/x86/k7/mmx/divrem_1.asm, mpn/x86/p6/mmx/divrem_1.asm (mpn_preinv_divrem_1): New entrypoint. (mpn_divrem_1): Avoid a branch when testing high * tests/mpz/t-scan.c: Nailify. * mpz/tdiv_qr_ui.c: Nailify. * mpz/tdiv_q_ui.c: Nailify. * mpz/tdiv_r_ui.c: Nailify. * mpz/tdiv_ui.c: Nailify. * mpz/cmp_ui.c: Nailify. * mpz/ui_pow_ui.c: Misc nailify changes to shut up compiler warnings. * mpz/scan0.c: Nailify. * mpz/scan1.c: Nailify. * tests/mpz/t-sizeinbase.c (mpz_fake_bits): Nailify. 2002-04-18 Torbjorn Granlund * mpz/aorsmul_i.c: Nailify. * mpz/cmp_si.c: Nailify (botched). * mpz/ui_pow_ui.c: Nailify. * gmp-h.in (__GMPZ_FITS_UTYPE_P): Nailify. * mpz/fits_s.h: Nailify. * tests/mpz/bit.c (check_tstbit): Nailify. From Paul Zimmermann: * mpn/generic/sqrtrem.c: Nailify. * mpz/n_pow_ui.c: Nailify. * mpz/cfdiv_r_2exp.c: Nailify. * randraw.c (lc): Undo: Let mpn_rshift put result in place to avoid extra MPN_COPY. 2002-04-17 Torbjorn Granlund * mpz/clrbit.c: Add two GMP_NUMB_MASK masks after addition. * mpn/generic/random2.c (LOGBITS_PER_BLOCK): Decrease to 4. * gmp-impl.h (nail DIV_DC_THRESHOLD): Decrease to 50 to allow fast division. * mpn/generic/random2.c: Nailify. * mpz/fac_ui.c: Nailify. * mpz/mul_i.h: #if ... #endif code block to shut up gcc warnings. * mpn/generic/sqrtrem.c: Adopt to GNU coding standards. (mpn_dc_sqrtrem): New name for mpn_dq_sqrtrem. Partial nailification. * configure.in: As a temporary hack, clear extra_functions for nails builds. * gmp-h.in (mpz_get_ui): #if ... #endif else code block to shut up gcc warnings. 2002-04-17 Kevin Ryde * texinfo.tex: Update to 2002-03-26.08 per texinfo 4.2. * gmp.texi: Must have @top in @ifnottex (or @contents doesn't come out in one run). * mpn/generic/scan0.c, mpn/generic/scan1.c: Nailify. * tests/mpn/t-scan.c: New file. * tests/mpn/Makefile.am (check_PROGRAMS): Add it. * tests/refmpn.c, tests/tests.h (refmpn_tstbit): Use unsigned long for bit index. (refmpn_setbit, refmpn_clrbit, refmpn_scan0, refmpn_scan1): New functions. * mpfr/cmp_ui.c (mpfr_cmp_si_2exp): Fix b==0 i!=0 case. 2002-04-17 Gerardo Ballabio * gmpxx.h, mpfrxx.h: Remove mpfr_class bool combinations, remove mpfr_class::get_str2, use mp_rnd_t for rounding modes, use 8*sizeof(double) for mpfr_t's holding doubles. 2002-04-17 Torbjorn Granlund * mpz/powm.c: Nailify. * mpz/powm_ui.c: Nailify. 2002-04-16 Torbjorn Granlund * mpz/hamdist.c: Nailify. * tests/misc.c (urandom): Nailify. * mpz/get_si.c: Nailify. * gmp-h.in (mpz_get_ui): Nailify. Streamline (and probably upset memory checkers). * gmp-impl.h (mp_bases[10] values): Add versions for GMP_NUMB_BITS being 28, 60, and 63. * mpn/mp_bases.c: Add tables for GMP_NUMB_BITS being 28, 60, and 63. * mpz/iset_si.c: Nailify. * mpz/iset_ui.c: Nailify * tests/mpz/convert.c (main): Print test number in error message. * mpn/generic/get_str.c (mpn_sb_get_str): Shift up `frac' into nails field after bignum division. 2002-04-16 Kevin Ryde * gmp-h.in, gmp-impl.h (GMP_NAIL_MASK): Move to gmp.h. * gmp.texi: Use @documentdescription and @copying, per texinfo 4.2. (Low-level Functions): Clarify mpn_gcd overlap requirements, rewrite mpn_set_str description, add nails section. (C++ Interface General): Remove bool from types that mix with classes. (Language Bindings): Add STklos, GNU Smalltalk, Regina. (Binary to Radix, Radix to Binary): Describe new code. (Assembler Cache Handling): More notes, mostly by Torbjorn. * macos/configure (%vars): Remove __GMP from substitutions, per change to main configure. * mpn/generic/dive_1.c: Nailify. * mpn/generic/mode1o.c: Nailify, remove bogus ASSERT in commented-out alternate implementation. * gmp-impl.h (SUBC_LIMB): New macro. * tests/devel/try.c (validate_divexact_1): Correction to compare. (udiv_qrnnd): New testing. (SHIFT_LIMIT): Nailify. (-b): New option, remove spurious "H" from getopt string. * mpz/clrbit.c: Nailify. * tests/mpz/t-hamdist.c: Nailify. * gmp-impl.h (MPN_FIB2_SIZE): Nailify. (PP): Nailify conditionals. * tests/mpz/t-fib_ui.c (MPZ_FIB_SIZE_FLOAT): Nailify. * configure.in, acinclude.m4: Establish GMP_NAIL_BITS and GMP_LIMB_BITS for gmp-h.in configure tests. * mpfr/*, configure.in: Update to final mpfr 2.0.1. * mpfr/acinclude.m4 (MPFR_CONFIGS): Use $host, not uname stuff. * mpfr/tests/tout_str.c: Patch from Paul for denorm fprintf tests. 2002-04-15 Torbjorn Granlund * mpn/generic/divrem_1.c (EXTRACT): Remove. * tests/mpz/t-tdiv_ui.c (dump_abort): Accept argument for error string. * mpz/rrandomb.c: Nailify. Needs further work. * mpn/generic/mod_1.c: Nailify. * gmp-impl.h: Set various *_THRESHOLD values to be used for nails to avoid not yet qualified algorithms. (MPZ_CHECK_FORMAT): Check that nail part is zero. * tests/mpz/t-mul.c (main): Test squaring even for huge operands. (base_mul): Nailify. (dump_abort): Accept argument for error string. Print product difference. * mpn/generic/set_str.c: Nailify. * gmp-h.in (__GMPN_ADD, __GMPN_SUB): Nailify. 2002-04-14 Torbjorn Granlund * randraw.c (lc): Return non-nonsense return value for seed=0 case. Check for m2exp being non-zero early; remove all other tests of m2exp. Remove redundant MPN_ZERO call. Let mpn_rshift put result in place to avoid extra MPN_COPY. Remove confusing comment before function `lc' describing BBS algorithm. Misc simplification and cleanups. Nailify. Needs further work. * mpz/set_si.c: Nailify. * mpz/set_ui.c: Nailify. * mpz/mul_i.h: Nailify. * tests/mpz/t-mul_i.c: Actually test _ui routines. Add some more test values. * mpn/generic/mul_n.c: Finish nailifying toom3 code. 2002-04-13 Kevin Ryde * mpfr/*: Update to another new mpfr 2.0.1. * configure.in, Makefile.am, mpfr/Makefile.am, mpfr/tests/Makefile.am: Use MPFR_CONFIGS macro, establish separate MPFR_CFLAGS for mpfr build. * mpfr/tests/Makefile.am: Correction to convenience rule for libmpfr.a. 2002-04-11 Kevin Ryde * mpfr/set_q.c: gmp-impl.h before mpfr.h to avoid _PROTO redefine. * mpfr/*, configure.in: Update to new mpfr 2.0.1. * tests/refmpn.c (refmpn_udiv_qrnnd, refmpn_divmod_1c_workaround): Fixes for nails. * tests/t-constants.c (MODLIMB_INVERSE_3): Nailify tests. (MP_BASES_BIG_BASE_INVERTED_10, MP_BASES_NORMALIZATION_STEPS_10): Only check these under USE_PREINV_DIVREM_1. * tests/t-modlinv.c: Nailify tests. 2002-04-11 Gerardo Ballabio * gmpxx.h: Remove bool combinations, remove mpf_class::get_str2, only need now. 2002-04-11 Torbjorn Granlund * mpn/generic/diveby3.c: Nailify. * gmp-impl.h (MODLIMB_INVERSE_3): Nailify. * mpn/generic/mul_n.c: Nailify Toom3 code. 2002-04-10 Kevin Ryde * gmp-impl.h (MPN_KARA_MUL_N_MINSIZE, MPN_KARA_SQR_N_MINSIZE): Set to 3, as needed by nails case. * mpn/generic/addmul_1.c, mpn/generic/submul_1.c [nails]: Fix vl assert, add rp,n and up,n asserts. * mpfr/Makefile.am: Add new mpfr-math.h, install mpf2mpfr.h. 2002-04-10 Torbjorn Granlund * mpn/generic/divrem_1.c: Nailify. Update mp_size_t variables to use `n' suffix instead of `size' suffix. * mpn/generic/divrem_2.c: Likewise. * mpn/generic/sb_divrem_mn.c: Nailify. * mpn/generic/tdiv_qr.c: Nailify. (SHL): Remove silly macro. * mpn/generic/mul_n.c (mpn_kara_mul_n): Replace open-coded increment by mpn_incr_u call. Handle nails in ws[n] increment. * mpn/generic/mul_n.c (mpn_kara_sqr_n): Likewise. * gmp-h.in (GMP_NUMB_MASK): New #define. (__GMPN_AORS_1): Add version for nails. * gmp-impl.h (GMP_NUMB_MASK): Comment out, now in gmp.h. (mpn_incr_u): Don't assume `incr' is non-zero. (mpn_decr_u): Similarly. 2002-04-09 Kevin Ryde * mpfr/*, configure.in: Update to mpfr 2.0.1. * tests/refmpn.c (refmpn_mul_1c, lshift_make): Corrections for nails. * tssts/refmpn.c, tests/tests.h (refmpn_cmp_allowzero): New function. * mpn/generic/mul_1.c [nails]: Fix vl assert, add {up,n} assert. * mpn/pa32/hppa1_1/pa7100/addmul_1.asm, mpn/pa32/hppa1_1/pa7100/submul_1.asm: Rename "size" define, to avoid ELF .size directive. Reported by LaMont Jones. * tests/mpz/t-set_si.c: Add nails support. 2002-04-05 Torbjorn Granlund * gmp-impl.h: Replace nail mpn_incr_u, mpn_decr_u with faster versions. (mp_bases[10] values): Check GMP_NUMB_BITS instead of BITS_PER_MP_LIMB. Add GMP_NUMB_BITS == 30 version. (__gmp_doprnt, etc): Remove parameter names. * mpn/generic/mul_n.c: Nailify Karatsuba code. * mpn/generic/get_str.c: Nailify. * mpn/generic/sqr_basecase.c: Nailify. * mpn/generic/lshift.c: Nailify. * mpn/generic/rshift.c: Likewise. * mpn/generic/add_n.c: Nailify. Revamp non-nail code. * mpn/generic/sub_n.c: Likewise. * mpn/generic/mul_1.c: Likewise. * mpn/generic/addmul_1.c: Likewise. * mpn/generic/submul_1.c: Likewise. 2002-04-02 Kevin Ryde * gmp-impl.h (BSWAP_LIMB_FETCH, BSWAP_LIMB_STORE) [powerpc]: Corrections to constraints, and restrict to bigendian. 2002-03-31 Kevin Ryde * tests/mpz/dive.c: Better diagnostics. * tests/devel/try.c (mpn_get_str, mpn_umul_ppmm_r): New tests. * tests/misc.c, tests/tests.h (byte_diff_lowest, byte_diff_highest): New functions. * tests/t-bswap.c: New file. * tests/Makefile.am (check_PROGRAMS): Add it. * tests/mpn/t-aors_1.c, tests/mpn/t-iord_u.c: Add nails support. * gmp-impl.h (MPN_IORD_U) [x86]: Eliminate unnecessary jiord and iord, rename "n" to incr per generic versions, restrict to nails==0. (mpn_incr_u, mpn_decr_u): Add nails support. (GMP_NAIL_LOWBIT, GMP_NUMB_MAX): New macros. * tests/trace.c, tests/tests.h (byte_trace, byte_tracen): New functions. * tests/trace.c: Handle NULL operands. * tests/refmpn.c, tests/devel/try.c, tune/speed.c: Add preliminary nail support. * tests/refmpn.c, test/tests.h (byte_overlap_p, refmpn_equal_anynail, refmpn_umul_ppmm_r, refmpn_udiv_qrnnd_r, refmpn_get_str, refmpn_bswap_limb, refmpn_random, refmpn_random2, refmpn_bswap_limb): New functions. * gmp-impl.h, tests/refmpn.c (ASSERT_LIMB): Renamed from ASSERT_MP_LIMB_T. * mpn/x86/*/*.asm, mpn/powerpc32/*/*.asm, mpn/powerpc64/*/*.asm: Put speeds after the copyright notice, so as to keep that clear. 2002-03-29 Kevin Ryde * configure.in (powerpc*-*-aix*): Correction to xlc -qarch selection, for 32-bit mode. 2002-03-28 Torbjorn Granlund * mpn: Fix spacing in many files. * mpn/generic/aorsmul_1.c: Split into addmul_1.c and submul_1.c. * mpn/generic/aors_n.c: Split into add_n.c and sub_n.c. * mpn/pa64/add_n.asm: Trim another 0.125 cycle/limb. Fix a comment. * mpn/pa64/sub_n.asm: Likewise. * mpn/pa64/mul_1.asm: Change comclr, comb to proper forms cmpclr, cmpb. * mpn/pa64/addmul_1.asm: Likewise. * mpn/pa64/submul_1.asm: Likewise. 2002-03-28 Kevin Ryde * gmp.texi (Converting Integers): Fix type of exp in mpz_get_d_2exp, reported by epl@unimelb.edu.au. (References): Update Burnikel and Ziegler URL, reported by Keith Briggs. * gmp-h.in, mp-h.in, configure.in, acinclude.m4: Remove __GMP from AC_SUBSTs, since autoconf says leading "_" in makefile variables is not portable. * demos/expr/run-expr.c: Declare optarg, optind, opterr if necessary. * configure.in, demos/expr/expr-config-h.in: Configs for this. 2002-03-27 Torbjorn Granlund * mpn/Makefile.am (TARG_DIST): Remove pa64w and hppa, add pa32. * configure.in (path_20w): Remove pa64w. * mpn/pa64/udiv_qrnnd.asm: Tweak for PA8000 performance comparative to that on PA8500. 2002-03-26 Torbjorn Granlund * mpn/pa32: New name for mpn/hppa. * configure.in: Corresponding changes. * mpn/pa64/umul_ppmm.asm: New file, generalized for both 2.0N and 2.0W. * mpn/pa64/umul_ppmm.S: Remove. * mpn/pa64/udiv_qrnnd.asm: Generalize for both 2.0N and 2.0W. * mpn/pa64w/udiv_qrnnd.asm: Remove. 2002-03-26 Kevin Ryde * mpfr/tests/tdiv.c, mpfr/tests/tui_div.c: Don't depend on nan and inf handling in "double", for the benefit of alpha. * configure (hppa2.0w): Set path to "pa64w pa64". * acinclude.m4, configure.in (GMP_C_INLINE): New macro. * acinclude.m4 (GMP_H_EXTERN_INLINE): Use it, and fix "yes" handling. 2002-03-25 Torbjorn Granlund * mpn/pa64w/add_n.s: Remove. * mpn/pa64w/sub_n.s: Remove. * mpn/pa64w/lshift.s: Remove. * mpn/pa64w/rshift.s: Remove. * mpn/pa64w/mul_1.S: Remove. * mpn/pa64w/addmul_1.S: Remove. * mpn/pa64w/submul_1.S: Remove. * mpn/pa64w/sqr_diagonal.asm: Remove. * mpn/pa64/mul_1.asm: New file with twice faster code; generalized for both 2.0N and 2.0W. * mpn/pa64/submul_1.asm: Likewise. * mpn/pa64/mul_1.S: Remove. * mpn/pa64/submul_1.S: Remove. * mpn/pa64/sqr_diagonal.asm: Generalize for both 2.0N and 2.0W. * mpn/pa64/add_n.asm: New file, generalized for both 2.0N and 2.0W. * mpn/pa64/sub_n.asm: Likewise. * mpn/pa64/lshift.asm: Likewise. * mpn/pa64/rshift.asm: Likewise. * mpn/pa64/add_n.s: Remove. * mpn/pa64/sub_n.s: Remove. * mpn/pa64/lshift.s: Remove. * mpn/pa64/rshift.s: Remove. 2002-03-24 Kevin Ryde * gmp-impl.h (BSWAP_LIMB_FETCH, BSWAP_LIMB_STORE): New macros. * mpz/inp_raw.c, mpz/out_raw.c: Use them. * acconfig.h (HAVE_HOST_CPU): Add some powerpc types. * mpn/powerpc32/750/com_n.asm: New file. * mpfr/tests/tout_str.c: Disable random tests, since they fail on alphaev56-unknown-freebsd4.1 and do nothing by default. * mpfr/tests/tsqrt.c: Don't depend on nan, inf or -0 in "double", for the benefit of alpha. * mpfr/sqrt.c: Clear nan flag on -0. * demos/factorize.c: Use mpn_random() instead of random(), to avoid portability problems. * demos/isprime.c (print_usage_and_exit): Declare as "void" to avoid warnings. * demos/pexpr.c (setup_error_handler): Corrections to sigstack code. * demos/calc/calc.y: Add some `;'s to make bison 1.34 happy. 2002-03-23 Torbjorn Granlund * mpn/pa64/addmul_1.asm: New file with twice faster code; generalized for both 2.0N and 2.0W. 2002-03-22 Kevin Ryde * tune/time.c: Add SGI hardware counter measuring method, change some abort()s into ASSERT_FAIL()s. * configure.in (AC_CHECK_HEADERS): Add fcntl.h and sys/syssgi.h. (AC_CHECK_FUNCS): Add syssgi. * configure.in, mpfr/Makefile.am, mpfr/tests/Makefile.am: Use -mieee-with-inexact or -ieee_with_inexact for mpfr on alpha, so denorms work. * mpfr/isinteger.c: Fix a memory leak. 2002-03-21 Torbjorn Granlund * tune/speed.c (struct choice_t): Make `r' an mp_limb_t. 2002-03-21 Kevin Ryde * configure.in (HAVE_LIMB_BIG_ENDIAN, HAVE_LIMB_LITTLE_ENDIAN): Use an AH_VERBATIM and better explanation. * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Similarly for the HAVE_DOUBLE constants. * gmp.texi (Number Theoretic Functions): Clarify sign of GCD returned by mpz_gcdext. * demos/pexpr.c, demos/pexpr-config-h.in, configure.in: Use an autoconf test for stack_t. * configure.in, gmp-h.in, mp-h.in, macos/configure, tests/mpz/reuse.c, tests/mpf/reuse.c: Use __GMP_LIBGMP_DLL to enable windows declspec, don't require _WIN32 (etc), remove __GMP_LIBGMP_SHARED and __GMP_LIBGMP_STATIC. * gmp-impl.h (mp_bases): Add __GMP_DECLSPEC, for the benefit of tests/t-constants.c. * tune/many.pl, tune/speed.h: Remove suffix hack for back.asm. 2002-03-21 Paul Zimmermann * mpfr/sin_cos.c (mpfr_sin_cos): New file. * mpfr/mpfr.h, mpfr/mpfr.texi, mpfr/Makefile.am: Add it. * mpfr/tan.c: Fix sign in 2nd and 4th quadrants. * mpfr/log10.c: Fix hangs on certain inputs. 2002-03-20 Torbjorn Granlund * demos/pexpr.c (setup_error_handler): Declare `s', the first sigaltstack parameter, using `stack_t' just on AIX. 2002-03-19 Torbjorn Granlund * mpn/powerpc32/mul_1.asm: Use free caller-saves registers instead of the callee-saves r30 and r31. 2002-03-19 Kevin Ryde * tune/freq.c (freq_proc_cpuinfo): Recognise powerpc "clock", where previously got the wrong result from "bogomips". * mpn/powerpc32/add_n.asm, mpn/powerpc32/sub_n.asm: Rewrite, faster on 750, and smaller too. * mpn/powerpc32/*.asm: Use L(), add some measured speeds. * longlong.h (count_trailing_zeros) [vax]: Add a version using ffs, but commented out. 2002-03-17 Kevin Ryde * tune/speed.c, tune/speed.h, tune/common.c, many.pl: Use optional ".r" to specify operand overlaps for mpn_add_n, mpn_sub_n and logops. Remove mpn_add_n_inplace and mpn_add_n_self. * tune/many.pl: Fix MULFUNC_PROLOGUE parsing. * gmp.texi (Known Build Problems): Note `make' problem with long libgmp.la dependencies list. * printf/doprnt.c, scanf/doscan.c (%zn): Remove test of non-existent HAVE_SIZE_T, just use size_t unconditionally. * printf/doprnt.c (%zd etc): Fix 'z' type parsing. * tests/misc/t-printf.c, tests/misc/t-scanf.c: More tests. * configure.in: Use AC_COPYRIGHT. Add m4_pattern_allow(GMP_MPARAM_H_SUGGEST). * tune/Makefile.am (libdummy.la): Remove this, sqr_basecase.c already gets an ansi2knr rule from nodist_tuneup_SOURCES. * longlong.h (count_leading_zeros) [pentiumpro gcc<3]: Test HAVE_HOST_CPU_i686 too. * mpz/out_raw.c (HTON_LIMB_STORE): Fix a typo in big endian #if. 2002-03-14 Kevin Ryde * mpn/x86/pentium/com_n.asm, mpn/x86/pentium/logops_n.asm, mpn/x86/k6/mmx/com_n.asm: Add nails support. * texinfo.tex: Update to 2002-03-01.06 (per texinfo 4.1). * gmp.texi (@ma): Remove, @math does this now. * mpfr/tests/reuse.c: Clear op1 and op2 flags only in their respective outer loops. * configure.in (--enable-cxx): Correction to the default stated in the help string. (power*-*-aix*, not powerpc): Use aix.m4, don't run GMP_ASM_POWERPC_R_REGISTERS or use powerpc-defs.m4. 2002-03-13 Torbjorn Granlund * mpn/sparc32/gmp-mparam.h: New file. 2002-03-13 Kevin Ryde * demos/expr/exprfr.c: More mpfr functions, corrections to agm, cos, sin, rename log2 constant to loge2 to make room for log2 function. * demos/expr/t-expr.c: More tests. * mpz/inp_raw.c (NTOH_LIMB_FETCH) [generic 16bit]: Remove spurious "+". * mpfr/acos.c: Avoid a memory leak for certain operands. * acinclude.m4, configure.in (GMP_C_DOUBLE_FORMAT): New macro. * acinclude.m4 (GMP_HPC_HPPA_2_0, GMP_ASM_UNDERSCORE, GMP_ASM_ALIGN_LOG, GMP_ASM_LSYM_PREFIX, GMP_ASM_W32, GMP_ASM_X86_MMX): Change ac_objext to OBJEXT, which is the documented variable. * config.guess (powerpc*-*-*): Use #ifdef on constants POWER_630 etc in the AIX test, since old versions don't have them all. 2002-03-11 Kevin Ryde * configure.in (LIBC211): New AC_DEFINE, for mpfr. * configure.in (mips*-*-*): Support ABI=o32 on irix 6, allow gcc 2.7.2 to fall back on it, but detect it doesn't work with gcc 2.95. Use single mips-defs.m4 for both mips32 and mips64. * acinclude.m4 (GMP_GCC_MIPS_O32): New macro. * mpn/mips32/mips-defs.m4: Renamed from mips.m4. * mpn/mips64/mips.m4: Remove (was a copy of mips32/mips.m4). * mpn/powerpc32/750: New directory. * configure.in (powerpc740, powerpc750, powerpc7400): Use it. * mpn/powerpc32/750/gmp-mparam.h: New file. * config.sub, gmp.texi (ultrasparc1): Remove this, just use plain "ultrasparc". 2002-03-10 Kevin Ryde * mpfr: Update to 20020301, except internal_ceil_exp2.c, internal_ceil_log2.c, internal_floor_log2.c renamed to i_ceil_exp2.c, i_ceil_log2.c, i_floor_log2.c to be unique in DOS 8.3. And sqrtrem.c removed since no longer required. * mpfr/mpfr.texi: Fix some formatting. * mpfr/tests/reuse.c: Patch by Paul to fix test4 variable handling. * mpfr/sinh.c: Patch by Paul to fix err calculation when t==0. * mpfr/tests/tget_d.c: Disable until portability of rnd_mode.c can be sorted out. * configure.in (powerpc*-*-*): Separate gcc and xlc cpu flags setups for clarity. * longlong.h (count_leading_zeros, count_trailing_zeros) [x86_64]: New macros. 2002-03-07 Kevin Ryde * gmp.texi (Build Options): Note all the ultrasparcs accepted. (Language Bindings): Add Math::BigInt::GMP. * config.sub (ultrasparc2i): New cpu type. * config.guess (sparc-*-*, sparc64-*-*): Add some exact CPU detection. 2002-03-05 Kevin Ryde * longlong.h (count_leading_zeros, count_trailing_zeros) [alphaev67, alphaev68]: Use ctlz and cttz insns (as per gcc longlong.h). (count_leading_zeros) [sparclite]: Fix parameter order (as per gcc longlong.h). * acconfig.h (HAVE_HOST_CPU_alphaev68): New define. * config.guess [i?86-*-*]: Suppress error messages if compiler not found or test program won't run. [rs6000-*-*, powerpc-*-*]: Force code alignment for mfpvr test. 2002-03-04 Torbjorn Granlund * mpn/generic/pow_1.c: New file. 2002-03-03 Kevin Ryde * gmp.texi (Build Options): Note compiler must be able to fully link, add alphapca57 and alphaev68, give a clearer example of MPN_PATH (Debugging): Add notes on valgrind. (C++ Formatted Output): Clarify mpf showbase handling, in particular note "00.4" in octal. * printf/doprntf.c: Do a showbase on octal float fractions, for instance "00.4" where previously it gave "0.4". * tests/cxx/t-ostream.cc: Update. * gmp-h.in, mp-h.in (__GMP_DECLSPEC, __GMP_DECLSPEC_XX): Test __WIN32__ for Borland C, reported by "delta trinity". * gmp-h.in, mp-h.in: Use for size_t under C++, suggested by Hans Aberg some time ago. * gmp-h.in (): Move to top of file for clarity. * Makefile.am (libgmpxx_la_SOURCES): Use dummy.cc to force C++. (CXX_OBJECTS): Add osfuns$U.lo. * dummy.cc: New file. * cxx/Makefile.am (INCLUDES): Use __GMP_WITHIN_GMPXX. (libcxx_la_SOURCES): Add osfuns.cc. * gmp-h.in (__GMP_DECLSPEC_XX): New define, use it on libgmpxx funs. * gmp-impl.h: Add __GMP_DECLSPEC to libgmp functions used by libgmpxx. * longlong.h (COUNT_TRAILING_ZEROS_TIME): Remove, no longer used. * gmp-impl.h (MPN_SIZEINBASE, MPN_SIZEINBASE_16): Correction to __totbits for nails. * gmp-impl.h (JACOBI_LS0): Test size before limb, to pacify valgrind. (JACOBI_0LS): Ditto, and fix parens around arguments. * mpn/x86/x86-defs.m4 (call_mcount): Add a counter to make data labels unique, since simplified L() scheme no longer gives that effect. (notl_or_xorl_GMP_NUMB_MASK): New macro. Add m4_assert_numargs in a few places. * configure.in (*sparc*): Fix cycle counter setups for ABI=64. 2002-02-28 Torbjorn Granlund * mpn/vax/gmp-mparam.h: New file. 2002-02-28 Kevin Ryde * gmp-h.in (gmp_errno, gmp_version): Move into extern "C" block, reported by librik@panix.com. * gmp-h.in, mp-h.in (__GMP_DECLSPEC_EXPORT, __GMP_DECLSPEC_IMPORT): Use __declspec(dllexport) and __declspec(dllimport) on Borland. * gmp-h.in (_GMP_H_HAVE_FILE): Test __STDIO_H for Borland. Reported by "delta trinity". * gmp-impl.h (va_copy): Fall back on memcpy, not "=". * mpn/generic/pre_mod_1.c: Add a comment about obsolescence. * tune/time.c (MICROSECONDS_P): Don't trust time differences of 1 microsecond. * tests/cxx/t-ostream.cc: Use "const char *" not just "char *" for test data strings, avoids warnings on Sun CC. 2002-02-27 Torbjorn Granlund * configure.in: For sparc under solaris2.[7-9], pass -fsimple=1 to disable some crazy -fast optimizations. 2002-02-25 Torbjorn Granlund * configure.in: For sparc under solaris2.[7-9], pass -fns=no to enable denorm handling under -fast. 2002-02-25 Kevin Ryde * configure.in (alpha*-*-*): Rearrange -mcpu selection for gcc, provide an ev67 -> ev6 fallback. Fix -arch,-tune selection for DEC C. Allow ~ for space in optional options lists. * tune/tuneup.c (tune_preinv_divrem_1): Compare against an assembler mpn_divrem_1 if it exists, not the generic C mpn_divrem_1_div. (tune_preinv_mod_1): Ditto with mpn_mod_1. * tune/time.c (DIFF_SECS_ROUTINE): Eliminate the unused "type" parameter, try to make the code a bit clearer. * tune/freq.c: Reduce the period measured for cycles versus gettimeofday, add cycles versus microsecond getrusage. * mpz/array_init.c: "i" should be mp_size_t, noticed by E. Khong. 2002-02-24 Torbjorn Granlund * configure.in: For sparc under solaris2.[7-9], pass -fast instead of other optimization options. 2002-02-23 Kevin Ryde * mpn/asm-defs.m4 (GMP_NUMB_MASK): New macro. (PROLOGUE, EPILOGUE): Relax quoting for the benefit of tune/many.pl when GSYM_PREFIX non-empty. * tune/time.c, tune/speed.h (speed_time_init): Include clock tick period in speed_time_string. * tune/time.c, configure.in (clock_gettime): New measuring method. * tune/many.pl: Add -DHAVE_NATIVE_mpn_foo to C objects, to avoid conflicts with a macro version in gmp-impl.h, eg. mpn_com_n. 2002-02-22 Torbjorn Granlund * demos/pexpr.c: Increase RLIMIT_STACK to 4Mibyte. 2002-02-22 Kevin Ryde * tune/tuneup.c: Don't confuse gcc with mipspro cc in diagnostic. 2002-02-20 Torbjorn Granlund * configure.in (mips*-*-irix[6789]*]): Set `extra_functions_n32', not `extra_functions'. * printf/doprnt.c: Conditionally include inttypes.h. * printf/repl-vsnprintf.c: Likewise. * scanf/doscan.c: Likewise. 2002-02-20 Kevin Ryde * mpn/x86/k7/mmx/com_n.asm: New file. * mpz/n_pow_ui.c (SWAP_RP_TP): Use ASSERT_CODE on ralloc and talloc, to ensure they needn't live past the initial allocs in a normal build. * mpn/generic/mod_34lsub1.c: Note this is for internal use. 2002-02-19 Torbjorn Granlund * Clean up *_THRESHOLD names. Many files affected. * mpn/mips32: Asm-ify 32-bit mips code. Move files from `mips2' to `mips32' directory. * mpn/mips64: Move files from `mips3' to `mips64' directory. * configure.in: Change `mips2' => `mips32' and `mips3' => `mips64'. 2002-02-19 Kevin Ryde * acinclude.m4, configure.in (GMP_PROG_LEX): New macro. * tune/tuneup.c (one): Start next threshold at a max of previous ones, in order to get a good starting point for TOOM3_SQR_THRESHOLD if KARATSUBA_SQR_THRESHOLD is 0 (ie. using mpn_mul_basecase only). * configure.in, tune/tuneup.c (GMP_MPARAM_H_SUGGEST): New AC_DEFINE replacing GMP_MPARAM_H_FILENAME. Suggest a new file in a cpu specific subdirectory rather than mpn/generic. * acinclude.m4 (POWERPC64_PATTERN): New macro. * configure.in (powerpc*-*-*): Use it. (powerpc*-*-*): Use umul in 32L and aix64. (mips*-*-*): Use umul, 32 and 64 bit versions. 2002-02-18 Torbjorn Granlund * longlong.h: Add basic x86-64 support. 2002-02-17 Torbjorn Granlund * demos/pexpr.c: Support `-X' for upper case hex, make `-x' output lower case hex. * mpn/mips2/umul.s: Make it actually work. * mpn/mips3/umul.asm: New file. * mpn/mips2/gmp-mparam.h: New file. 2002-02-16 Torbjorn Granlund * mpn/generic/get_str.c (mpn_sb_get_str): Round frac upwards after umul_ppmm calls. 2002-02-16 Kevin Ryde * config.guess (alpha-*-*): Do alpha exact cpu probes on any system, and only if configfsf.guess gives a plain "alpha". * acinclude.m4 (GMP_PROG_CC_WORKS): Detect a gcc 3.0.3 powerpc64 linker invocation problem. 2002-02-15 Torbjorn Granlund * mpn/generic/get_str.c (mpn_sb_get_str): For base 10, develop initial digits using umul_ppmm, then switch to plain multiplication. * config.guess: Rewrite Alpha subtype detection code for *bsd systems. 2002-02-15 Kevin Ryde * gmp.texi (Build Options): Note powerpc exact cpu types. (Debugging): Advertise DEBUG in memory.c. * config.sub, config.guess: Add some powerpc exact cpus. * configure.in: Add configs for them. * memory.c [__NeXT__]: Remove unused #define of "static". (__gmp_default_allocate, __gmp_default_reallocate): Print size if allocation fails, don't use perror. * gmp-h.in: g++ 3 demands __GMP_NOTHROW is before other attributes. 2002-02-14 Torbjorn Granlund * mpn/alpha/mul_1.asm: Fix typo preventing build on T3E systems. 2002-02-14 Kevin Ryde * tune/tuneup.c (tune_set_str): Increase max_size, for the benefit of alpha. * macos/README: Bug reports to bug-gmp@gnu.org, clarify MacOS X a bit. * mpn/generic/gcdext.c [WANT_GCDEXT_ONE_STEP]: Add missing TMP_FREE. * tune/speed.c, tune/tuneup.c: Allow for speed_cycletime of 0.0 in some diagnostic printouts. * tune/time.c (speed_cycletime): Note can be 0.0. 2002-02-12 Torbjorn Granlund * mpn/alpha/mul_1.asm: Add mpn_mul_1c entry. * mpn/pa64w/sqr_diagonal.asm: Use L() for labels. 2002-02-11 Torbjorn Granlund * mpn/generic/get_str.c (mpn_sb_get_str): Change declaration of rp to accommodate tuneup compiles. 2002-02-11 Kevin Ryde * mpn/alpha/default.m4, mpn/alpha/unicos.m4 (PROLOGUE_cpu): Add noalign option. * mpn/alpha/default.m4 (PROLOGUE_cpu): use ALIGN instead of ".align". * gmp.texi (Debugging): Notes on Checker. (Other Multiplication): Move note on float FFTs to here. (Assembler Floating Point): New text and revisions by Torbjorn, picture formatting by me. Simplify tex pictures elsewhere a bit, share heights, eliminate some gaps at line joins. 2002-02-11 Torbjorn Granlund * mpn/generic/get_str.c (mpn_sb_get_str): Rewrite to generate fraction limbs and use multiplication for digit development. Trim allocation of buf. Get rid of code for !USE_MULTILIMB. 2002-02-10 Torbjorn Granlund * mpn/generic/set_str.c (mpn_set_str): Undo this: Change invocations of mpn_add_1 to instead use mpn_incr_u. * tests/mpz/convert.c: Free str only after it is used in error message. * mpn/generic/get_str.c (mpn_sb_get_str): Combine tail code for base 10 and generic bases. * mpn/mp_bases.c: Add entries for base 256. Remove __ prefix from table name. * gmp-impl.h (__mp_bases): Remove superfluous mp_ part of name, making it __gmpn_bases instead of __gmpn_mp_bases. (mp_bases): New #define. * tune/speed.h (SPEED_ROUTINE_MPN_SET_STR): Allow bases up to 256. (SPEED_ROUTINE_MPN_GET_STR): Likewise. 2002-02-09 Torbjorn Granlund * mpn/generic/set_str.c (mpn_set_str): Use mpn_mul_1c if available. Change invocations of mpn_add_1 to instead use mpn_incr_u. 2002-02-09 Kevin Ryde * mpz/array_init.c, mpz/cfdiv_q_2exp.c, mpz/cfdiv_r_2exp.c, mpz/cong_2exp.c, mpz/divis_2exp.c, mpz/hamdist.c, mpz/init2.c, mpz/mul_2exp.c, mpz/realloc2.c, mpz/scan0.c, mpz/scan1.c, mpz/setbit.c, mpz/tdiv_q_2exp.c, mpz/tdiv_r_2exp.c, mpz/tstbit.c, mpz/urandomb.c: Use GMP_NUMB_BITS. * mpz/iset_str.c [__CHECKER__]: Store a dummy value to the low limb to stop it appearing uninitialized. * gmp-h.in (__GMP_NOTHROW): New macro. (mp_set_memory_functions, mpz_cmp, mpz_cmp_si, mpz_cmp_ui, mpz_cmpabs, mpz_cmpabs_ui, mpz_congruent_2exp_p, mpz_divisible_2exp_p, mpz_fits_sint_p, mpz_fits_slong_p, mpz_fits_sshort_p, mpz_fits_uint_p, mpz_fits_ulong_p, mpz_fits_ushort_p, mpz_get_si, mpz_get_ui, mpz_getlimbn, mpz_hamdist, mpz_popcount, mpz_scan0, mpz_scan1, mpz_size, mpz_sizeinbase, mpz_swap, mpz_tstbit, mpq_equal, mpq_swap, mpf_cmp, mpf_cmp_si, mpf_cmp_ui, mpf_fits_sint_p, mpf_fits_slong_p, mpf_fits_sshort_p, mpf_fits_uint_p, mpf_fits_ulong_p, mpf_fits_ushort_p, mpf_get_default_prec, mpf_get_prec, mpf_get_si, mpf_get_ui, mpf_integer_p, mpf_set_default_prec, mpf_set_prec_raw, mpf_size, mpf_swap, mpn_add_1, mpn_cmp, mpn_hamdist, mpn_popcount, mpn_sub_1): Use it. * gmp-impl.h (MPN_SIZEINBASE, MPN_SIZEINBASE_16): New macros from mpn_sizeinbase, and use GMP_NUMB_BITS. * mpz/get_str.c, mpz/sizeinbase.c, mpbsd/mout.c, tune/speed.h: Use MPN_SIZEINBASE. * mpbsd/mtox.c: Use MPN_SIZEINBASE_16. * configure.in, mpn/Makefile.am, gmp-impl.h (mpn_sizeinbase): Remove. * mpn/generic/sizeinbase.c: Remove file. * gmp-impl.h (MPN_GET_STR_SIZE): Remove. * tests/mpn/t-g_str_size.c: Remove file. * tests/mpn/Makefile.am: Update. * Makefile.am (dist-hook): Don't distribute cvs merge ".#" files. 2002-02-08 Torbjorn Granlund * configure.in: Override extra_functions for all sparcv8 systems, not just supersparc. 2002-02-06 Kevin Ryde * tune/tuneup.c (tune_mul, tune_sqr): Disable FFTs until tuned. * tune/speed.h (SPEED_ROUTINE_MPN_SET_STR): Fix memory clobber in destination cache priming. * printf/doprnt.c: Fix parsing of %s and %p conversions. * tests/misc/t-printf.c (check_misc): Add some tests. 2002-02-03 Torbjorn Granlund * mpn/sparc32/v8/udiv.asm: New file, from v8/supersparc. * mpn/generic/set_str.c: Rename indigits_per_limb => chars_per_limb. Remove redundant chars_per_limb. Reverse 4 loops in basecase code for speed. Use MP_BASES_CHARS_PER_LIMB_10. 2002-02-03 Kevin Ryde * acinclude.m4 (GMP_PROG_NM): Ensure -B or -p get used when doing a cross compile with the native nm, helps OSF for instance. (GMP_ASM_LSYM_PREFIX): Remove ".byte 0" for the benefit of irix 6, allow "N" from nm for OSF, allow for "t" for other systems, but prefer no mention of the symbol at all. * tune/tuneup.c (print_define_remark): New function. Turn some "#if"s into plain "if"s. * tune/tuneup.c, gmp-impl.h, tune/Makefile.am (GET_STR_BASECASE_THRESHOLD, GET_STR_PRECOMPUTE_THRESHOLD): Tune these. * mpn/generic/get_str.c [TUNE_PROGRAM_BUILD]: Cope with non-constant GET_STR_PRECOMPUTE_THRESHOLD. 2002-02-02 Torbjorn Granlund * mpn/generic/get_str.c (mpn_get_str): Fix typo in a declaration. 2002-02-02 Kevin Ryde * mpn/generic/set_str.c: Use MP_PTR_SWAP and POW2_P, add __GMP_PROTO to convert_blocks prototype, disable SET_STR_BLOCK_SIZE sanity check. * tune/set_strb.c, tune/set_strs.c: New files. * tune/speed.h, tune/speed.c, tune/common.c,tune/Makefile.am: Add them. * tune/tuneup.c: Tune SET_STR_THRESHOLD. (DEFAULT_MAX_SIZE): Renamed from MAX_SIZE, allow any param.max_size[]. 2002-02-01 Torbjorn Granlund * tests/mpz/convert.c: Increase operand size. Add (yet disabled) code for testing with random strings. * mpn/generic/get_str.c (mpn_get_str): Rewrite to become sub-quadratic. (mpn_dc_get_str, mpn_sb_get_str): New functions. 2002-01-31 Kevin Ryde * gmpxx.h (cmp): Renamed from "compare". * configure.in (AC_C_BIGENDIAN): Don't abort when cross compiling. (PROLOGUE): Allow new style optional second parameter when grepping. * acinclude.m4 (GMP_HPC_HPPA_2_0, GMP_ASM_UNDERSCORE, GMP_ASM_ALIGN_LOG, GMP_ASM_LSYM_PREFIX, GMP_ASM_W32, GMP_ASM_X86_MMX): Use $ac_objext for object filenames. (GMP_ASM_UNDERSCORE): Use CCAS to assemble. * demos/pexpr-config-h.in: New file. * configure.in: Generate demos/pexpr-config.h. (AC_CHECK_FUNCS): Add clock, cputime, setrlimit, sigaction, sigaltstack, sigstack. * acinclude.m4 (GMP_SUBST_CHECK_FUNCS, GMP_SUBST_CHECK_HEADERS): New macros. * demos/pexpr.c: Use pexpr-config.h, not various #ifdefs. (setup_error_handler): Use signal if sigaction not available, allow for SIGBUS missing on mingw. (main): Use time() for random seed if gettimeofday not available. (cleanup_and_exit): Move SIGFPE out of LIMIT_RESOURCE_USAGE. 2002-01-30 Torbjorn Granlund * mpn/generic/set_str.c: Rewrite to become sub-quadratic. (convert_blocks): New function. 2002-01-30 Kevin Ryde * gmp-impl.h (GMP_NUMB_MASK, GMP_NAIL_MASK, GMP_NUMB_HIGHBIT, ASSERT_MPN, ASSERT_MP_LIMB_T): New macros. * mpn/generic/fib2_ui.c: Use GMP_NUMB_BITS, simplify the data generator program, share __gmp_fib_table initializers between bit sizes, cope with bit sizes other than those specifically setup. * gmp-impl.h (FIB_TABLE_LIMIT, FIB_TABLE_LUCNUM_LIMIT): Corresponding rearrangement of conditionals. * tests/mpz/t-fib_ui.c (check_fib_table): New test. 2002-01-28 Kevin Ryde * mpz/set_si.c, mpz/iset_si.c: Store to _mp_d[0] unconditionally, use an expression for _mp_size. * mpz/init.c, mpz/init2.c, mpz/iset.c, mpq/init.c [__CHECKER__]: Store dummy values to low limbs to stop them appearing uninitialized. 2002-01-26 Kevin Ryde * mpfr/mpfr-test.h (MAX, MIN, ABS): Use instead a patch from Paul and Vincent. 2002-01-24 Kevin Ryde * configure.in: Extra quoting to get argument help messages right. * gmp.texi (Efficiency): Suggest hex or octal for input and output. (Formatted Output Strings): Mention "*" for width and precision. * mpn/generic/sizeinbase.c: New file, adapted from mpz/sizeinbase.c. Use POW2_P, use __mp_bases[base].big_base for log2(base). * configure.in, mpn/Makefile.am: Add it. * gmp-impl.h: Add prototype. * mpz/sizeinbase.c, tune/speed.h, mpn/generic/get_str.c, mpz/get_str.c, mpbsd/mout.c, mpbsd/mtox.c: Use it. * mpz/get_str.c: Write directly to user buffer, skip at most one leading zero, eliminate special case for x==0. * mpbsd/mtox.c: Allocate exact result space at the start, eliminate special case for x==0. * mpbsd/mout.c: Only need to skip one high zero with mpn_sizeinbase. * configure.in (--enable-nails): New option. (GMP_NAIL_BITS, GMP_LIMB_BITS, GMP_NUMB_BITS): New defines for gmp.h and config.m4. * gmp-h.in: Add templates. * mpfr/mpfr-test.h (MAX, MIN, ABS): Use #ifndef to avoid a redefine error on AIX xlc. 2002-01-23 Torbjorn Granlund * mpn/generic/get_str.c: Correct type of `out_len'. 2002-01-22 Kevin Ryde * mpn/generic/pre_divrem_1.c: Corrections to some ASSERTs. * mpfr/mul_ui.c: Don't call mpn_lshift with 0 shift. * mpfr/mpz_set_fr.c: Produce correct mpz_t for f==0. 2002-01-21 Torbjorn Granlund * longlong.h (32-bit powerpc add_ssaaaa): Remove spurious commutative declaration. (64-bit powerpc add_ssaaaa): Likewise. 2002-01-20 Kevin Ryde * acinclude.m4 (GMP_FUNC_VSNPRINTF): Use %n to better detect sparc solaris 2.7 problems. 2002-01-19 Torbjorn Granlund * demos/pexpr.c (mpz_eval_expr): Optimize s^rhs for -1 <= s <= 1. (cleanup_and_exit): Improve error message wording. 2002-01-19 Kevin Ryde * mpfr/mpfr.h (_PROTO): Use __GMP_PROTO, for compatibility with gmp-impl.h. 2002-01-17 Torbjorn Granlund * mpfr/mpfr-test.h: Test "__hpux", not "hpux". Mask off mrand48 return value to 31 bits to work around sloppy mpfr #include practices. * mpfr/tests/*.c: Use #include "", not <>, for gmp.h and mpfr.h. Make sure to #include mpfr-test.h from all files that use random(). 2002-01-17 Kevin Ryde * gmp-impl.h (__GMP_REALLOCATE_FUNC_MAYBE_TYPE): New macro. * gmp-impl.h, mpz/get_str.c, mpz/out_raw.c, mpq/get_str.c, mpq/set_str.c, mpf/get_str.c, printf/asprntffuns.c, printf/doprnt.c, printf/repl-vsnprintf.c, printf/snprntffuns.c, scanf/doscan.c, mpbsd/mtox.c: Some fixes to compile as C++. * mpn/generic/jacbase.c (JACOBI_BASE_METHOD): New tuned parameter, replacing COUNT_TRAILING_ZEROS_TIME test. Add a third method too. * tune/speed.c, tune/speed.h, tune/common.c, tune/Makefile.am: Add measuring of mpn_jacobi_base methods. * tune/jacbase1.c, tune/jacbase2.c, tune/jacbase3.c: New files. * tune/tuneup.c (JACOBI_BASE_METHOD): Tune this. * mpn/x86/*/gmp-mparam.h (COUNT_TRAILING_ZEROS_TIME): Remove macro. * gmp-h.in: Use __gmp prefix on variables in inlines. * gmp-impl.h (MPN_COPY_INCR, MPN_COPY_DECR): Remove __i, unused. * mpn/generic/mul_fft.c: Use HAVE_NATIVE_mpn_addsub_n, not ADDSUB. Use CNST_LIMB for some constants. 2002-01-15 Kevin Ryde * tests/mpbsd/Makefile.am: Add a convenience rule for ../libtests.la. * printf/Makefile.am: libdummy.la should be in EXTRA_LTLIBRARIES. * mpf/out_str.c: Use MPF_SIGNIFICANT_DIGITS, so mpf_out_str and mpf_get_str give the same for ndigits==0. * mpfr/exceptions.c (mpfr_set_emin, mpfr_set_emax): Work around a powerpc64 gcc 3.0 -O2 bug. * tests/memory.c, tests/tests.h (tests_memory_validate): New function. 2002-01-14 Kevin Ryde * mpn/generic/sb_divrem_mn.c, mpn/generic/divrem_1.c, mpn/generic/divrem_2.c, mpn/generic/mod_1.c: Don't use UMUL_TIME and UDIV_TIME, just default to preinv. * gmp-impl.h (USE_PREINV_DIVREM_1, USE_PREINV_MOD_1): Ditto. (DIVEXACT_1_THRESHOLD, MODEXACT_1_ODD_THRESHOLD): Don't use UMUL_TIME and UDIV_TIME, make default thresholds 0. (UDIV_NORM_PREINV_TIME, UDIV_UNNORM_PREINV_TIME): Remove macros. * mpn/x86/*/gmp-mparam.h (UMUL_TIME, UDIV_TIME, UDIV_NORM_PREINV_TIME): Remove macros. * gmp.texi (Headers and Libraries): New section, being the header notes from "GMP Basics" and some new stuff. (Parameter Conventions): Notes on "const" parameters. (Formatted Output Strings): Add type N, tweak some wording. * tests/refmpn.c (refmpn_divmod_1c): Avoid a bug in i386 gcc 3.0. 2002-01-12 Kevin Ryde * mpz/root.c: Add , for abort(). * mpfr/tests/Makefile.am (AUTOMAKE_OPTIONS): Add ansi2knr. * mpfr/mpfr.h, mpfr/mpfr-tests.h, reuse.c, tadd.c, tadd_ui.c, tagm.c, tatan.c, tcmp2.c, tcos.c, tdiv.c, tdiv_ui.c, teq.c, texp.c, tget_str.c, thyperbolic.c, tlog.c, tmul.c, tout_str.c, tpow.c, trandom.c, tset_z.c, tsin.c, tsqrt.c, tsqrt_ui.c, tsub_ui.c, ttan.c, tui_div.c: Fixes for K&R. * tests/misc/t-scanf.c (check_misc, check_misc): * tests/mpz/t-inp_str.c, tests/mpq/t-inp_str.c, tests/misc/t-scanf.c: Avoid strings in ASSERT, not enjoyed by K&R. * gmp-impl.h (ASSERT): Note this. * tests/tests.h (refmpn_mod_34lsub1): Add __GMP_PROTO. * mpbsd/Makefile.am: Avoid an automake problem with ansi2knr and sources in a different directory. * printf/repl-vsnprintf.c: Test HAVE_LONG_DOUBLE for long double. * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Add mod_34lsub1.c, mul_2.c, pre_divrem_1.c. * gmp-h.in, gmp-impl.h (mpn_add_nc, mpn_addmul_1c, mpn_addsub_n, mpn_addsub_nc, mpn_divrem_1c, mpn_dump, mpn_mod_1c, mpn_mul_1c, mpn_mul_basecase, mpn_sqr_n, mpn_sqr_basecase, mpn_sub_nc, mpn_submul_1c): Move to gmp-impl.h, since they're undocumented. * gmp-impl.h (mpn_reciprocal): Remove, unused. * tune/many.pl (cntlz, cnttz): Use new SPEED_ROUTINE_COUNT_ZEROS. 2002-01-11 Kevin Ryde * mpn/hppa/*.asm, mpn/pa64/*.asm, mpn/pa64w/*.asm: Use L(). 2002-01-08 Kevin Ryde * mpn/asm-defs.m4 (PROLOGUE, EPILOGUE): New scheme, optional function name to EPILOGUE, check for missing or wrong function name EPILOGUE. * mpn/alpha/unicos.m4, mpn/alpha/default.m4, mpn/m68k/m68k-defs.m4, mpn/mips3/mips.m4, mpn/ia64/default.m4, mpn/powerpc32/aix.m4, mpn/powerpc64/aix.m4, mpn/x86/x86-defs.m4: Consequent updates, add a few more asserts. * mpn/alpha/unicos.m4, mpn/alpha/default.m4, mpn/alpha/cntlz.asm, mpn/alpha/invert_limb.asm (PROLOGUE_GP): Change to an optional "gp" parameter on plain PROLOGUE. * gmp.texi (Low-level Functions): mpn_get_str doesn't clobber an extra limb, and doesn't clobber at all for power of 2 bases. (Language Bindings): Add python gmpy. * mpz/get_str.c: Determine realloc size arithmetically. * mpbsd/mtox.c: Size memory block returned to actual space needed. * gmp.texi (BSD Compatible Functions): Describe this. * mpz/get_str.c: Don't copy mpn_get_str input for power of 2 bases. * mpbsd/mtox.c: Ditto, and as a side effect avoid a memory leak from a missing TMP_FREE. * mpz/get_str.c, mpbsd/mout.c: No longer need for +1 limb for mpn_get_str clobber. * gmp-impl.h (MPN_GET_STR_SIZE): New macro. * mpn/generic/get_str.c, mpz/get_str.c, mpbsd/mout.c, mpbsd/mtox.c, tune/speed.h: Use it. * tests/mpn/t-g_str_size.c: New test. * tests/mpn/Makefile.am: Add it. * gmp-impl.h (POW2_P): New macro. * mpn/generic/get_str.c, tests/misc.c: Use it. * printf/doprnt.c: Add "N" for mpn, share some code between N, Q and Z. * tests/misc/t-printf.c: Add tests. * gmp-impl.h (ASSERT_CODE): New macro. * tests/mpbsd/t-mtox.c: New test. * tests/mpbsd/Makefile.am: Add it. (allfuns_LDADD): Don't link against libgmp when testing everything in libmp can link. 2002-01-07 Torbjorn Granlund * gmp-impl.h (MPN_COPY_INCR, MPN_COPY_DECR): Rewrite generic versions. 2002-01-06 Kevin Ryde * mpn/generic/pre_divrem_1.c: Don't support size==0. * tests/devel/try.c: Update. * mpn/generic/get_str.c: Add special case for base==10. * gmp-impl.h (MP_BASES_CHARS_PER_LIMB_10, MP_BASES_BIG_BASE_10, MP_BASES_BIG_BASE_INVERTED_10, MP_BASES_NORMALIZATION_STEPS_10): New constants. * tests/t-constants.c: Add checks. * mpn/mp_bases.c [GENERATE_TABLE]: Print defines for gmp-impl.h, print all standard bits-per-limb by default. * demos/pexpr.c, demos/expr/expr.h, demos/expr/expr-impl.h: Use __GMP_PROTO. * gmp-h.in (mpn_divexact_by3c): Remove variables from prototype, to keep out of application namespace. 2002-01-04 Torbjorn Granlund * gmp-impl.h: Move _PROTO declaration to before its first usages. 2002-01-04 Kevin Ryde * gmp-h.in, mp-h.in, tests/tests.h: Rename _PROTO to __GMP_PROTO, and don't use #ifndef just define it ourselves. * gmp-impl.h: Provide _PROTO as an alias for __GMP_PROTO, to avoid big edits internally, for the moment. 2002-01-03 Torbjorn Granlund * tune/speed.c (usage): Insert "\n\" into a string. 2001-12-30 Torbjorn Granlund * mpn/pa64/udiv_qrnnd.c: Remove file. * mpn/pa64w/udiv_qrnnd.c: Remove file. * gmp-impl.h (MPN_IORD_U): Change formatting (labels in pos 0, insns indented by tab). (MPN_INCR_U): Use "addl $1,foo; jc", not "incl foo; jz". * gmp-impl.h (udiv_qrnnd_preinv): Use plain subtract, not sub_ddmmss, in one more case. 2001-12-30 Kevin Ryde * mpn/generic/get_str.c (udiv_qrnd_unnorm): New macro. Use "do while" for dig_per_u loop since it's non-zero. * acconfig.h (HAVE_HOST_CPU_m68k etc): Add templates. * mpn/generic/mul_basecase.c, mpz/mul.c, mpz/n_pow_ui.c, mpn/x86/pentium/mul_2.asm, tests/devel/try.c, tests/tests.h, tests/refmpn.c, tune/speed.c, tune/speed.h, tune/common.c, tune/many.pl (mpn_mul_2): New parameter style. * gmp-impl.h (mpn_mul_2): Add prototype. * configure.in (gmp_mpn_functions_optional): Add mul_2. * longlong.h (__vxworks__): Remove from powerpc tests, not correct, not on its own at least. * tune/speed.c: Add "aas" to specify 0xAA..AA data. * tune/tuneup.c (print_define_end): Indicate "never" and "always". 2001-12-29 Torbjorn Granlund * mpq/set_d.c: ANSI-fy. * mpz/invert.c: Use PTR and SIZ (cosmetic change). * mpz/cong.c: Rename `xor' to `sign' to avoid C++ reserved word. 2001-12-28 Torbjorn Granlund * mpn/sparc64/sqr_diagonal.asm: New file. 2001-12-28 Kevin Ryde * mpn/generic/get_str.c: Avoid one mpn_divrem_1 by running main loop only until msize==1. * tune/tuneup.c: Break up all() for clarity. (USE_PREINV_DIVREM_1, USE_PREINV_MOD_1): Compare against plain division udiv_qrnnd, not the tuned and possibly preinv version. * tune/freq.c: Split sysctl and sysctlbyname probes into separate functions, shorten some identifiers, put descriptions inside functions, define functions unconditionally and do nothing if requisites not available. * mpz/inp_raw.c: Avoid a gcc 3.0 powerpc64 bug on AIX. * acinclude.m4, configure.in (GMP_C_RESTRICT): New macro. * mpfr/sin.c: Patch from Paul to fix sign of sin(3pi/2). * demos/calc/calc.y: Improve some error messages. 2001-12-28 Torbjorn Granlund * mpn/sparc64/mul_1.asm: Rename r72 -> r80. * mpn/sparc64/addmul_1.asm: Likewise. 2001-12-27 Torbjorn Granlund * mpn/generic/tdiv_qr.c: Misc formatting cleanups. For switch case 2, replace `dn' with its value (2). 2001-12-25 Torbjorn Granlund * tests/devel/mul_1.c: Add FIXED_XLIMB. * tests/devel/addmul_1.c: Likewise. * tests/devel/submul_1.c: Likewise. * tests/devel/add_n.c: Improve error message. Accept command line argument for # of tests. * tests/devel/sub_n.c: Likewise. * tests/devel/: Remove CLOCK settings. * mpn/sparc32/v9/mul_1.asm: Rewrite. * mpn/sparc32/v9/addmul_1.asm: Rewrite. * mpn/sparc32/v9/submul_1.asm: Rewrite. 2001-12-24 Torbjorn Granlund * mpn/sparc64/mul_1.asm: Get rid of global constant 0.0 (L(noll)). * mpn/sparc64/addmul_1.asm: Likewise. 2001-12-23 Torbjorn Granlund * mpn/generic/get_str.c: Move final ASSERT to just before zero fill loop. 2001-12-22 Torbjorn Granlund * mpn/generic/get_str.c: Move ASSERTs out of loops. Split digit generation code into two loops, saving a test of msize in the loop. 2001-12-22 Kevin Ryde * mpn/x86/x86-defs.m4, mpn/x86/*/*.asm: Remove L / LF scheme putting function name in local labels. * mpn/generic/get_str.c: Use mpn_preinv_divrem_1, add a couple of ASSERTs. * mpn/generic/pre_divrem_1.c: New file. * configure.in (gmp_mpn_functions): Add it. * gmp-impl.h (mpn_preinv_divrem_1): Add prototype. (USE_PREINV_DIVREM_1, MPN_DIVREM_OR_PREINV_DIVREM_1): New macros. * tests/devel/try.c, tune/speed.c, tune/speed.h, tune/common.c, tune/many.pl, tune/Makefile.am (mpn_preinv_divrem_1): Add testing and measuring. * tune/tuneup.c: Determine USE_PREINV_DIVREM_1. * tune/pre_divrem_1.c: New file. * tests/refmpn.c, tests/tests.h (refmpn_preinv_divrem_1): New function. * tests/mpz/t-io_raw.c: New file. * tests/mpz/Makefile.am (check_PROGRAMS): Add it. * mpz/inp_raw.c, mpz/out_raw.c: Rewrite. * acinclude.m4, configure.in (AC_C_BIGENDIAN): New test. * gmp-impl.h (BSWAP_LIMB): New macro. * acinclude.m4 (GMP_PROG_CC_WORKS): For a native compile, demand executables will run, per AC_PROG_CC. This detects ABI=64 is unusable in a native sparc solaris 7 build with the kernel in 32-bit mode. * gmp.texi (ABI and ISA): Add notes on this, add an example configure setting an ABI. * tune/tuneup.c, configure.in: Print the gmp-mparam.h filename. * tune/tuneup.c: Print the CPU frequency. * tune/time.c, tune/speed.h: Add s390 "stck" method, flatten conditionals in speed_time_init a bit, use have_* variables to let some code go dead in speed_starttime and speed_endtime. * tune/freq.c (speed_cpu_frequency_irix_hinv): New function. * Makefile.am, configure.in: Restore mpfr. * configure.in: Add --with-readline, AC_PROG_YACC and AM_PROG_LEX. * demos/calc/calc.y, demos/calc/calclex.l: Add readline support, add lucnum function. * demos/calc/Makefile.am: Add calcread.c, calc-common.h, use $(YACC), $(LEX) and $(LEXLIB). * demos/calc/calcread.c, demos/calc/calc-common.h, demos/calc/calc-config-h.in, demos/calc/README: New files. * configure.in: Put demos/expr configs in expr-config.h. * demos/expr/expr-config-h.in: New file. * demos/expr/expr-impl.h: Renamed from expr-impl-h.in, get configs from expr-config.h. * demos/expr/Makefile.am: Update. * demos/expr/exprfr.c: Use mpfr_sin and mpfr_cos, remove some spurious returns. 2001-12-20 Torbjorn Granlund * mpn/sparc64/mul_1.asm: Trim an instruction. * mpn/sparc64/addmul_1.asm: Likewise. * mpn/ia64/add_n.asm: Rewrite. * mpn/ia64/sub_n.asm: Rewrite. 2001-12-19 Torbjorn Granlund * mpn/ia64/mul_1.asm: Rewrite. * mpn/ia64/addmul_1.asm: Rewrite. * mpn/ia64/submul_1.c: Use TMP_ALLOC_LIMBS. * tests/devel/mul_1.c: Improve error message. Accept command line argument for # of tests. * tests/devel/addmul_1.c: Likewise. * tests/devel/submul_1.c: Likewise. 2001-12-18 Torbjorn Granlund * mpn/mips3/mul_1.asm: Add NOPs to save a cycle on R1x000. 2001-12-18 Kevin Ryde * gmpxx.h (gmp_randclass): Don't allow copy constructors or "=", implementation by Gerardo. * gmp-h.in (operator<<, operator>>): Remove parameter names from prototypes, to keep out of user namespace. * acinclude.m4 (GMP_FUNC_VSNPRINTF): Let the test program work as C++. 2001-12-16 Torbjorn Granlund * mpn/sparc64/mul_1.asm: Rewrite. * mpn/sparc64/addmul_1.asm: Rewrite. * mpn/sparc64/submul_1.asm: Rewrite. * mpn/sparc64/addmul1h.asm: Remove. * mpn/sparc64/submul1h.asm: Remove. * mpn/sparc64/mul1h.asm: Remove. 2001-12-15 Kevin Ryde * gmp-h.in (mpn_add, mpn_add_1, mpn_cmp, mpn_sub, mpn_sub_1): Follow __GMP_INLINE_PROTOTYPES for whether to give prototype with inline. * configure.in (i686*-*-*, pentiumpro-*-*, pentium[23]-*-*, athlon-*-*, pentium4-*-*): Fall back on -march=pentium if -march=pentiumpro or higher is not good (eg. solaris cmov). 2001-12-12 Torbjorn Granlund * gmp-impl.h (MPN_ZERO): Rewrite generic version to be similar to powerpc version. 2001-12-12 Kevin Ryde * acinclude.m4 (GMP_PROG_CC_WORKS): Detect cmov problems with gcc -march=pentiumpro on solaris 2.8. * tune/common.c, tune/speed.h: Allow for commas in count_leading_zeros and count_trailing_zeros macros. * demos/expr/Makefile.am: Distribute exprfr.c and exprfra.c. * tune/Makefile.am (speed_ext_SOURCES): Should be speed-ext.c. 2001-12-10 Torbjorn Granlund * mpn/s390/addmul_1.asm: New file. * mpn/s390/submul_1.asm: New file. * mpn/s390/mul_1.asm: New file. * mpn/s390/gmp-mparam.h: Update. 2001-12-07 Kevin Ryde * gmp-h.in, mp-h.in, gmp-impl.h: __GMP_DECLSPEC at start of prototypes, for the benefit of Microsoft C. * gmp.texi (Introduction to GMP): Mention ABI and ISA section. (Known Build Problems): Recommend GNU sed on solaris 2.6. (Assigning Integers): Direct feedback to bug-gmp. (References): Typo Knuth vol 2 is from 1998. * gmpxx.h (gmp_randclass): Add initializers for gmp_randinit_default and gmp_randinit_lc_2exp_size. gmp.texi (C++ Interface Random Numbers): Describe them. * tests/misc/t-locale.c, tests/cxx/t-locale.cc: Ensure mpf_clear is done when the localconv override doesn't work. Reported by Mike Jetzer. * printf/doprnti.c: Don't showbase on a zero mpq denominator. * tests/misc/t-printf.c, tests/cxx/t-ostream.c: Add test cases. 2001-12-04 Kevin Ryde * gmp.texi (Known Build Problems): Update to gmp_randinit_lc_2exp_size for the sparc solaris 2.7 problem. (Reentrancy): SCO ctype.h affects all text-based input functions. (Formatted Output Strings): Correction to the mpf example. (Single Limb Division): Correction, should be q-1 not q+1. (Extended GCD): Clarify why single-limb is inferior. (Raw Output Internals): Clarify size is twos complement, note limb order means _mp_d doesn't get directly read or written. (Contributors): Clarify mpz_jacobi. And a couple of formatting tweaks elsewhere. * tests/cxx/t-headers.cc: New file. * tests/cxx/Makefile.am: Add it. * gmpxx.h: Add , needed by mpf_class::get_str2. * gmp-h.in (mpq_inp_str, mpn_hamdist): Add __GMP_DECLSPEC. 2001-12-01 Torbjorn Granlund * Version 4.0 released. * mpfr/README: Replace contents with explanation of why mpfr is gone. 2001-12-01 Kevin Ryde * Makefile.am, configure.in: Temporarily remove mpfr, just leave a README. * mpn/Makefile.am (EXTRA_DIST): Add Makeasm.am. 2001-11-30 Gerardo Ballabio * tests/cxx/t-constr.cc, tests/cxx/t-expr.cc: New files. * tests/cxx/Makefile.am (check_PROGRAMS): Add them. 2001-11-30 Kevin Ryde * mpfr: Update to 2001-11-16. Patch TMP handling of agm.c and sqrt.c, use plain mpn_sqrtrem in sqrt.c, separate .c files for floor and ceil, disable an expression style assert in add1.c. * mpn/s370: Rename to s390. * configure.in (s3[6-9]0*-*-*): Update. * mpn/Makefile.am (TARG_DIST): Add s390. * mpz/fits_s.c, mpf/fits_s.c, mpf/fits_u.c: Remove files, unused since change to .h style. 2001-11-29 Torbjorn Granlund * gmp-h.in: Declare mpz_get_d_2exp and mpf_get_d_2exp. * Makefile.am: Add mpz/get_d_2exp$U.lo and mpf/get_d_2exp$U.lo. * mpf/Makefile.am: Add get_d_2exp.c. * mpz/Makefile.am: Add get_d_2exp.c. 2001-11-29 Kevin Ryde * mpn/*/gmp-mparam.h: Update measured thresholds. * mpn/s370/gmp-mparam.h: New file. * mpz/millerrabin.c: Mark for internal use only, for now. * gmp.texi (Number Theoretic Functions): Remove documentation. 2001-11-28 Torbjorn Granlund * mpf/get_d_2exp.c: New file. * mpz/get_d_2exp.c: New file. * mpz/realloc2.c: Fix typo. Make more similar to mpz_realloc. * mpz/realloc.c: Use __GMP_REALLOCATE_FUNC_LIMBS. 2001-11-27 Gerardo Ballabio * gmpxx.h, mpfrxx.h: Various updates and improvements. 2001-11-27 Kevin Ryde * gmp.texi (Useful Macros and Constants): Add gmp_version, add @findex for mp_bits_per_limb. * demos/perl/GMP.pm, demos/perl/GMP.xs: Use new style gmp_randinit's. * demos/perl/test.pl: Update for this, and for mpz_perfect_power_p handling of 0 and 1. 2001-11-26 Torbjorn Granlund * mpz/realloc.c: Clear variable when decreasing allocation to less than needed. Misc updates. 2001-11-25 Kevin Ryde * tests/misc/t-locale.c: Avoid printf in the normal case, since the replacement localeconv breaks it on SunOS 4. * gmp.texi (Build Options, Notes for Package Builds): Note libgmpxx depends on libgmp from same GMP version. * acinclude.m4, configure.in (GMP_FUNC_SSCANF_WRITABLE_INPUT): New test. * scanf/sscanf.c, scanf/vsscanf.c: Use it to ensure sscanf input is writable, if necessary. * tests/misc/t-scanf.c: Ensure sscanf arguments are writable, always. * configure.in (AC_CHECK_DECLS): Remove sscanf, no longer required. * configure.in (none-*-*): Fix default CFLAGS setups. * doc/configuration: Misc updates. 2001-11-23 Kevin Ryde * mpz/init2.c, mpz/realloc2.c: New files. * Makefile.am, mpz/Makefile.am: Add them. * gmp-h.in: Add prototypes. * gmp.texi (Efficiency): Mention these instead of _mpz_realloc. (Initializing Integers): Add documentation, reword other parts. 2001-11-22 Torbjorn Granlund * mpn/cray/ieee/addmul_1.c: Fix logic for more_carries scalar loop. * mpn/cray/ieee/submul_1.c: Likewise. 2001-11-20 Kevin Ryde * gmp.texi (Known Build Problems): Note an out of memory on DJGPP. (Function Classes): Update function counts. Misc tweaks elsewhere. * configure.in (AC_CHECK_DECLS): Add sscanf. * tests/misc/t-scanf.c: Use it, for the benefit of SunOS 4. * tal-debug.c, gmp-impl.h: More checks of TMP_DECL/TMP_MARK/TMP_FREE consistency. * mpfr/Makefile.am (AR): Explicit AR=@AR@ to override automake default, necessary for powerpc64 ABI=aix64. 2001-11-18 Torbjorn Granlund * mpz/powm.c: Move TMP_MARK to before any TMP_ALLOCs. 2001-11-18 Kevin Ryde * configure.in (--enable-fft): Make this the default. * gmp.texi (Build Options): Update. * Makefile.am (libmp_la_DEPENDENCIES): Revise mpz objects needed by new mpz/powm.c. * gmp.texi (Random State Initialization): Add gmp_randinit_default and gmp_randinit_lc_2exp_size, mark gmp_randinit as obsolete. (Random State Seeding): New section, taken from "Random State Initialization" and "Random Number Functions". * configure.in (AC_CHECK_DECLS): Add fgetc, fscanf, ungetc. * scanf/fscanffuns.c: Use these, for the benefit of SunOS 4. * gmp-impl.h, gmp-h.in (__gmp_default_fp_limb_precision): Move back to gmp-impl.h now not required for inlined mpf. * randlc2s.c (gmp_randinit_lc_2exp_size): New file, the size-based LC selection from rand.c. * rand.c (gmp_randinit): Use it. * randdef.c (gmp_randinit_default): New file. * gmp-impl.h (RANDS): Use it. (ASSERT_CARRY): New macro. * gmp-h.in (gmp_randinit_default, gmp_randinit_lc_2exp_size: Add prototypes. * Makefile.am (libgmp_la_SOURCES): Add randdef.c and randlc2s.c. * printf/asprntffuns.c: Include config.h before using its defines. * gmp-impl.h: Move C++ to top of file to avoid the memset redefine upsetting configure tests. Remove since in gmp.h suffices. 2001-11-16 Kevin Ryde * gmp.texi (Integer Exponentiation): mpz_powm supports negative exponents. (Assigning Floats, I/O of Floats, C++ Formatted Output, C++ Formatted Input): Decimal point follows locale. (Formatted Output Strings): %n accepts any type. (Formatted Input Strings): New section. (Formatted Input Functions): New section. (C++ Class Interface): Corrections and clarifications suggested by Gerardo. * scanf/doscan.c, scanf/fscanf.c, scanf/fscanffuns.c, scanf/scanf.c, scanf/sscanf.c, scanf/sscanffuns.c, scanf/vfscanf.c, scanf/vscanf.c, scanf/vsscanf.c, scanf/Makefile.am, tests/misc/t-scanf.c: New files. * gmp-h.in, gmp-impl.h, Makefile.am, configure.in: Consequent additions. * tests/misc: New directory. * tests/misc/Makefile.am: New file. * tests/misc/t-locale.c: New file. * tests/misc/t-printf.c: Moved from tests/printf. * tests/printf: Remove directory. * configure.in, tests/Makefile.am: Update. * tests/cxx/t-locale.cc: New file. * tests/cxx/Makefile.am: Add it. * mpf/set_str.c, cxx/ismpf.cc: Use localeconv for the decimal point. * acinclude.m4 (GMP_ASM_X86_MCOUNT): Update to $lt_prog_compiler_pic for current libtool, recognise non-PIC style mcount in windows DLLs. * gmp-impl.h (__gmp_replacement_vsnprintf): Add prototype. * gmp-impl.h (__gmp_rands, __gmp_rands_initialized, modlimb_invert_table): Add __GMP_DECLSPEC for the benefit of test programs using them from a windows DLL. * longlong.h (__clz_tab): Ditto. * mpn/x86/t-zdisp2.pl: New file. * mpn/x86/pentium4/README: New file. 2001-11-15 Torbjorn Granlund * mpz/powm.c (HANDLE_NEGATIVE_EXPONENT): #define to 1. * tests/mpz/reuse.c (main): Use mpz_invert to avoid undefined mpz_powm cases. 2001-11-14 Torbjorn Granlund * mpz/powm_ui.c: Rewrite along the lines of mpz/powm.c (except still no redc). * mpz/powm.c: Adjust for negative b, after exponentiation done. Add (still disabled) code for handling negative exponents. Misc cleanups. 2001-11-14 Kevin Ryde * mpf/out_str.c: Use localeconv for the decimal point. * tests/misc.c (tests_rand_end): Use time() if gettimeofday() not available (eg. on mingw). 2001-11-11 Kevin Ryde * gmp-h.in: Remove parameter names from prototypes, to keep out of application namespace. 2001-11-08 Kevin Ryde * acinclude.m4 (GMP_GCC_VERSION_GE): Fix sed regexps to work on Solaris 8. * printf/doprnt.c: Support %n of all types, per glibc. * gmp-h.in, gmp-impl.h, mpf/abs.c, mpf/neg.c, mpf/get_prc.c, mpf/get_dfl_prec.c, mpf/set_dfl_prec.c, mpf/set_prc_raw.c, mpf/set_si.c, mpf/set_ui.c, mpf/size.c: Revert mpf inlining, in order to leave open the possibility of keeping binary compatibility if mpf becomes mpfr. * mpn/x86/k7/mmx/lshift.asm, mpn/x86/k7/mmx/rshift.asm: Use Zdisp to force code size for computed jumps. * mpn/x86/k6/mod_34lsub1.asm, mpn/x86/k6/k62mmx/copyd.asm: Use Zdisp to force good code alignment. * mpn/x86/x86-defs.m4 (Zdisp): More instructions. * mpn/x86/pentium/sqr_basecase.asm, mpn/x86/k7/mmx/mod_1.asm, mpn/x86/k7/mmx/popham.asm: Remove some unnecessary "0" address offsets. * mpq/set_si.c, mpq/set_ui.c: Set _mp_den._mp_size correctly if den==0. 2001-11-07 Torbjorn Granlund * mpn/hppa/hppa1_1/udiv_qrnnd.asm: Work around gas bug. * mpn/asm-defs.m4 (PROLOGUE): Change alignment to 8 (probably a good idea in general; required for hppa/hppa1_1/udiv_qrnnd.asm). 2001-11-06 Torbjorn Granlund * gmp-impl.h (MPN_COPY_INCR): Prepend local variable by `__'. (MPN_COPY_DECR): Likewise. 2001-11-05 Torbjorn Granlund * mpz/powm.c: Call mpn functions, not mpz functions, for computation mod m. Streamline allocations to use a mixture of stack allocation and heap allocation. Add currently disabled phi(m) exponent reduction code. Misc optimizations and cleanups. 2001-11-05 Kevin Ryde * mpq/inp_str.c: Remove unused variable "ret". * mpn/x86/k7/sqr_basecase.asm: Fix a 0(%edi) to use Zdisp, so the computed jumps hit the right spot on old gas. * mpq/canonicalize.c: DIVIDE_BY_ZERO if denominator is zero. * mpn/lisp/gmpasm-mode.el (comment-start-skip): Correction to the way the first \( \) pair is setup. (gmpasm-font-lock-keywords): Don't fontify the space before a "#" etc. Misc tweaks to some comments. 2001-11-03 Torbjorn Granlund * tests/refmpn.c (refmpn_overlap_p): Reverse return values. 2001-11-02 Kevin Ryde * tune/many.pl: Setup CFLAGS_PIC and ASMFLAGS_PIC, since that's no longer done by configure. * mpn/x86/pentium4/mmx/popham.asm: New file. * mpn/x86/x86-defs.m4 (psadbw): New macro. * mpn/x86/k7/mmx/popham.asm: Use it. * tests/refmpn.c (refmpn_overlap_p): New function, independent of MPN_OVERLAP_P. 2001-10-31 Torbjorn Granlund * tests/mpz/t-powm.c: Print proper error message when finding discrepancy. 2001-10-31 Kevin Ryde * mpn/x86/pentium/mod_34lsub1.asm: New file. * mpn/x86/k7/mod_34lsub1.asm: New file. * mpn/x86/mod_34lsub1.asm: New file. 2001-10-30 Kevin Ryde * tests/printf/t-printf.c (check_misc): Add checks from the glibc docs. (check_vasprintf, check_vsnprintf): Run these unconditionally. * gmp-impl.h (ASSERT_MPQ_CANONICAL): New macro. * mpq/cmp.c, mpq/cmp_si.c, mpq/cmp_ui.c, mpq/equal.c: Add ASSERTs for canonical inputs, where correctness depends on it. * mpn/lisp/gmpasm-mode.el (comment-start-skip): Add "dnl". 2001-10-27 Torbjorn Granlund * demos/pexpr.c: Remove some unused variables. (main): Allocate more buffer space to accommodate minus sign. 2001-10-27 Kevin Ryde * gmp-impl.h, mpn/asm-defs.m4, configure.in, tune/speed.h, tune/speed.c, tune/common.c, tune/many.pl, tests/devel/try.c: Add mpn_mod_34lsub1. * tests/refmpn.c, tests/tests.h (refmpn_mod_34lsub1): New function. * mpn/generic/mod_34lsub1.c: New file. * mpn/x86/k6/mod_34lsub1.asm: New file. * mpn/x86/pentium4/sse2/mod_34lsub1.asm: New file. * mpn/x86/x86-defs.m4 (Zdisp): Add another instruction. * gmp-h.in, gmpxx.h: Use not whole . * gmp.texi (Known Build Problems): Add note on test programs with Windows DLLs. 2001-10-26 Kevin Ryde * tests/mpq/t-get_d.c: Limit the size of "eps" for vax. * gmp.texi (maybepagebreak): New macro, use it in a few places. (Notes for Particular Systems): C++ Windows DLLs are not supported. (Known Build Problems): Note sparc solaris 2.7 gcc 2.95.2 shared library problems. (Autoconf): Tweak version numbers shown. (Integer Roots): mpz_perfect_square_p and mpz_perfect_power_p consider 0 and 1 perfect powers, mpz_perfect_power_p accepts negatives. (Number Theoretic Functions): Add mpz_millerrabin, combined with a reworded mpz_probab_prime_p. (Formatted Output Strings): Misc clarifications. (Formatted Output Functions): gmp_asprintf, gmp_vasprintf, gmp_snprintf, gmp_vsnprintf always available. (C++ Formatted Output): Misc rewordings. (Formatted Input): New chapter. (C++ Class Interface): New chapter, by Gerardo and me. (Language Bindings): Update GMP++ now in GMP. (C++ Interface Internals): New section, by Gerardo and me. * printf/repl-vsnprintf.c: New file. * configure.in, acinclude.m4, Makefile.am, printf/Makefile.am: Use it if libc vsnprintf missing or bad. * configure.in (AC_CHECK_FUNCS): Add strnlen. * printf/snprntffuns.c, printf/vasprintf.c: Use __gmp_replacement_vsnprintf if libc vsnprintf not available. * printf/asprintf.c, printf/snprintf.c, printf/vasprintf.c, printf/vsnprintf.c: Provide these functions unconditionally. * acinclude.m4 (GMP_FUNC_VSNPRINTF): Remove warning about omissions when vsnprintf not available. 2001-10-24 Kevin Ryde * configure, aclocal.m4: Regenerate with a libtool patch for a stray quote in AC_LIBTOOL_PROG_LD_SHLIBS under mingw and cygwin. * gmp-impl.h (modlimb_invert): More comments. * printf/doprnt.c, printf/doprnti.c: Use the precision field to print leading zeros. * tests/printf/t-printf.c: Test this. * cxx/osdoprnti.cc, gmp-impl.h: Ignore precision in operator<<. * tune/speed.c, tune/speed.h, tune/common.c: Add mpn_mul_1_inplace. 2001-10-23 Torbjorn Granlund * mpz/pprime_p.c (mpz_millerrabin): Remove function and its descendant. * mpz/millerrabin.c: New file with code from pprime.c. * mpz/Makefile.am: Compile millerrabin.c. * Makefile.am (MPZ_OBJECTS): Ditto. * gmp-h.in: Declare mpz_millerrabin. 2001-10-22 Torbjorn Granlund * tests/mpz/t-perfsqr.c: New file. * tests/mpz/Makefile.am (check_PROGRAMS): Add it. * demos/factorize.c (factor): Check for number to factor == 0. (main): When invoked without arguments, read from stdin. * mpz/perfpow.c: Add code to handle negative perfect powers ((-b)^odd). Treat 0 and 1 as perfect powers. * mpn/sparc32/v9/sqr_diagonal.asm: Jump past .align. 2001-10-21 Torbjorn Granlund * mpn/generic/perfsqr.c (sq_res_0x100): Remove bogus final `,'. (mpn_perfect_square_p): Suppress superfluous `&1' in sq_res_0x100 test. (mpn_perfect_square_p, O(n) test): Improve comments. Combine remainder tests for some small primes. Don't share code for different limb sizes. Use single `if' with many `||' for better code density. 2001-10-22 Kevin Ryde * demos/perl/GMP.xs (mutate_mpz, tmp_mpf_grow): Make these "static". * mpn/x86/pentium/popcount.asm, mpn/x86/pentium/hamdist.asm (mpn_popcount_table): Use GSYM_PREFIX. 2001-10-19 Kevin Ryde * mpn/x86/*.asm: Add some measured speeds on various x86s. * tests/mpz/reuse.c, tests/mpf/reuse.c: Disable tests when using a windows DLL, because certain global variable usages won't compile. * configure.in (AC_CHECK_FUNCS): Add alarm. * tests/spinner.c: Conditionalize alarm and SIGALRM availability, for the benefit of mingw32. * acinclude.m4 (GMP_ASM_TYPE, GMP_ASM_SIZE): Suppress .type and .size on COFF. * acinclude.m4 (GMP_PROG_HOST_CC): New macro. * configure.in: Use it for windows DLL cross-compiles. * aclocal.m4, configure: Regenerate with libtool patch to hold HOST_CC in the generated libtool script. * aclocal.m4, configure: Regenerate with libtool patch to suppress warnings when probing command line limit on FreeBSD. * demos/qcn.c (M_PI): Define if not already provided, helps mingw32. 2001-10-17 Kevin Ryde * printf/doprnt.c: Use for intmax_t. * longlong.h: Recognise __sparcv8 for gcc on Solaris. Reported by Mark Mentovai . * gmp-impl.h (gmp_allocated_string): No need for inline on member funs. 2001-10-16 Kevin Ryde * gmp.texi (Debugging): Add mpatrol. (Integer Comparisons, Comparing Rationals, Float Comparison): Index entries for sign tests. (I/O of Floats): Clarify mpf_out_str exponent is in decimal. (C++ Formatted Output): mpf_t operator<< exponent now in decimal. (FFT Multiplication): Use an ascii art sigma. (Contributors): Add Gerardo Ballabio. * cxx/osfuns.cc (__gmp_doprnt_params_from_ios): Always give mpf_t exponent in decimal, irrespective of ios::hex or ios::oct. * tests/cxx/t-ostream.cc (check_mpf): Update. * printf/doprnt.c: Support %lln and %hhn. * mpn/x86/pentium4/sse2/submul_1.asm: Use a psubq to negate the initial carry (helps the submul_1c case), and improve the comments. 2001-10-11 Kevin Ryde * acinclude.m4, configure.in (GMP_IMPL_H_IEEE_FLOATS): New macro. * ltmain.sh: Send some rm errors to /dev/null, helps during compiles on Solaris 2.7 and HP-UX 10. * tal-notreent.c: Renamed from stack-alloc.c. * Makefile.am, acinclude.m4, gmp-impl.h: Update. * gmp-h.in: Don't give both prototypes and inlines, except on gcc. * gmp-h.in, gmp-impl.h: Use #includes to get necessary standard classes, add std:: to prototypes. * cxx/*.cc, tests/cxx/t-ostream.cc: Add "use namespace std". * acinclude.m4 (GMP_PROG_CXX_WORKS): Ditto. * tests/*/Makefile.in, mpfr/tests/Makefile.in: Regenerate with automake patch to avoid Ultrix problem with empty $(TESTS). * */Makefile.in: Regenerate with automake patch to only rm *_.c in "make clean" when ansi2knr actually in use, helps DOS 8.3. * Makefile.in: Regenerate with automake patch to fix stamp-h numbering, avoiding an unnecessary config.status run. 2001-10-09 Torbjorn Granlund * mpn/hppa/hppa1_1/udiv_qrnnd.asm: Use L macros for labels. Quote L reloc operator. * gmp-impl.h: Declare class string. * mpn/asm-defs.m4 (INT32, INT64): Quote $1 to prevent further expansion. * mpn/alpha/ev6/mul_1.asm: New file. 2001-10-09 Kevin Ryde * gmp.texi (Introduction to GMP): Add pentium 4 to optimized CPUs. (Build Options): Note macos directory. (Notes for Package Builds): GMP 4 series binary compatible with 3. (Known Build Problems): Remove $* and ansi2knr note, now fixed, except possibly under --host=none. (Formatted Output Strings): Remove -1 prec for all digits. * mpz/add.c, mpz/sub.c: Don't use mpz path on #include (helps macos). * mpbsd/Makefile.am (INCLUDES): Add -I$(top_srcdir)/mpz. * printf/doprnt.c, tests/printf/t-printf.c: Remove support for %.*Fe prec -1 meaning all digits. * acinclude.m4 (GMP_PROG_AR): Override libtool, use AR_FLAGS="cq". (GMP_HPC_HPPA_2_0): Print version string to config.log. * Makefile.am (AUTOMAKE_OPTIONS): Remove check-news (permission notice in NEWS file is too big). (dist-hook): Don't distribute numbered or unnumbered emacs backups. * Makefile.am, cxx/Makefile.am: Updates for Gerardo's stuff. 2001-10-09 Gerardo Ballabio * cxx/isfuns.cc: New file. * gmp-impl.h: Add prototypes. * cxx/ismpf.cc, cxx/ismpq.cc, cxx/ismpz.cc: New files. * gmp-h.in: Add prototypes. * gmpxx.h, mpfrxx.h: New files. 2001-10-08 Kevin Ryde * configure.in (with_tags): Establish a default based on --enable-cxx. * aclocal.m4: Regenerate with libtool patches for sed char range to help Cray, LTCC quotes and +Z warnings grep to help HP-UX. * gmp-impl.h (doprnt_format_t, doprnt_memory_t, doprnt_reps_t, doprnt_final_t): Use _PROTO. 2001-10-05 Torbjorn Granlund * mpn/asm-defs.m4 (INT32, INT64): Use LABEL_SUFFIX. * mpn/hppa: Convert files to `.asm'. 2001-10-05 Kevin Ryde * mpn/Makeasm.am (.S files): Revert to separate CPP and CCAS, use cpp-ccas, and only pass CPPFLAGS to CPP, not whole CFLAGS. * mpn/cpp-ccas: New file. * mpn/Makefile.am (EXTRA_DIST): Add it. * tune/common.c, tune/speed.h: Change SPEED_ROUTINE_MPN_COPY_CALL uses to SPEED_ROUTINE_MPN_COPY or new SPEED_ROUTINE_MPN_COPY_BYTES. Avoids macro expansion problems on Cray. * configure.in (AC_PROG_CXXCPP): Add this, to make libtool happier. 2001-10-04 Torbjorn Granlund * mpz/rrandomb.c (gmp_rrandomb): Change bit_pos to be 0-based (was 1-based); shift 2 (was 1) when making bit mask. These two changes avoid undefined shift counts. (gmp_rrandomb): Avoid most calls to _gmp_rand by caching random values. * mpn/generic/random2.c: Changes for mirroring mpz/rrandomb.c. 2001-10-04 Kevin Ryde * gmp.texi (Build Options): Add --enable-cxx. (Notes for Particular Systems): Mention pentium4 performance and SSE2. (Known Build Problems): Remove vax jsobgtr note, no longer needed. (Converting Floats): Tweak mpf_get_str description. (Low-level Functions): Correction to mpn_gcdext destination space requirements. (C++ Formatted Output): New section. (Language Bindings): Add ALP (Contributors): Add Paul Zimmermann's square root, update my things. * acinclude.m4 (GMP_PROG_CC_IS_GNU, GMP_PROG_CXX_WORKS): Send compiler errors to config.log. * mpq/Makefile.am (INCLUDES): Remove -DOPERATION_$*, not needed. * mpn/x86/*.asm: Change references to old README.family to just README. * mpz/README: Remove file, now adequately covered in the manual. 2001-10-03 Torbjorn Granlund * mpn/x86/pentium4/copyi.asm: New file. * mpn/x86/pentium4/copyd.asm: New file. * gmp-impl.h: Implement separate MPN_COPY_INCR and MPN_COPY_DECR macros for CRAY systems. (CRAY _MPN_COPY): Delete. 2001-10-02 Kevin Ryde * tests/mpz/t-popcount.c (check_data): Use "~ (unsigned long) 0" to avoid compiler warnings on sco. * mpbsd/Makefile.am: Compile mpz files directly, no copying. Use mpz/add.c and mpz/sub.c rather than mpz/aors.c. (INCLUDES): Remove -DOPERATION_$*, no longer needed (by mpz). * mpz/aors.h: Renamed from mpz/aors.c. * mpz/add.c, mpz/sub.c: New files, using mpz/aors.h. * mpz/aors_ui.h: Renamed from mpz/aors_ui.c. * mpz/add_ui.c, mpz/sub_ui.c: New files, using mpz/aors_ui.h. * mpz/fits_s.h: Renamed and adapted from mpz/fits_s.c. * mpz/fits_sshort.c, mpz/fits_sint.c, mpz/fits_slong.c: New files. * mpz/mul_i.h: Renamed from mpz/mul_siui.c. * mpz/mul_ui.c, mpz/mul_ui.c: New files, using mpz/mul_i.h. * mpz/Makefile.am: Consequent updates. (INCLUDES): Remove -DOPERATION_$*. * mpf/fits_s.h: Renamed and adapted from mpf/fits_s.c. * mpf/fits_sshort.c, mpf/fits_sint.c, mpf/fits_slong.c: New files. * mpf/fits_u.h: Renamed and adapted from mpf/fits_u.c. * mpf/fits_ushort.c, mpf/fits_uint.c, mpf/fits_ulong.c: New files. * mpf/Makefile.am: Consequent updates. (INCLUDES): Remove -DOPERATION_$*. * cxx/osfuns.cc (__gmp_doprnt_params_from_ios): Don't use ios::hex etc as cases in a switch, they're not constant in g++ 3.0. * mpn/Makeasm.am (.s.o, .s.obj, .S.o, .S.obj, .asm.o, .asm.obj): Locate source file with test -f the same as automake. (.S): Let CCAS do the preprocessing, and run libtool for .S.lo. (.asm.lo): Run libtool via m4-ccas to get new style foo.lo right. (COMPILE_FLAGS): Add $(DEFAULT_INCLUDES), per new automake. * mpn/m4-ccas: New file. * mpn/Makefile.am (EXTRA_DIST): Add it. * mpn/asm-defs.m4: Add m4_not_for_expansion(`DLL_EXPORT'). * mpn/x86/x86-defs.m4: Undefine PIC if DLL_EXPORT is set. * configure.in (CFLAGS_PIC, ASMFLAGS_PIC): Remove, no longer needed. * acinclude.m4 (GMP_FUNC_VSNPRINTF): Warn what's omitted when vsnprintf not available. * mpn/underscore.h: Remove file, not used since m68k converted to asm. * mpn/Makefile.am (EXTRA_DIST): Remove it. * tests/refmpz.c: Add , for free(). 2001-10-01 Torbjorn Granlund * mpn/x86/pentium4/sse2/submul_1.asm: Apply some algebraic simplifications. * mpn/x86/pentium4/sse2/addmul_1.asm: Comment. 2001-10-01 Kevin Ryde * configure.in (--enable-cxx): New option for C++ support. Add cxx and tests/cxx subdirectories. * ltmain.sh, aclocal.m4: Update to libtool 2001-09-30. * cxx/Makefile.am, cxx/Makefile.in, cxx/osdoprnti.cc, cxx/osfuns.cc, cxx/osmpf.cc, cxx/osmpq.cc, cxx/osmpz.cc: New files. * Makefile.am: Add them, in new libgmpxx. * gmp-h.in, gmp-impl.h: Prototypes and support. * tests/cxx/Makefile.am, tests/cxx/Makefile.in, tests/cxx/t-ostream.cc: New files. * tune/speed.h (SPEED_ROUTINE_MPN_GCD_CALL, SPEED_ROUTINE_MPN_GCDEXT_ONE): mpn_gcdext needs size+1 for destinations. Found by Torbjorn. * gmp-h.in (__GNU_MP__, __GNU_MP_VERSION): Bump to 4.0. * mp-h.in (__GNU_MP__): Ditto. * gmp.texi, Makefile.am, compat.c: Amend version 3.2 to 4.0. * acinclude.m4 (GMP_PROG_CXX_WORKS): New macro. (GMP_PROG_CC_WORKS): Write "conftest" test program, not a.out. * gmp-impl.h (struct gmp_asprintf_t): Moved from printf/vasprintf.c. (GMP_ASPRINTF_T_INIT): New macro. (GMP_ASPRINTF_T_NEED): New macro, adapted from vasprintf.c NEED(). * printf/vasprintf.c: Use these. * printf/asprntffuns.c: New file. * printf/Makefile.am, Makefile.am: Add it. * printf/asprntffuns.c, printf/vasprintf.c, gmp-impl.h (__gmp_asprintf_memory, __gmp_asprintf_reps, __gmp_asprintf_final): Move to asprntffuns.c, rename to __gmp and make global, remove spurious formal parameters from __gmp_asprintf_final. * configure.in (j90-*-*, sv1-*-*): Don't duplicate $path in $add_path. (*-*-mingw*): Don't assemble with -DPIC (as per cygwin). * printf/snprntffuns.c (gmp_snprintf_final): Remove spurious formal parameters. * tune/tuneup.c (POWM_THRESHOLD): Reduce stop_factor to 1.1 to help Cray vector systems. * tests/misc.c (tests_rand_start): Print GMP_CHECK_RANDOMIZE=NN to facilitate cut and paste when re-running. * tests/mpz/t-inp_str.c (check_data): Add more diagnostic prints. 2001-09-30 Kent Boortz * macos/configure, macos/Makefile.in, macos/README: Updates for gmp 4. * gmp-h.in (_GMP_H_HAVE_FILE): Recognise Apple MPW. 2001-09-30 Torbjorn Granlund * mpn/cray/ieee/submul_1.c: Rewrite. Streamline multiplications; use `majority' logic. 2001-09-27 Torbjorn Granlund * gmp-h.in (__GMPN_AORS_1): Rewrite to work around Cray compiler bug. 2001-09-26 Torbjorn Granlund * mpn/x86/pentium4/sse2/gmp-mparam.h: New file. 2001-09-26 Kevin Ryde * mpn/x86/pentium4/sse2/dive_1.asm: New file. * mpn/x86/pentium4/sse2/submul_1.asm: New file. * mpn/x86/pentium4/sse2/sqr_basecase.asm: New file. * mpn/x86/pentium/copyi.asm: New file, based on past work by Torbjorn. * mpn/x86/pentium/copyi.asm: New file, ditto. * mpn/x86/pentium/com_n.asm: Rewrite, ditto. * printf/snprntffuns.c (gmp_snprintf_format): Copy va_list in case vsnprintf trashes it. * printf/vasprintf.c (gmp_asprintf_format): Ditto. * gmp-impl.h, doprnt.c (va_copy): Move to gmp-impl.h. * tests/mpz/t-cmp_d.c (check_low_z_one): Patch by Torbjorn for vax limited float range. 2001-09-23 Torbjorn Granlund * mpn/vax/lshift.s: Change `jsob*' to `sob*'. * mpn/vax/rshift.s: Likewise. 2001-09-23 Kevin Ryde * mpn/x86/pentium4/sse2/mul_basecase.asm: Some simple but real code. * printf/doprnt.c: Use va_copy for va_list variables, copy function parameter in case it's call-by-reference. * tune/freq.c (speed_cpu_frequency_bsd_dmesg): New function. (speed_cpu_frequency_table): Use it. * tune/many.pl (popcount, hamdist): Fix declared return value. (sb_divrem_mn): Remove a spurious duplicate entry. (CLEAN): Add tmp-$objbase.c when using that for .h files. (macro_speed): Give a default for .h files. Add ATTRIBUTE_CONST or __GMP_ATTRIBUTE_PURE as appropriate. * tune/speed.h (SPEED_ROUTINE_MPN_MOD_CALL, SPEED_ROUTINE_MPN_PREINV_MOD_1, SPEED_ROUTINE_MPN_POPCOUNT, SPEED_ROUTINE_MPN_HAMDIST, SPEED_ROUTINE_MPN_GCD_1N, SPEED_ROUTINE_MPN_GCD_1_CALL, SPEED_ROUTINE_MPZ_JACOBI): Use return values so gcc 3 won't discard calls to pure or const functions. (mpn_mod_1_div, mpn_mod_1_inv): Add __GMP_ATTRIBUTE_PURE. 2001-09-22 Torbjorn Granlund * mpn/x86/pentium4/sse2/mul_basecase.asm: New file, placeholder for real code, hiding the default x86 mul_basecase.asm. 2001-09-22 Kevin Ryde * configure.in (AC_PREREQ): Bump to 2.52. (m4_pattern_forbid, m4_pattern_allow): New calls, forbid GMP_. (AC_CHECK_HEADERS): Remove sys/types.h, already done by autoconf. * acinclude.m4, configure.in (GMP_GCC_NO_CPP_PRECOMP): New macro. * tests/devel/try.c (TYPE_PREINV_MOD_1): Don't run size==0. (malloc_region): Need fd=-1 for mmap MAP_ANON on BSD. 2001-09-20 Torbjorn Granlund * mpz/cong.c (mpz_congruent_p): Fix one-limb c * mpn/x86/pentium4/sse2/diveby3.asm: New file. * mpn/x86/pentium4/sse2/mode1o.asm: New file. 2001-09-16 Kevin Ryde * printf/doprnt.c: '#' means showpoint and showtrailing for %e, %f, %g. * tests/printf/t-printf.c (check_f): More test cases. 2001-09-15 Torbjorn Granlund * gmp-h.in (__GMPN_AORS_1): Remove param TEST, add OP and CB. Postpone zeroing of (cout). (__GMPN_ADD_1, __GMPN_SUB_1): Corresponding changes. 2001-09-14 Kevin Ryde * ChangeLog: Merge in tests/rand/ChangeLog. * tests/rand/ChangeLog: Remove file. * printf/doprnt.c: Fix handling of a plain format after a GMP one; no need to protect against negative precision internally. * tests/printf/t-printf.c (check_misc): More checks. 2001-09-12 Torbjorn Granlund * mpn/cray/ieee/invert_limb.c: Add a PROLOGUE in a comment to have HAVE_NATIVE_... defined. 2001-09-11 Kevin Ryde * configure.in, gmp-h.in (__GMP_HAVE_HOST_CPU_FAMILY_power, __GMP_HAVE_HOST_CPU_FAMILY_powerpc): New AC_SUBSTs. * gmp-h.in (__GMPN_COPY_INCR): Use them to select the power/powerpc code, rather than preprocessor defines. * acinclude.m4, configure.in (GMP_H_ANSI): New macro. * gmp-h.in (__GMP_EXTERN_INLINE): Add a definition for SCO 8 cc. * gmp-h.in, version.c (gmp_version): Make the pointer "const" as well as the string. * acinclude.m4, configure.in (GMP_PROG_CC_IS_XLC): Recognise xlc when invoked under another name (cc, xlc128, etc). * acinclude.m4 (GMP_PROG_CC_IS_GCC): Print a message when recognised. 2001-09-11 Torbjorn Granlund * gmp-h.in: Let __DECC mean __GMP_HAVE_CONST, etc. * mp-h.in: Likewise. 2001-09-10 Torbjorn Granlund * mpn/x86/pentium4/mmx/lshift.asm: New file. * mpn/x86/pentium4/mmx/rshift.asm: New file. * tests/mpn/t-iord_u.c (check_incr_data): Work around HP compiler bug. (check_decr_data): Likewise. 2001-09-08 Kevin Ryde * gmp.texi (Integer Logic and Bit Fiddling): Update mpz_hamdist behaviour, clarify mpz_popcount a touch. (Language Bindings): Add mlton, fix alphabetical order. (Single Limb Division): Describe 2 or 1/2 limbs at a time style. * configure.in (AC_CHECK_FUNCS): Add mmap. * tests/devel/try.c (malloc_region): Use mmap if available. * tests/refmpz.c, tests/tests.h (refmpz_hamdist): New function. * tests/mpz/t-hamdist.c: New file. * tests/mpz/Makefile.am: Add it. * mpz/hamdist.c: Support neg/neg operands. * macos/Makefile.in: Remove dual compile of mpq/aors.c and mpn/generic/popham.c. * gmp-impl.h (popc_limb): New macro, adapted from mpn/generic/popham.c. For 64-bits reuse 0x33...33 constant. * mpn/generic/popcount.c, mpn/generic/hamdist.c: Split from popham.c, use popc_limb macro, remove unused "i", don't bother with "register" qualifiers. * mpn/generic/popham.c: Remove file. * ltmain.sh, configure, aclocal.m4: Update to libtool 1.4.1, with one ltdll.c generation patch. * doc/configuration: Misc updates, note libtool patch used. * mpn/x86/pentium4/sse2/mul_1.asm: Use pointer increments not indexed addressing, to get 4.0 c/l flat. * tests/mpq/t-cmp_si.c (check_data): Use ULONG_MAX for denominators. * tests/misc.c (mpz_negrandom): Use given rstate, not RANDS. 2001-09-07 Torbjorn Granlund * mpn/x86/pentium4/sse2/addmul_1.asm: New file. 2001-09-04 Kevin Ryde * tune/freq.c: Define a HAVE for each speed_cpu_frequency routine to avoid duplicating conditionals. (speed_cpu_frequency_sco_etchw): New function. (speed_cpu_frequency_table): Use it. * tune/README: Mention SCO openunix 8 /etc/hw. * mpz/fib_ui.c: Use ?: to avoid a gcc 3 bug on powerpc64. Store back a carry for limb * configure.in (m68k-*-*): Let m68k mean 68000, not 68020. * gmp.texi (Notes for Particular Systems): Update. * gmp-impl.h (union ieee_double_extract) [m68k]: Use longs, since int might be only 16 bits. * tests/mpq/t-aors.c: New file. * tests/mpq/Makefile.am: Add it. * tests/refmpq.c: New file. * tests/Makefile.am: Add it. * tests/tests.h: Add prototypes. * mpq/aors.c: Share object code for mpq_add and mpq_sub. * Makefile.am, mpq/Makefile.am: Single mpq/aors.lo now. * tests/devel/try.c (TYPE_SUBMUL_1): Use correct reference routine. 2001-08-30 Kevin Ryde * mpn/x86/x86-defs.m4 (cmov_available_p): Add pentium4. * gmp-h.in: Put #define renamings with prototypes. Remove commented out #defines of gmp-impl.h things. (mpn_invert_limb): Remove #define, already in gmp-impl.h. (mpn_lshiftc, mpn_rshiftc): Remove #defines, unused. (mpn_addsub_nc): Add prototype to #define. 2001-08-28 Kevin Ryde * gmp.texi: Switch to GFDL. (Top): Arrange copyright and conditions to appear here too. For clarity have all this before the miscellaneous macro definitions. (Copying): Refer to COPYING.LIB file, mention plain GPL2 in demo programs. (Contributors, References): Use @appendix rather than @unnumbered. (GNU Free Documentation License): New appendix. (@contents): Move to start of document, use only for tex (not html). (Debugging): Add leakbug. (Build Options): Add pentium4. (I/O of Rationals): Add mpq_inp_str. * fdl.texi: New file, with two @appendix directive tweaks. * Makefile.am (gmp_TEXINFOS): Add it. * tests/mpz/io.c: Check mpz_inp_str return against ftell, send error messages just to stdout. * mpz/inp_str.c, gmp-impl.h (__gmpz_inp_str_nowhite): New function, and share a __gmp_free_func call. * mpq/inp_str.c: New file. * Makefile.am, mpq/Makefile.am: Add it. * tests/mpq/t-inp_str.c: New file. * tests/mpq/Makefile.am (check_PROGRAMS): Add it. * configure.in, acconfig.h (HAVE_HOST_CPU_FAMILY_power, HAVE_HOST_CPU_FAMILY_powerpc, HAVE_HOST_CPU_FAMILY_x86): AC_DEFINEs for processor families. * gmp-impl.h: Use them, rather than cpp defines. * demos/Makefile.am (primes_LDADD): Use $(LIBM), for log(). * tune/many.pl, tune/Makefile.am: Fix some from clean and distclean. 2001-08-26 Kevin Ryde * tests/devel/try.c (ARRAY_ITERATION): Make types match on "?:" legs. (TYPE_MPZ_JACOBI, TYPE_MPZ_KRONECKER): Remove some superseded code. * tests/printf/t-printf.c (check_plain): Don't compare "all digits" precision against plain printf. * tune/Makefile.am: Eliminate empty TUNE_MPZ_SRCS. * configure, config.in, INSTALL.autoconf: Update to autoconf 2.52. * */Makefile.in, mdate-sh, missing, aclocal.m4, configure: Update to automake 1.5. * configfsf.guess, configfsf.sub: Update to 2001-08-23. 2001-08-24 Torbjorn Granlund * demos/primes.c: Complete rewrite. 2001-08-24 Kevin Ryde * longlong.h: Test __ppc__ for apple darwin cc, reported by Jon Becker. Also test __POWERPC__, PPC and __vxworks__. * tune/speed.h (speed_cyclecounter) [x86]: Don't clobber ebx in PIC. 2001-08-22 Kevin Ryde * configure.in (x86 mmx): Correction to mmx path stripping. 2001-08-17 Kevin Ryde * configure.in, acinclude.m4, Makefile.am, printf/Makefile.am, tests/printf/Makefile.am, gmp-h.in, gmp-impl.h, gmp.texi: Remove C++ support, for the time being. * printf/doprntfx.cc, doprntix.cc, osfuns.cc, osmpf.cc, osmpq.cc, osmpz.cc, tests/printf/t-ostream.cc: Remove files. * printf/doprnt.c, printf/doprntf.c, gmp-impl.h: Use a single __gmp_doprnt_mpf, rather than a separate ndigits calculation. * printf/doprnt.c, printf/doprntf.c, gmp-impl.h, gmp.texi, tests/printf/t-printf.c: Let empty or -1 prec mean all digits for mpf. * printf/doprnt.c, tests/printf/t-printf.c: Accept h or l in %n; let negative "*" style width mean left justify. * gmp-impl.h, mpf/get_str.c (MPF_SIGNIFICANT_DIGITS): New macro, extracted from mpf/get_str.c. * libmp.sym: New file. * Makefile.am (libmp_la_LDFLAGS): Use it. (DISTCLEANFILES): Remove asm-syntax.h, no longer generated. Remove some comments about "make check". * demos/perl/GMP.pm, GMP.xs, GMP/Mpf.pm: Add printf and sprintf, change get_str to string/exponent for floats, remove separate mpf_get_str. * demos/perl/GMP/Mpf.pm (overload_string): Use $# (default "%.g"). * demos/perl/typemap: Fix some duplicate string entries. * demos/perl/test.pl: Update tests, split overloaded constants into ... * demos/perl/test2.pl: ... this new file. * demos/perl/Makefile.PL (clean): Add test.tmp. 2001-08-16 Kevin Ryde * printf/snprntffuns.c (gmp_snprintf_format): Correction to bufsize-1 return value handling. * demos/calc/calc.y: Reposition "%{" so copyright notice gets into generated files. * INSTALL: Use gmp_printf. 2001-08-14 Kevin Ryde * mpz/inp_str.c: Fix return value (was 1 too big). * tests/mpz/t-inp_str.c: New file. * tests/mpz/Makefile.am: Add it. * mpn/x86/pentium4/sse2/add_n.asm: New file. * mpn/x86/pentium4/sse2/sub_n.asm: New file. * mpn/x86/pentium4/sse2/mul_1.asm: New file. 2001-08-12 Kevin Ryde * printf/sprintffuns.c, printf/doprntf.c: Don't use sprintf return value (it's a pointer on SunOS 4). * acinclude.m4 (GMP_ASM_X86_SSE2, GMP_STRIP_PATH): New macros. * configure.in: Add pentium4 support. * mpn/x86/pentium4, mpn/x86/pentium4/mmx, mpn/x86/pentium4/sse2: New directories. * mpn/x86/README: Update. 2001-08-10 Torbjorn Granlund * demos/pexpr.c (setup_error_handler): Catch also SIGABRT. 2001-07-31 Kevin Ryde * tests/refmpn.c (refmpn_mul_1c): Allow low to high overlaps. * gmp-h.in, gmp-impl.h (_gmp_rand): Move prototype to gmp-impl.h. * tune/Makefile.am (EXTRA_DIST): Add many.pl. 2001-07-28 Kevin Ryde * gmp.texi (Random Number Functions): Old rand functions no longer use the C library. * configure.in, acinclude.m4 (GMP_FUNC_VSNPRINTF): New macro. * mpn/generic/get_str.c: Add an ASSERT for high limb non-zero. 2001-07-24 Kevin Ryde * gmp.texi (Build Options): Add --enable-cxx. (Converting Floats): Note mpf_get_str only generates accurately representable digits. (Low-level Functions): Note mpn_get_str requires non-zero high limb. (Formatted Output): New chapter. (Multiplication Algorithms): Use @quotation with @multitable. (Toom-Cook 3-Way Multiplication): Ditto. * tests/memory.c (tests_free_nosize): New function. * tests/tests.h (tests_allocate etc): Add prototypes. * tests/printf: New directory. * tests/printf/Makefile.am, t-printf.c, t-ostream.cc: New files. * configure.in, tests/Makefile.am: Add them. * configure.in, acinclude.m4 (GMP_PROG_CXX): New macro. * configure.in (--enable-cxx): New option. (AC_CHECK_HEADERS): Add locale.h and sys/types.h, remove unistd.h. (AC_CHECK_TYPES): Add intmax_t, long double, long long, ptrdiff_t, quad_t. (AC_CHECK_FUNCS): Add localeconv, memset, obstack_vprintf, snprintf, strchr, vsnprintf. (AC_CHECK_DECLS): Add vfprintf. * gmp-h.in, gmp-impl.h: Additions for gmp_printf etc. * printf: New directory. * printf/Makefile.am, asprintf.c, doprnt.c, doprntf.c, doprntfx.cc, doprnti.c, doprntix.cc, fprintf.c, obprintf.c, obprntffuns.c, obvprintf.c, osfuns.cc, osmpf.cc, osmpq.cc, osmpz.cc, printf.c, printffuns.c, snprintf.c, snprntffuns.c, sprintf.c, sprintffuns.c, vasprintf.c, vfprintf.c, vprintf.c, vsnprintf.c, vsprintf.c: New files. * configure.in, Makefile.am: Add them. * configure.in (HAVE_INLINE): Remove AC_DEFINE, unused. (AC_CHECK_TYPES): Don't test for void, assume it always exists. * gmp-impl.h (__GMP_REALLOCATE_FUNC_MAYBE): New macro. * mpz/get_str.c, mpq/get_str.c, mpf/get_str.c: Use it. * gmp-impl.h (mpn_fib2_ui): Use __MPN. (MPN_COPY_DECR): Fix an ASSERT. (CAST_TO_VOID): Remove macro. * gmp-h.in (mpq_out_str): Give #define even without prototype. (mpz_cmp_d, mpz_cmpabs_d): Corrections to #defines. * tests/devel/try.c: Add mpn_add and mpn_sub, don't use CAST_TO_VOID. 2001-07-23 Torbjorn Granlund * config.guess: Recognize pentium4. * config.sub: Recognize pentium4. 2001-07-17 Kevin Ryde * gmp-h.in (__GMPN_AORS_1): Remove x86 and gcc versions, leave just one version. (__GMPN_ADD, __GMPN_SUB): New macros, rewrite of mpn_add and mpn_sub. (mpn_add, mpn_sub): Use them. (__GMPN_COPY_REST): New macro. * gmp-h.in, gmp-impl.h, acinclude.m4: Remove __GMP_ASM_L and __GMP_LSYM_PREFIX, revert to ASM_L in gmp-impl.h and AC_DEFINE of LSYM_PREFIX. 2001-07-11 Kevin Ryde * gmp-h.in (__GMPN_ADD_1 etc) [x86]: Don't use this on egcs 2.91. * mpz/fits_uint.c, fits_ulong.c, mpz/fits_ushort.c: Split up fits_u.c. * mpz/fits_u.c: Remove file. * mpz/Makefile.am, macos/Makefile.in: Update. * tests/refmpn.c,tests.h (refmpn_copy): New function. * tests/devel/try.c (TYPE_ZERO): No return value from call. (TYPE_MODEXACT_1_ODD, TYPE_MODEXACT_1C_ODD): Share call with TYPE_MOD_1 and TYPE_MOD_1C. (MPN_COPY, __GMPN_COPY, __GMPN_COPY_INCR): Add testing. 2001-07-10 Kevin Ryde * gmp-h.in (__GMPN_COPY): Add form to help gcc on power and powerpc. * gmp-impl.h (MPN_COPY_INCR, MPN_COPY_DECR, MPN_ZERO): Ditto. * mpn/powerpc64/copyi.asm, mpn/powerpc64/copyd.asm: Remove files. * mpz/tdiv_ui.c: Eliminate some local variables (seems to save code on i386 gcc 2.95.x), remove a bogus comment about quotient. * errno.c, gmp-impl.h (__gmp_exception, __gmp_divide_by_zero, __gmp_sqrt_of_negative): New functions. * gmp-impl.h (GMP_ERROR, DIVIDE_BY_ZERO, SQRT_OF_NEGATIVE): Use them. * randclr.c, randraw.c: Use ASSERT(0) for unrecognised algorithms. 2001-07-07 Kevin Ryde * configure.in (powerpc*-*-*): Use -no-cpp-precomp for Darwin. * tests/mpbsd/t-itom.c: Renamed from t-misc.c. * tests/mpbsd/t-misc.c: Remove file. * tests/mpbsd/Makefile.am: Update. * tests/mpf/t-set_si.c,t-cmp_si.c,t-gsprec.c: Split from t-misc.c. * tests/mpf/t-misc.c: Remove file. * tests/mpf/Makefile.am: Update. * tests/mpz/t-oddeven.c,t-set_si.c,t-cmp_si.c: Split from t-misc.c. * tests/mpz/t-misc.c: Remove file. * tests/mpz/Makefile.am: Update. * stack-alloc.c: Add some alignment ASSERTs. * gmp-impl.h (MPN_NORMALIZE): Add notes on x86 repe/scasl slow. * tests/devel/try.c (MPN_ZERO): Add testing. * tune/speed.c,speed.h,common.c,many.pl (MPN_ZERO): Add measuring. * mpn/x86/divrem_1.asm: Update a remark about gcc and "loop". * tests/mpq/t-cmp_si.c: New file. * tests/mpq/Makefile.am: Add it. * tests/misc.c,tests.h (mpq_set_str_or_abort): New function. * mpq/cmp_si.c: New file. * Makefile.am, mpq/Makefile.am: Add it. * gmp-h.in (mpq_cmp_si): Add prototype. * gmp.texi (Comparing Rationals): Add doco. * gmp-h.in (_GMP_H_HAVE_FILE): Add _FILE_DEFINED for microsoft, add notes on what symbols are for what systems. 2001-07-06 Torbjorn Granlund * longlong.h (ibm032 umul_ppmm): Fix typo. * longlong.h (sparclite sdiv_qrnnd): Fix typo. 2001-07-03 Kevin Ryde * mpz/bin_ui.c (DIVIDE): Use MPN_DIVREM_OR_DIVEXACT_1. * mpz/bin_uiui.c (MULDIV): Ditto, and use local variables for size and pointer. * acinclude.m4 (GMP_INCLUDE_GMP_H): New macro, use it everywhere gmp.h is wanted at configure time. * acinclude.m4, configure.in (GMP_H_EXTERN_INLINE, GMP_H_HAVE_FILE): New macros. * gmp-h.in (__GMP_EXTERN_INLINE): Set to "inline" for C++. (mpn_add, mpn_sub): Use new style __GMP_EXTERN_INLINE. * gmp-h.in, mp-h.in, gmp-impl.h (_EXTERN_INLINE): Remove, unused. * mpn/generic/add.c, mpn/generic/sub.c: New files. * mpn/generic/inlines.c: Remove file. * configure.in, mpn/Makefile.am: Update. * gmp.texi (GMP Basics): Note the need for stdio.h to get FILE prototypes. 2001-07-01 Kevin Ryde * gmp.texi (Build Options, Reentrancy): Updates for new --enable-alloca behaviour. (Debugging): Describe --enable-alloca=debug. (Miscellaneous Integer Functions): Note mpz_sizeinbase ignores signs. (Low-level Functions): Give a formula for mpn_gcdext cofactor. (Factorial Algorithm): New section. (Binomial Coefficients Algorithm): New section. Misc tweaks elsewhere. * mpf/set_prc.c: Merge the two truncation conditionals, misc cleanups, no functional changes. * mpn/*/gmp-mparam.h (DIVEXACT_1_THRESHOLD): Add tuned values. * gmp-impl.h (DIVEXACT_1_THRESHOLD): Make the default 0 when 2*UMUL_TIME < UDIV_TIME. * mpn/x86/p6/dive_1.asm: New file. * mpn/x86/dive_1.asm: New file. * mpn/x86/gmp-mparam.h (DIVEXACT_1_THRESHOLD): Use it always. * tests/refmpn.c, tests.h (refmpn_zero): New function. * tests/devel/try.c: Use it. * tests/refmpn.c (refmpn_sb_divrem_mn): Use refmpn_cmp, not mpn_cmp. * tests/mpf/t-get_d.c (main): Use || not |. * tests/misc.c, tests/t-modlinv.c, tests/mpq/t-get_str.c, tests/mpf/reuse.c: Add string.h. 2001-06-29 Kevin Ryde * tune/speed.h (SPEED_ROUTINE_MPN_FIB2_UI, SPEED_ROUTINE_COUNT_ZEROS_C): Corrections to TMP block handling. * gmp-impl.h (MPN_TOOM3_MUL_N_MINSIZE, MPN_TOOM3_SQR_N_MINSIZE): Corrections to these to account for adding tD into E. (MPN_INCR_U, MPN_DECR_U) [WANT_ASSERT]: Add size assertions, since mpn_add_1 and mpn_sub_1 from gmp.h don't get them. (MPN_DIVREM_OR_DIVEXACT_1): Add an assert of no remainder. * assert.c: Add stdlib.h for abort prototype. * tests/spinner.c, trace.c, t-constants.c, t-count_zeros.c, t-gmpmax.c, t-modlinv.c: Ditto. * tests/mpz/t-bin.c, t-cmp.c, t-get_si.c, t-misc.c, t-popcount.c, t-set_str.c, t-sizeinbase.c: Ditto. * tests/mpq/t-equal.c, t-get_str.c, t-set_f.c, t-set_str.c: Ditto. * tests/mpf/t-fits.c, t-get_d.c, t-get_si.c, t-int_p.c, t-misc.c, t-trunc.c: Ditto. * tests/mpbsd/allfuns.c, t-misc.c: Ditto. * mpn/generic/mul_n.c, mpz/cfdiv_r_2exp.c: Use MPN_INCR_U rather than mpn_incr_u. * tests/devel/try.c (TYPE_SB_DIVREM_MN): More fixes for calling method. * mpn/x86/k6/cross.pl: More insn exceptions. 2001-06-23 Kevin Ryde * gmp-h.in (__GMPN_ADD_1, __GMPN_SUB_1) [i386]: Fix some asm output constraints. * gmp-impl.h (modlimb_invert): Mask after shifting, so mask constant fits a signed byte. * tests/devel/try.c (TYPE_SB_DIVREM_MN): Fix initial fill of quotient with garbage. 2001-06-20 Kevin Ryde * config.guess (rs6000-*-aix4* | powerpc-*-aix4*): Suppress error messages if $CC_FOR_BUILD or program don't work. * mpz/sqrt.c,sqrtrem.c: Special case for op==0, to avoid TMP_ALLOC(0). * tests/refmpf.c (refmpf_add, refmpf_sub): Avoid TMP_ALLOC(0). * tests/mpn/t-aors_1.c: New file. * tests/mpn/Makefile.am: Add it. * gmp-h.in (__GMPN_ADD_1, __GMPN_SUB_1): New macros, rewrite of mpn_add_1 and mpn_sub_1, better code for src==dst and/or n==1, separate versions for gcc x86, gcc generic, and non-gcc. (mpn_add_1, mpn_sub_1): Use them. (mpn_add, mpn_sub): Ditto, to get inlines on all compilers. (extern "C") [__cplusplus]: Let this encompass the extern inlines too. * mpn/generic/add_1.c,sub_1.c: New files, force code from gmp.h. * configure.in, mpn/Makefile.am: Add them. * acinclude.m4 (GMP_ASM_LSYM_PREFIX): AC_SUBST __GMP_LSYM_PREFIX rather than AC_DEFINE LSYM_PREFIX. * gmp-h.in (__GMP_LSYM_PREFIX): New substitution. (__GMP_ASM_L): New macro. * gmp-impl.h (ASM_L): Use it. * acinclude.m4, configure.in (GMP_C_ATTRIBUTE_MALLOC): New macro. * gmp-impl.h: Use it for all the malloc based TMP_ALLOCs. * stack-alloc.h: Remove file. * tal-reent.c: New file. * Makefile.am: Update. * acinclude.m4, configure.in (GMP_OPTION_ALLOCA): New macro, add malloc-reentrant method, use stack-alloc.c as malloc-notreentrant, make "reentrant" the default. * gmp-impl.h (__TMP_ALIGN): Moved from stack-alloc.c, use a union to determine the value, and demand only 4 bytes align on 32-bit systems. * gmp-impl.h (WANT_TMP_NOTREENTRANT): Move global parts of stack-alloc.h to here, allow non power-of-2 __TMP_ALIGN in TMP_ALLOC. * gmp-impl.h: Extend extern "C" to TMP_ALLOC declarations. * stack-alloc.c (tmp_stack): Move private parts of stack-alloc.h to here, use gmp-impl.h. * gmp-impl.h (TMP_ALLOC_LIMBS_2): New macro. * mpz/fib_ui.c, mpz/jacobi.c, mpq/cmp.c, mpn/generic/fib2_ui.c: Use it. * mpfr/exp2.c: Patch by Paul to match TMP_MARK and TMP_FREE in loop. * mpfr/sqrt.c: Scope nested TMP_DECL into nested { } block, patch by Paul, tweaked by me. * mpfr/agm.c: Ditto, and add a final TMP_FREE(marker2). * gmp-h.in (mpn_cmp): Add __GMP_ATTRIBUTE_PURE. * INSTALL: Clarify "make install", tweak formatting a bit. 2001-06-17 Kevin Ryde * configure.in, Makefile.am, gmp-impl.h: Add a debugging TMP_ALLOC, selected with --enable-alloca=debug. * tal-debug.c: New file. * configure.in, Makefile.am: Compile stack-alloc.c only for --disable-alloca. * assert.c (__gmp_assert_header): New function, split from __gmp_assert_fail. * mpz/lcm.c: Don't TMP_MARK and then just return. Remove unnecessary _mpz_realloc prototype. * mpn/generic/mul.c (mpn_sqr_n): Use __gmp_allocate_func for toom3 temporary workspace. 2001-06-15 Kevin Ryde * tests/mpz/t-set_f.c: New file. * tests/mpz/Makefile.am (check_PROGRAMS): Add it. * mpz/set_f.c: Share MPN_COPY between pad and trunc cases, do exp<=0 test earlier, store SIZ(w) earlier. * tests/t-count_zeros.c: New file. * tests/t-gmpmax.c: New file. * tests/Makefile.am (check_PROGRAMS): Add them. * mp_clz_tab.c: Compile the table only if longlong.h says it's needed; add an internal-use-only comment. * tune/common.c: Force a __clz_tab for convenience when testing. * mpn/x86/pentium/gmp-mparam.h, mpn/x86/pentium/mmx/gmp-mparam.h: Add COUNT_LEADING_ZEROS_NEED_CLZ_TAB, for mod_1.asm. * longlong.h (count_leading_zeros) [pentium]: Decide to go with float method for p54. (count_leading_zeros) [alpha]: Add COUNT_LEADING_ZEROS_NEED_CLZ_TAB. (__clz_tab): Provide a prototype only if it's needed. * tests/trace.c (mpz_trace): Don't use = on structures. (mpn_trace): Set _mp_alloc when creating mpz. 2001-06-12 Kevin Ryde * mpn/x86/divrem_1.asm: Amend some comments about P5 speed. * tune/README: Clarify reconfigure on gmp-mparam.h update. * mpn/x86/p6/copyd.asm: New file. * mpn/x86/p6/README: Update copyd and mod_1. * mpn/x86/copyd.asm: Amend some comments. * gmp-impl.h (__builtin_constant_p): Add dummy for non-gcc. (mpn_incr_u, mpn_decr_u): Recognise incr==1 at compile time in the generic code on gcc. * gmp-impl.h (ASSERT_ZERO_P, ASSERT_MPN_NONZERO_P): New macros. * mpn/generic/gcd_1.c, mpn/generic/mul_fft.c: Use them. * mpz/get_d.c: Add a private mpn_zero_p. * mpfr/trunc.c: Use own mpn_zero_p. * tune/speed.h (SPEED_ROUTINE_MPN_GCD_1N): Use refmpn_zero_p. * gmp-impl.h (mpn_zero_p): Remove, no longer needed. * gmp-h.in, gmp-impl.h: Move MPN_CMP to gmp.h as __GMPN_CMP, leave an MPN_CMP alias in gmp-impl.h. * gmp-h.in (mpn_cmp): Add an inline version. * mpn/generic/cmp.c: Use __GMP_FORCE_mpn_cmp to get code from gmp.h. * acinclude.m4 (GMP_C_ATTRIBUTE_MODE): New macro. * configure.in: Call it. * gmp-impl.h (SItype etc): Use it. * randraw.c (lc): Change mpn_mul_basecase->mpn_mul, mpn_incr_u->MPN_INCR_U, abort->ASSERT_ALWAYS(0). * longlong.h (count_leading_zeros) [pentiumpro]: Work around a partial register stall on gcc < 3. * gmp.texi (Introduction to GMP): Add IA-64. (Notes for Particular Systems): i386 means generic x86. * tests/t-modlinv.c: Use tests_start and tests_end. 2001-06-10 Kevin Ryde * gmp.texi (Number Theoretic Functions): mpz_jacobi only defined for b odd. Separate the jacobi/legendre/kronecker descriptions. (Low-level Functions): Document mpn_mul_1 "incr" overlaps. (Language Bindings): New chapter. * mpz/jacobi.c: Don't retaining old behaviour of mpz_jacobi on even b (it wasn't documented in 3.1.1). * mpz/jacobi.c, gmp-h.in (mpz_kronecker, mpz_legendre): Remove separate entrypoints, just #define to mpz_jacobi. * compat.c (__gmpz_legendre): Add compatibility entrypoint. * mpn/generic/mul_1.c: Allow "incr" style overlaps. * tests/devel/try.c (param_init): Test this. * mpf/mul_ui.c: Do size==0 test earlier. 2001-06-08 Kevin Ryde * gmp-impl.h (ULONG_HIGHBIT, UINT_HIGHBIT, USHRT_HIGHBIT): Cast ULONG_MAX etc to unsigned long etc before attempting to right shift. * acinclude.m4 (GMP_ASM_LSYM_PREFIX): Add an AC_DEFINE of LSYM_PREFIX. * gmp-impl.h (ASM_L): New macro. (mpn_incr_u, mpn_decr_u, MPN_INCR_U, MPN_DECR_U): Add i386 optimized versions. * mpn/hppa/*.s,S,asm: Use .label so the code works with gas on hppa GNU/Linux too, reported by LaMont Jones . * mpn/hppa/README: Add some notes on this. * acinclude.m4 (GMP_ASM_LABEL_SUFFIX): Ditto. * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Add dive_1.c, fib2_ui.c. * tests/mpn/t-iord_u.c: New file. * tests/mpn/Makefile.am (check_PROGRAMS): Add it. * configure.in (mips*-*-irix[6789]*): Make ABI=n32 the default, same as in gmp 3.1. * gmp.texi (ABI and ISA): Update. * gmp.texi (Build Options): Misc tweaks. (Notes for Particular Systems): Describe windows DLL handling. (Known Build Problems): DJGPP needs bash 2.04. (Number Theoretic Functions): mpz_invert returns 0<=r * configure.in, gmp-h.in, mp-h.in: Add support for windows DLLs. 2001-05-26 Kevin Ryde * gmp.texi (ABI and ISA, Reentrancy): Minor tweaks (Notes for Package Builds): Note gmp.h is a generated file. (Notes for Particular Systems): -march=pentiumpro is used for gcc 2.95.4 and up. (Assembler Loop Unrolling): Mention non power-of-2 unrolling. (Internals): New chapter. * mpf/README: Remove file. * demos/expr/README: Miscellaneous rewordings. * demos/perl: New directory. * demos/Makefile.am: Add it. * demos/perl/INSTALL, Makefile.PL, GMP.pm, GMP.xs, typemap, GMP/Mpz.pm, GMP/Mpq.pm, GMP/mpf.pm, GMP/Rand.pm, sample.pl, test.pl: New files. * configure, aclocal.m4: Update to autoconf 2.50. * configure, aclocal.m4, ltmain.sh: Update to libtool 1.4. * configure, aclocal.m4, missing, ansi2knr.c, */Makefile.in: Update to automake 1.4f. * Makefile.am: Conditionalize mpfr in $(SUBDIRS) to handle mpfr.info. * mpfr/Makefile.am (INFO_DEPS): Remove previous mpfr.info handling. * mpn/Makefile.am (GENERIC_SOURCES): Remove this, just put mp_bases.c in libmpn_la_SOURCES. * tests/Makefile.am (tests.h): Move from EXTRA_HEADERS to libtests_la_SOURCES. * ltconfig: Remove file, no longer needed. * Makefile.am (gmp-impl.h, longlong.h, stack-alloc.h): Move from EXTRA_DIST to libgmp_la_SOURCES, so they get included in TAGS. * tests/rand/Makefile.am (gmpstat.h): Move to libstat_la_SOURCES similarly. * config.guess (68k-*-*): Use $SHELL not "sh", tweak some comments. * mpfr/mpfr.texi (Introduction to MPFR): Tweak table formatting, note non-free programs must be able to be re-linked. 2001-05-20 Kevin Ryde * mpn/powerpc64/addmul_1.asm, mpn/powerpc64/mul_1.asm, mpn/powerpc64/submul_1.asm: Add carry-in entrypoints. 2001-05-17 Kevin Ryde * gmp.texi (ge): Fix definition for info. (Notes for Particular Systems): Mention 68k dragonball and cpu32. (Efficiency): Add static linking, more about in-place operations, describe mpq+/-integer using addmul. (Reporting Bugs): A couple of words about self-contained reports. (Floating-point Functions): Note exponent limitations of mpf_get_str and mpf_set_str. (Initializing Floats): Clarify mpf_get_prec, mpf_set_prec and mpf_set_prec_raw a bit. (Float Comparison): Note current mpf_eq deficiencies. * gmp-h.in (__GMP_HAVE_CONST, __GMP_HAVE_PROTOTYPES, __GMP_HAVE_TOKEN_PASTE): Merge GNU ansidecl.h tests for ANSI compilers. * demos/expr/expr-impl-h.in: Ditto. * gmp-impl.h (BITS_PER_MP_LIMB): Define from __GMP_BITS_PER_MP_LIMB if not already in gmp-mparam.h. * tests/t-constants.c (BITS_PER_MP_LIMB, __GMP_BITS_PER_MP_LIMB): Check these are the same. * gmp-h.in (mpf_get_default_prec, mpf_get_prec, mpf_set_default_prec, mpf_set_prec_raw): Provide "extern inline" versions, use __GMPF on the macros. * mpf/get_dfl_prc.c, mpf/get_prc.c, mpf/set_dfl_prc.c, mpf/set_prc_raw.c: Get code from gmp.h using __GMP_FORCE. * gmp-h.in, gmp-impl.h (__gmp_default_fp_limb_precision): Move from gmp-impl.h to gmp-h.in. (__GMPF_BITS_TO_PREC, __GMPF_PREC_TO_BITS): Ditto, and use __GMPF prefix and add a couple of casts. * gmp-h.in (__GMP_MAX): New macro. * mpf/init2.c mpf/set_prc.c: Update for __GMPF prefix. * gmp-h.in (__GMP_BITS_PER_MP_LIMB): New templated define. * acinclude.m4 (GMP_C_SIZES): Add AC_SUBST __GMP_BITS_PER_MP_LIMB, remove AC_DEFINE BITS_PER_MP_LIMB. 2001-05-13 Kevin Ryde * gmp-h.in, gmp.texi, Makefile.am, mpz/Makefile.am, tests/mpz/t-pow.c: Remove mpz_si_pow_ui, pending full si support. * mpz/si_pow_ui.c: Remove file. 2001-05-11 Kevin Ryde * mpn/x86/pentium/dive_1.asm: New file. * mpn/powerpc32/umul.asm: Use r on registers. * mpn/powerpc64/umul.asm: New file. * configure.in (powerpc*-*-*): Enable umul in extra_functions. * tests/refmpn.c, tests/tests.h (refmpn_umul_ppmm): Use same arguments as normal mpn_umul_ppmm. (refmpn_mul_1c): Update. * tests/devel/try.c, tune/many.pl: Add some umul_ppmm testing support. * mpn/x86/k6/mmx/popham.asm, mpn/x86/k7/mmx/popham.asm: Don't support size==0. * mpn/x86/pentium/popcount.asm, mpn/x86/pentium/hamdist.asm: Ditto, and shave a couple of cycles from the PIC entry code. * mpz/mul.c: Use mpn_mul_1 for size==1 and mpn_mul_2 (if available) for size==2, to avoid copying; do vsize==0 test earlier. * mpf/sub.c: Test r!=u before calling mpf_set. * mpf/add.c: Ditto, and share mpf_set between usize==0 and vsize==0. * mpn/generic/tdiv_qr.c, mpq/get_d.c, mpf/div.c, mpf/set_q.c, mpf/set_str.c, mpf/ui_div.c: Test for high bit set, not for count_leading_zeros zero. * acinclude.m4 (GMP_PROG_AR, GMP_PROG_NM): Print a message if extra flags are added. * tests/mpz/t-mul_i.c: New file. * tests/mpz/Makefile.am: Add it. * mpz/mul_siui.c (mpz_mul_si): Fix for -0x80..00 on long long limb. * gmp-h.in (mpf_set_si, mpf_set_ui): Revert last change, set exp to 0 when n==0. * mpf/ceilfloor.c, mpf/trunc.c: Fix exp to 0 when setting r to 0. * gmp-impl.h (MPF_CHECK_FORMAT): Check exp==0 when size==0. 2001-05-07 Kevin Ryde * gmp-h.in (mpf_set_si, mpf_set_ui): Don't bother setting _mp_exp to 0 when n==0 (use 1 unconditionally). * tests/mpf/t-misc.c (check_mpf_set_si): Don't demand anything of _mp_exp when _mp_size is zero. * mpn/x86/README: Note gas _GLOBAL_OFFSET_TABLE_ with leal problem. * gmp-h.in (mpz_fits_uint_p, mpz_fits_ulong_p, mpz_fits_ushort_p): Provide these as "extern inline"s. (__GMP_UINT_MAX, __GMP_ULONG_MAX, __GMP_USHRT_MAX): New macros. (mpz_popcount): Use __GMP_ULONG_MAX. * gmp-impl.h (UINT_MAX, ULONG_MAX, USHRT_MAX): Use __GMP_U*_MAX, if not already defined. * mpz/fits_u.c: Use the code from gmp.h. 2001-05-06 Kevin Ryde * mpn/x86/k7/dive_1.asm: New file. * mpn/x86/k7/gcd_1.asm: New file. * mpn/asm-defs.m4 (m4_count_trailing_zeros): New macro. * gmp-h.in (mpz_get_ui, mpz_getlimbn, mpz_set_q, mpz_perfect_square_p, mpz_popcount, mpz_size, mpf_set_ui, mpf_set_si, mpf_size): Provide these as "extern inlines". Use just one big extern "C" block. * mpz/getlimbn.c, mpz/get_ui.c, mpz/perfsqr.c, mpz/popcount.c mpz/set_q.c, mpz/size.c, mpf/set_si.c, mpf/set_ui.c, mpf/size.c: Use __GMP_FORCE to get code from gmp.h. 2001-05-03 Kevin Ryde * extract-dbl.c: Add ASSERT d>=0. * gmp.texi (Efficiency): Add mpz_addmul etc for mpz+=integer, add mpz_neg etc in-place. (Integer Arithmetic): Add mpz_addmul, mpz_submul, mpz_submul_ui. (Initializing Rationals): Add mpq_set_str. (Low-level Functions): mpn_set_str requires strsize >= 1. * gmp-h.in (__GMP_EXTERN_INLINE, __GMP_ABS): New macros. (mpz_abs, mpq_abs, mpf_abs, mpz_neg, mpq_neg, mpf_neg): Provide inline versions. * mpz/abs.c, mpq/abs.c, mpf/abs.c, mpz/neg.c, mpq/neg.c, mpf/neg.c: Add suitable __GMP_FORCE to turn off inline versions. * tests/mpz/t-aorsmul.c,t-cmp_d.c,t-popcount,t-set_str.c: New files. * tests/mpz/Makefile.am: Add them. * mpz/aorsmul_i.c: New file, rewrite of addmul_ui.c. Add mpz_submul_ui entrypoint, share more code between some of the conditionals, use mpn_mul_1c if available. * mpz/addmul_ui.c: Remove file. * mpz/aorsmul.c: New file. * Makefile.am, mpz/Makefile.am: Update. * gmp-h.in (mpz_addmul, mpz_submul, mpz_submul_ui): Add prototypes. * gmp-impl.h (mpz_aorsmul_1): Add prototype. * tests/mpq/t-set_str.c: New file. * tests/mpq/Makefile.am: Add it. * mpq/set_str.c: New file. * Makefile.am, mpq/Makefile.am: Add it. * gmp-h.in (mpq_set_str): Add prototype. * mpz/set_str.c: Fix for trailing white space on zero, eg. "0 ". * mpn/generic/set_str.c: Add ASSERT str_len >= 1. * gmp-h.in, gmp-impl.h (mpn_incr_u, mpn_decr_u): Move to gmp-impl.h. * gmp-impl.h (MPN_INCR_U, MPN_DECR_U): New macros. 2001-04-30 Kevin Ryde * tests/mpz/t-lcm.c: New file. * tests/mpz/Makefile.am (check_PROGRAMS): Add it. * mpz/lcm.c: Add one limb special case. * mpz/lcm_ui.c: New file. * Makefile.am, mpz/Makefile.am: Add it. * gmp-h.in (mpz_lcm_ui): Add prototype. * gmp.texi (Number Theoretic Functions): Add mpz_lcm_ui, document lcm now always positive. * mp-h.in (mp_size_t, mp_exp_t): Fix typedefs to match gmp-h.in. * gmp-h.in (mpn_add_1, mpn_add, mpn_sub_1, mpn_sub): Remove K&R function defines (ansi2knr will handle mpn/inline.c, and just ansi is enough for gcc extern inline). * gmp-h.in (__GMP_HAVE_TOKEN_PASTE): New macro. (__MPN): Use it. * gmp-impl.h (CNST_LIMB): Ditto. * gmp-h.in, mp-h.in (__gmp_const, __gmp_signed, _PROTO, __MPN): Use ANSI forms on Microsoft C. (__GMP_HAVE_CONST): New define. * gmp-impl.h (const, signed): Use it. * demos/expr/expr-impl-h.in (): Use this with Microsoft C. (HAVE_STDARG): New define. * demos/expr/expr.c,exprz.c,exprq.c,exprf.c,exprfr.c: Use it. * acinclude.m4 (GMP_C_STDARG): New macro. * configure.in: Call it. * rand.c: Use it. * configure.in (AC_PROG_CC_STDC): New test. 2001-04-25 Kevin Ryde * mpn/x86/k6/mmx/dive_1.asm: New file. * mpn/x86/x86-defs.m4 (Zdisp): Two more insns. * mpn/x86/pentium/mul_2.asm: New file. * mpn/asm-defs.m4: Add define_mpn(mul_2). * acconfig.h (HAVE_NATIVE_mpn_divexact_1, mul_2): Add templates. * configure.in (ABI): Use AC_ARG_VAR. * tests/devel/try.c: Run reference function when validate fails. * mpq/get_str.c: Fixes for negative bases. * tests/mpq/t-get_str.c: Check negative bases. * tests/misc.c,tests.h (__gmp_allocate_strdup, strtoupper): New functions. 2001-04-24 Torbjorn Granlund * mpz/lcm.c (mpz_lcm): Make result always positive. * gmp-h.in (mpz_inp_binary, mpz_out_binary): Remove declarations. 2001-04-22 Kevin Ryde * mpn/powerpc64/addsub_n.asm: Use config.m4 not asm-syntax.m4. * mpz/cmp_d.c, mpz/cmpabs_d.c: New files. * Makefile.am, mpz/Makefile.am: Add them. * mpf/cmp_d.c, mpf/get_dfl_prec.c: New files. * Makefile.am, mpf/Makefile.am: Add them. * gmp-h.in (mpz_cmp_d, mpz_cmpabs_d, mpf_cmp_d, mpf_get_default_prec): Add prototypes. * gmp.texi: Add documentation. * mpf/set_prc.c: Avoid a realloc call if already the right precision. * gmp-impl.h (MPF_BITS_TO_PREC, MPF_PREC_TO_BITS): New macros. * mpf/get_prc.c, init2.c, set_dfl_prec.c, set_prc.c, set_prc_raw.c: Use them. 2001-04-20 Kevin Ryde * tests/devel/try.c: Don't test size==0 on mpn_popcount and mpn_hamdist; add testing for mpn_divexact_1; print some limb values with mpn_trace not printf. * mpz/popcount.c, mpz/hamdist.c: Don't pass size==0 to mpn_popcount and mpn_hamdist. * mpn/generic/popham.c: Don't support size==0. * config.guess (m68k-*-*): Detect m68010, return m68360 for cpu32, cleanup the nesting a bit. * gmp.texi (Integer Division): Fix mpz_congruent_2exp_p "c" type. (Integer Division): Add mpz_divexact_ui. (Number Theoretic Functions): Fix mpz_nextprime return type. (Exact Remainder): Divisibility tests now implemented. And more index entries in a few places. * tests/mpz/dive_ui.c: New file. * tests/mpz/Makefile.am (check_PROGRAMS): Add it. * mpz/dive_ui.c: New file. * Makefile.am, mpz/Makefile.am: Add it. * gmp-h.in (mpz_divexact_ui): Add prototype. * tune/many.pl, tune/speed.h: Add special mpn_back_to_back for development. * gmp-impl.h (MPN_DIVREM_OR_DIVEXACT_1): New macro. * mpz/divexact.c: Use it. * gmp-impl.h (DIVEXACT_1_THRESHOLD): New threshold. * tune/tuneup.c: Tune it. * tune/speed.c,speed.h,common.c,many.pl: Add measuring of mpn_divexact_1, mpn_copyi, mpn_copyd. * mpn/generic/dive_1.c: New file. * configure.in (gmp_mpn_functions): Add it. * gmp-impl.h (mpn_divexact_1): Add prototype. * mpn/asm-defs.m4: Add define_mpn(divexact_1). * tests/mpn: New directory. * tests/Makefile.am: Add it. * tests/mpn/Makefile.am: New file. * configure.in (AC_OUTPUT): Add it. * tests/mpn/t-asmtype.c: New file. * configure, config.in: Update to autoconf 2.49d. * configure.in, gmp-h.in, mp-h.in, demos/expr/expr-impl-h.in: Revert to generating gmp.h, mp.h and expr-impl.h with AC_OUTPUT and AC_SUBST. * configure.in (m68*-*-*): Oops, m683?2 is 68000, m68360 is cpu32. * mpn/m68k/m68k-defs.m4 (scale_available_p): Ditto. * configure.in (underscore, asm_align): Remove these variables, unused. (GMP_ASM_*): Sort by AC_REQUIREs, to avoid duplication. * acinclude.m4 (GMP_ASM_UNDERSCORE, GMP_ASM_ALIGN_LOG): Remove support for actions, no longer needed. 2001-04-17 Kevin Ryde * config.guess (m68k-*-*): Look for cpu in linux kernel /proc/cpuinfo. * acinclude.m4 (GMP_GCC_MARCH_PENTIUMPRO): The -mpentiumpro problem is fixed in 2.95.4, so test for that. (GMP_ASM_TYPE): Amend some comments. * tune/freq.c (speed_cpu_frequency_sysctl): Avoid having unused variables on GNU/Linux. * mpn/asm-defs.m4 (m4_instruction_wrapper): Fix a quoting problem if the name of the file is a macro. 2001-04-15 Kevin Ryde * mpn/powerpc64/*.asm: Add speeds on ppc630. * acconfig.h: Add dummy templates for _LONG_LONG_LIMB and HAVE_MPFR. * configure.in: Ensure config.in is the last AM_CONFIG_HEADER, which autoheader requires. * mpn/x86/pentium/popcount.asm: New file. * mpn/x86/pentium/hamdist.asm: New file. * mpn/asm-defs.m4: (m4_popcount): New macro. Amend a few comments elsewhere. * acinclude.m4 (GMP_ASM_RODATA): If possible, grep compiler output for the right directive. * tune/speed.c: Print clock speed in MHz, not cycle time. * configure.in (AC_CHECK_HEADERS): Check for sys/processor.h. * tune/freq.c (speed_cpu_frequency_processor_info): Require to exist, to differentiate the different processor_info on Darwin. (speed_cpu_frequency_sysctlbyname): Remove hw.model test which is in speed_cpu_frequency_sysctl. (speed_cpu_frequency_sysctl): Add hw.cpufrequency for Darwin. * gmp-impl.h (MPN_LOGOPS_N_INLINE, mpn_and_n ... mpn_xnor_n): Use a single expression argument for the different operations, necessary for the Darwin "smart" preprocessor. * mpn/m68k/t-m68k-defs.pl: Allow white space in m4_definsn and m4_defbranch. * tune/many.pl: Change RM_TMP_S to RM_TMP to match mpn/Makeasm.am, avoid a possibly undefined array in a diagnostic, add more renaming to hamdist. 2001-04-13 Kevin Ryde * ltmain.sh, aclocal.m4, configure, config.in: Update to libtool 1.3d. * configure.in: Change ac_ to lt_ in lt_cv_archive_cmds_need_lc and lt_cv_proc_cc_pic. * config.guess (m68*-*-*): Detect exact cpu with BSD sysctl hw.model, detect 68000/68010 with trapf, detect 68302 with bfffo. 2001-04-11 Kevin Ryde * acinclude.m4 (GMP_ASM_M68K_INSTRUCTION, GMP_ASM_M68K_ADDRESSING, GMP_ASM_M68K_BRANCHES): New macros. * configure.in: Use them, remove old 68k configs, use mc68020 udiv and umul. * mpn/m68k/m68k-defs.m4: New file. * mpn/m68k/t-m68k-defs.pl: New file. * mpn/m68k/*.asm: New files, converted from .S. Merge add_n and sub_n to aors_n, ditto mc68020 addmul_1 and submul_1 to aorsmul_1. No object code changes (except .type and .size now used on NetBSD 1.4). * mpn/m68k/README: New file. * mpn/m68k/*.S, */*.S, syntax.h: Remove files. * configure.in (m68*-*-netbsd1.4*): Pretend getrusage doesn't exist. * tune/README: Update. * configure.in (powerpc*-*-*): For the benefit of Darwin 1.3, add cc to cclist, make gcc_cflags -Wa,-mppc optional. 2001-04-06 Kevin Ryde * mpn/lisp/gmpasm-mode.el (gmpasm-comment-start-regexp): Add | for 68k. (gmpasm-mode-syntax-table): Add to comments. * tests/mpz/reuse.c (dsi_div_func_names): Add names for cdiv_[qr]_2exp. 2001-04-04 Kevin Ryde * acinclude.m4 (GMP_M4_M4WRAP_SPURIOUS): Fix test so as to actually detect the problem, add notes on m68k netbsd 1.4.1. * gmp.texi (Compatibility with older versions): Note libmp compatibility. 2001-04-03 Kevin Ryde * tests/mpz/reuse.c: Add mpz_cdiv_q_2exp and mpz_cdiv_r_2exp. * tests/mpz/t-pow.c: Drag in refmpn.o when testing mpz_pow_ui etc with refmpn_mul_2. * tune/speed.c,speed.h,common.c,many.pl: Add measuring of mpn_com_n and mpn_mul_2. * tests/devel/try.c: Add testing of mpn_mul_2, and a DATA_MULTIPLE_DIVISOR attribute. * gmp.texi (Build Options): List more m68k's. (Build Options): Add cross reference to tex2html. (Notes for Particular Systems): Add m68k means 68020 or up. (Rational Conversions): New section, with mpq_get_d, mpq_set_d and mpq_set_f from Miscellaneous, and new mpq_set_str. (Applying Integer Functions): Move mpq_get_num, mpq_get_den, mpq_set_num and mpq_set_den from Misc. (Miscellaneous Rational Functions): Remove section. (Custom Allocation): Partial rewrite for various clarifications. (References): Improve line breaks near URLs. * acinclude.m4 (GMP_GCC_M68K_OPTIMIZE): New macro. * configure.in (m68*-*-*): Use it to run gcc 2.95.x at -O not -O2. (m680?0-*-*, m683?2-*-*, m68360-*-*): Add optional gcc -m options. * tests/mpz/t-cmp.c: New file. * tests/mpz/t-sizeinbase.c: New file. * tests/mpz/Makefile.am: Add them. * gmp-impl.h (MPN_CMP): New macro. * mpz/cmp.c,cmpabs.c: Use it, and minor cleanups too. * tests/mpq/t-equal.c: New file. * tests/mpq/t-get_str.c: New file. * tests/mpq/Makefile.am: Add them. * mpq/get_str.c: New file. * Makefile.am, mpq/Makefile.am: Add it. * gmp-h.in (mpq_get_str): Add prototype. * mpq/equal.c: Rewrite using inline compare loops. * tests/refmpn.c,tests.h (refmpn_mul_2): Fix parameter order. * mpz/n_pow_ui.c: Fix mpn_mul_2 calls parameter order. 2001-03-29 Kevin Ryde * tests/mpf/t-trunc.c: New file. * tests/mpf/Makefile.am (check_PROGRAMS): Add it. * gmp-impl.h (MPF_CHECK_FORMAT): New macro. * mpf/trunc.c: New file, rewrite of integer.c, preserve prec+1 in copy, don't copy if unnecessary. * mpf/ceilfloor.c: New file likewise, and use common subroutine for ceil and floor. * mpf/integer.c: Remove file. * Makefile.am, mpf/Makefile.am, macos/Makefile.in: Update. * acinclude.m4 (GMP_GCC_VERSION_GE): New macro. (GMP_GCC_MARCH_PENTIUMPRO): Use it, remove CCBASE parameter (don't bother checking it's gcc). (GMP_GCC_ARM_UMODSI): New macro. * configure.in (GMP_GCC_MARCH_PENTIUMPRO): Update parameters. (arm*-*-*): Use GMP_GCC_ARM_UMODSI. * gmp.texi (Notes for Particular Systems): Add arm gcc requirements. 2001-03-28 Kevin Ryde * gmp.texi (Converting Integers): Document mpz_getlimbn using absolute value and giving zero for N out of range, move to end of section. * tests/refmpn.c (refmpn_tdiv_qr): Use refmpn_divmod_1 rather than refmpn_divrem_1. * tests/tests.h: Add some prototypes that were missing. * mpz/tdiv_q_ui.c: Remove a comment that belonged to mpz_tdiv_r_ui. 2001-03-26 Torbjorn Granlund * mpn/generic/gcdext.c: Handle carry overflow after m*n multiply code in both arms. Partially combine multiply arms. 2001-03-24 Kevin Ryde * longlong.h: Add comments to P5 count_leading_zeros. * demos/expr/exprz.c,t-expr.c,README: Add congruent_p and divisible_p. 2001-03-23 Kevin Ryde * gmp.texi (GMPceil, GMPfloor, ge, le): New macros. (Integer Division, mpn_cmp, mpn_sqrtrem, Algorithms): Use them. (mpn_bdivmod): Refer to mp_bits_per_limb, not BITS_PER_MP_LIMB, and improve formatting a bit. (mpn_lshift, mpn_rshift): Clarify the return values, and use {rp,n} for the destination. Miscellaneous minor rewordings in a few places. * mpn/arm/arm-defs.m4: New file. * configure.in (arm*-*-*): Use it. * mpn/arm/*.asm: Use changecom and registers from arm-defs.m4, use L() for local labels. * mpn/x86/k6/mmx/com_n.asm: Relax code alignment (same speed). * gmp-h.in (__GMP_ATTRIBUTE_PURE): Use __pure__ to avoid application namespace. * gmp-impl.h (ABS): Add parens around argument. 2001-03-20 Kevin Ryde * acinclude.m4 (GMP_PROG_M4): Use AC_ARG_VAR on $M4. * acinclude.m4 (GMP_M4_M4WRAP_SPURIOUS): New macro. * configure.in: Use it. * mpn/asm-defs.m4: Ditto. 2001-03-18 Kevin Ryde * mpn/x86/pentium/logops_n.asm: New file. * mpn/x86/k6/k62mmx/copyd.asm: Rewrite, smaller and simpler, faster on small sizes, slower on big sizes (about half the time). * mpn/x86/k6/k62mmx/copyi.asm: Remove file, in favour of generic x86. * mpn/x86/copyi.asm: Add some comments. * mpn/x86/k6/README: Update. * mpn/x86/k6/gcd_1.asm: New file. * gmp-impl.h (NEG_MOD): Fix type of __dnorm. * acinclude.m4 (GMP_C_SIZES): Fix use of __GMP_WITHIN_CONFIGURE. 2001-03-15 Kevin Ryde * gmp.texi (GMPabs): New macro. (Float Comparison - mpf_reldiff): Use it. (Integer Comparisons - mpz_cmpabs): Ditto, puts "abs" in info. (Reentrancy): Update notes on old random functions. (Karatsuba Multiplication): Better characterize the effect of basecase speedups on the thresholds, pointed out by Torbjorn. * tune/README: Notes on the 1x1 div threshold for mpn_gcd_1. * tests/misc.c (mpz_pow2abs_p, mpz_flipbit, mpz_errandomb, mpz_errandomb_nonzero, mpz_negrandom): New functions. (mpz_erandomb, mpz_erandomb_nonzero): Use urandom(). * tests/spinner.c (spinner_wanted, spinner_tick): Make global. * tests/tests.h: Update prototypes. * tests/mpz/t-cong.c, tests/mpz/t-cong_2exp.c: New files. * tests/mpz/Makefile.am (check_PROGRAMS): Add them. * mpz/cong.c, mpz/cong_2exp.c, mpz/cong_ui.c: New files. * Makefile.am, mpz/Makefile.am: Add them. * gmp-impl.h (NEG_MOD): New macro. * gmp-h.in (mpz_congruent_p, mpz_congruent_2exp_p, mpz_congruent_ui_p): Add prototypes. * gmp.texi (Integer Division, Efficiency): Add documentation. * mpq/aors.c: No need for ABS on denominator sizes. * gmp-impl.h (mpn_divisible_p): Use __MPN. * gmp-impl.h (LOW_ZEROS_MASK): New macro. * mpz/divis_ui.c, mpn/generic/divis.c: Use it. * mpz/setbit.c: Fix normalization for case of a negative ending up with a zero high limb. * tests/mpz/bit.c (check_single): New test for this problem. * configure.in (none-*-*): Fix cclist for default ABI=long. 2001-03-10 Kevin Ryde * mpz/cfdiv_q_2exp.c: Don't scan for non-zero limbs if they don't matter to the rounding. * mpz/get_ui.c: Fetch _mp_d[0] unconditionally, so the code can come out branch-free. 2001-03-08 Kevin Ryde * tests/devel/try.c (param_init): Fix reference functions for and_n and nand_n. * tune/speed.c, tests/devel/try.c: Seed RANDS, not srandom etc. * configure.in (AC_CHECK_FUNCS): Remove srand48 and srandom. * macos/configure (coptions): Remove random/srandom, now unnecessary. * configure.in (gmp.h, mp.h, demos/expr/expr-impl.h): Generate using AM_CONFIG_HEADER. (_LONG_LONG_LIMB, HAVE_MPFR): Change to AC_DEFINEs. * gmp-h.in, mp-h.in, demos/expr/expr-impl-h.in: Change to #undef's. * acinclude.m4 (GMP_FUNC_ALLOCA, GMP_C_SIZES): Use gmp-h.in, not gmp.h. * Makefile.am (EXTRA_DIST): Remove gmp-h.in and mp-h.in, now done automatically. * acinclude.m4 (GMP_FUNC_ALLOCA), gmp-impl.h: Set and use __GMP_WITHIN_CONFIGURE rather than GMP_FUNC_ALLOCA_TEST. * mpf/random2.c: Use _gmp_rand and RANDS instead of random() for the exponent, ensures full range of values too. * tests/mpz/t-div_2exp.c (check_various): Start with d based on i, but don't let it go negative. * tune/tuneup.c (KARATSUBA_MUL_THRESHOLD): Limit probing to TOOM3_MUL_THRESHOLD_LIMIT, the size of the workspace in mul_n.c. Use a -1 with this too, so size * mpn/cray/cfp/mul_1.c: Don't call mpn_add_n with size 0. * mpn/cray/cfp/addmul_1.c: Likewise. * mpn/cray/cfp/submul_1.c: Don't call mpn_sub_n with size 0. * tests/mpz/t-div_2exp.c (check_various): Start 2nd d loop from 0 (avoid problems with Cray compilers). 2001-03-06 Torbjorn Granlund * mpn/cray/ieee/submul_1.c: Don't call mpn_sub_n with size 0. * mpn/cray/ieee/mul_basecase.c: New file. * mpn/cray/ieee/sqr_basecase.c: New file, derived from mul_basecase.c. 2001-03-06 Kevin Ryde * tests/devel/try.c (pointer_setup): Allow dst_size == SIZE_SIZE2 for the benefit of mpn_tdiv_qr. * tune/tuneup.c (all): Start karatsuba probing at size==4, for the benefit of cray t90 ieee which has speed oddities at size==2. * gmp-impl.h (USE_LEADING_REGPARM): Use __GMP_GNUC_PREREQ. Use __GMP_ATTRIBUTE_PURE and ATTRIBUTE_CONST in a few places. * gmp-h.in (__GMP_GNUC_PREREQ) New macro. (__GMP_ATTRIBUTE_PURE): New macro, use it in many places. * gmp-impl.h, gmp-h.in (mpn_jacobi_base): Move prototype to gmp-impl.h, use ATTRIBUTE_CONST. * tune/speed.h (speed_cyclecounter): Inline asm version for i386. * mpz/cfdiv_r_2exp.c (cfdiv_r_2exp): Only reread "up" after second realloc, first is under w!=u. 2001-03-05 Torbjorn Granlund * mpn/cray/sub_n.c: Rewrite using `majority' logic. * mpz/cfdiv_r_2exp.c (cfdiv_r_2exp): Reread `up' after realloc of w. * mpn/cray/ieee/mul_1.c: Rewrite. Streamline multiplications; use `majority' logic. * mpn/cray/ieee/addmul_1.c: Likewise. * mpn/cray/add_n.c: Rewrite using `majority' logic. 2001-03-04 Torbjorn Granlund * longlong.h (CRAY udiv_qrnnd): No longer conditional on CRAYMPP. (64-bit hppa add_ssaaaa): New. (64-bit hppa sub_ddmmss): New. * mpn/cray/ieee/invert_limb.c: New file. * gmp-impl.h (RANDS): Add a `,0' to make it compile on more compilers. 2001-03-03 Kevin Ryde * mpz/n_pow_ui.c (ULONG_PARITY): Move to gmp-impl.h. * gmp-impl.h (ULONG_PARITY): i386 part from n_pow_ui.c, new generic form by Torbjorn. * tests/mpz/t-div_2exp.c: New file, rewrite of t-2exp.c. * tests/mpz/t-2exp.c: Remove file. * tests/mpz/Makefile.am (check_PROGRAMS): Update. * gmp-h.in (mpz_cdiv_q_2exp, mpz_cdiv_q_2exp): Add prototypes. * gmp.texi (Integer Division): Add mpz_cdiv_q_2exp and mpz_cdiv_q_2exp. * mpz/cfdiv_q_2exp.c: New file, partial rewrite of fdiv_q_2exp.c, add mpz_cdiv_q_2exp entrypoint. * mpz/cfdiv_r_2exp.c: New file, rewrite of fdiv_r_2exp.c, use all mpn, add mpz_cdiv_r_2exp entrypoint. * mpz/fdiv_q_2exp.c, mpz/fdiv_r_2exp.c: Remove files. * mpz/Makefile.am (libmpz_la_SOURCES): Update. * Makefile.am (MPZ_OBJECTS): Ditto. * gmp-impl.h (USE_LEADING_REGPARM): Use __i386__ same as longlong.h (REGPARM_2_1, REGPARM_3_1, REGPARM_ATTR): New macros. * mpz/jacobi.c (jac_or_kron): Use them. * configure.in (HAVE_ABI_$ABI): Re-enable this for config.m4, with dots changed to underscores (necessary for hppa). * tests/mpz/t-divis.c, tests/mpz/t-divis_2exp.c: New files. * tests/mpz/Makefile.am (check_PROGRAMS): Add them. * gmp-h.in (mpz_divisible_p, mpz_divisible_ui_p, mpz_divisible_2exp_p): Add prototypes. * gmp.texi (Integer Division): Add mpz_divisible_p. (Efficiency): Add remarks about divisibility testing. * mpz/divis.c, mpz/divis_ui.c, mpz/divis_2exp.c: New files. * mpz/Makefile.am (libmpz_la_SOURCES): Add them. * Makefile.am (MPZ_OBJECTS): Ditto. * mpn/generic/divis.c: New file. * configure.in (gmp_mpn_functions): Add it. * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Ditto. * gmp-impl.h (mpn_divisible_p): Add prototype. * urandom.h: Remove file. * Makefile.am (EXTRA_DIST): Remove it. * tests/mpz/convert.c, dive.c, io.c, logic.c, reuse.c, t-2exp.c, t-fdiv.c, t-fdiv_ui.c, t-gcd.c, t-jac.c, t-mul.c, t-pow.c, t-powm.c, t-powm_ui.c, t-root.c, t-sqrtrem.c, t-tdiv.c, t-tdiv_ui.c: Use RANDS, initialized by tests_rand_start. * tests/mpz/t-pow.c: New file, being t-pow_ui renamed and with some further tests added. * tests/mpz/t-pow_ui.c: Remove file. * tests/mpz/Makefile.am (check_PROGRAMS): Update. * tests/t-modlinv.c: Don't use urandom.h. * tests/mpz/bit.c, tests/mpz/t-scan.c: Ditto. * tests/mpq/t-cmp.c, tests/mpq/t-cmp_ui.c, tests/mpq/t-get_d.c: Ditto. * tests/mpf/reuse.c, t-add.c, t-conv.c, t-dm2exp.c, t-muldiv.c, t-sqrt.c, t-sub.c: Ditto. * tests/misc.c (tests_rand_start, tests_rand_end): New functions. (tests_start, tests_end): Use them. (urandom): New function. * tests/tests.h: Add prototypes. * mpz/random.c: Rewrite using mpz_urandomb and RANDS. * mpn/generic/random.c: Rewrite using _gmp_rand and RANDS. * mpn/generic/random2.c: Use RANDS not random() etc. * gmp-impl.h (__gmp_rands, __gmp_rands_initialized): Add externs. (gmp_randstate_ptr): New typedef. (RANDS, RANDS_CLEAR): New macros. * rands.c: New file. * Makefile.am (libgmp_la_SOURCES): Add it. * configure.in (mpn_objs_in_libmp): New AC_SUBST. * Makefile.am (libmp_la_DEPENDENCIES): Use it. 2001-03-02 Torbjorn Granlund * mpn/pa64/udiv_qrnnd.asm: New file. 2001-03-01 Kevin Ryde * mpbsd/rpow.c: New file. * mpbsd/Makefile.am (libmpbsd_la_SOURCES): Add it (nodist_libmpbsd_la_SOURCES): Remove pow_ui.c. * Makefile.am (MPBSD_OBJECTS): Add rpow.lo, remove pow_ui.lo. (libmp_la_DEPENDENCIES): Add mpz/n_pow_ui.lo. * mpz/ui_pow_ui.c: Rewrite using mpz_n_pow_ui. * mpz/pow_ui.c: Ditto, and no longer provide rpow for mpbsd. * mpz/n_pow_ui.c: New file, rewrite of pow_ui.c and ui_pow_ui.c. Use less temporary memory, strip factors of 2 from the base, use mpn_mul_2 if available. * mpz/si_pow_ui.c: New file. * mpz/Makefile.am (libmpz_la_SOURCES): Add them. * Makefile.am (MPZ_OBJECTS): Ditto. * gmp-impl.h (mpz_n_pow_ui): Add prototype. * gmp-h.in (mpz_si_pow_ui): Add prototype. * gmp.texi (Integer Exponentiation): Add mpz_si_pow_ui. * acinclude.m4 (GMP_C_SIZES): Add BITS_PER_ULONG. Correction to mp_limb_t working check. * configure.in (limb_chosen): New variable. * tests/t-constants.c (BITS_PER_ULONG): Check this value. Add some reminders about tests that fail on Cray. * tests/refmpn.c (refmpn_mul_2): New function. * tests/refmpz.c (refmpz_pow_ui): Copied from tests/mpz/t-pow_ui.c * tests/tests.h: Add prototypes. * configure.in (none-*-*): Add ABI=longlong. * doc/configuration (Long long limb testing): Describe it. * gmp.texi (Low-level Functions): Move some commented out remarks ... * mpn/generic/mul_basecase.c: ... to here. * mpn/x86/README: Note "%=" as an alternative to "1:" in __asm__. * tests/trace.c (mp_trace_start): Print "bin" for binary. * mpn/generic/dump.c: Add a couple of casts to keep gcc quiet. * gmp-h.in (mpn_incr_u, mpn_decr_u): Add parens around arguments. * mpbsd/mout.c, mpbsd/mtox.c (num_to_text): Remove unused variable. * mpfr/set_d.c (mpfr_get_d2): Declare "q" for 64-bit limbs. 2001-02-28 Torbjorn Granlund * mpn/pa64w/udiv_qrnnd.asm: Tune. 2001-02-27 Torbjorn Granlund * mpn/pa64w/udiv_qrnnd.asm: New file. 2001-02-26 Torbjorn Granlund * longlong.h (arm): Optimize sub_ddmmss by testing for constant operands. * mpn/arm/invert_limb.asm: New file. 2001-02-24 Torbjorn Granlund * mpn/generic/lshift.c: Rewrite. * mpn/generic/rshift.c: Rewrite. * longlong.h: Use UWtype for external interfaces that expect mp_limb_t. * longlong.h (arm): #define invert_limb. * mpn/arm: Make labels have local scope. * configure.in (arm*-*-*): Set extra_functions. * longlong.h (arm): #define udiv_qrnnd. * mpn/arm/udiv.asm: New file. 2001-02-24 Kevin Ryde * tune/many.pl: Add mpn_count_leading_zeros, mpn_count_trailing_zeros and mpn_invert_limb. Add count_leading_zeros, count_trailing_zeros from a .h file. Correction to modexact_1_odd prototype. Support ansi2knr. * tune/speed.h, tune/common.c: Consequent changes. * demos/expr/*: Make a few more functions available in expressions, create only libexpr.a, misc minor updates. * mpn/Makeasm.am: Add some comments about suffix ordering. * tests/refmpn.c (rshift_make, lshift_make): No need to compare unsigned to zero. * mpq/mul.c: Detect and optimize squaring. 2001-02-23 Torbjorn Granlund * mpn/mips3: Convert files to `.asm'. * mpn/arm: Convert files to `.asm'. Misc cleanups. * mpn/arm/submul_1.asm: New file. 2001-02-21 Kevin Ryde * tune/tuneup.c (all): Only one compiler print should match, no need for #undef PRINTED_COMPILER. * mpfr/mpfr.h (mpfr_sgn): Use mpfr_cmp_ui (patch from Paul). * mpz/fib_ui.c: Update some remarks about alternative algorithms. * gmp.texi (Fibonacci Numbers Algorithm): Ditto. (Assigning Floats): Clarify mpf_swap swaps the precisions too. (Low-level Functions): Try to be clearer about negative cofactors. 2001-02-21 Torbjorn Granlund * mpn/sparc64/copyi.asm: Streamline for small operands. * mpn/sparc64/add_n.asm: Likewise. * mpn/sparc64/sub_n.asm: Likewise. * mpn/sparc64/copyd.asm: New file. 2001-02-20 Torbjorn Granlund * mpn/sparc64/lshift.asm: Rewrite. * mpn/sparc64/rshift.asm: Rewrite. 2001-02-19 Torbjorn Granlund * mpn/sparc64/add_n.asm: Rewrite using `majority' logic. * mpn/sparc64/sub_n.asm: Likewise. * tune/tuneup.c (all): Recognise DECC and MIPSpro compilers. * mpn/pa64/sqr_diagonal.asm: Use PROLOGUE/EPILOGUE. * mpn/pa642/sqr_diagonal.asm: Likewise. * configure.in (HAVE_ABI_$abi): Disable for now. * mpn/asm-defs.m4 (PROLOGUE): Use LABEL_SUFFIX. * acinclude.m4 (GMP_ASM_ATTR): New check, for hppa oddities. 2001-02-18 Torbjorn Granlund * mpn/hppa/hppa1_1/gmp-mparam.h: New file. * mpn/hppa/hppa2_0/gmp-mparam.h: New file. * mpn/pa64/sqr_diagonal.asm: New file. * mpn/pa64w/sqr_diagonal.asm: New file. * mpn/hppa/hppa1_1/sqr_diagonal.asm: New file. * mpn/hppa/hppa2_0/sqr_diagonal.asm: New file. * mpn/sparc32/v9/add_n.asm: Use `fitod' instead of `fxtod' for dummy FA-pipeline insns. * mpn/sparc32/v9/sub_n.asm: Likewise. 2001-02-18 Kevin Ryde * gmp.texi (Known Build Problems): Notes on make, $* and K&R, misc tweaks elsewhere. (Low-level Functions): Use {} notation in mpn_sqrtrem. (Basecase Multiplication): Mention BASECASE_SQR_THRESHOLD. * mpfr/isnan.c (mpfr_number_p): Infinity is not a number. * mpfr/out_str.c: Pass strlen+1 for the block size to free. * mpfr/get_str.c: Correction for realloc to strlen+1. * acinclude.m4 (GMP_C_SIZES): Generate an error if mp_limb_t doesn't seem to work for some reason. 2001-02-16 Torbjorn Granlund * mpn/sparc32/v9/gmp-mparam.h: Retune. * mpn/sparc32/v9/add_n.asm: New file. * mpn/sparc32/v9/sub_n.asm: New file. * mpn/sparc32/v9/mul_1.asm: Tune function entry. * mpn/sparc32/v9/addmul_1.asm: Likewise. * mpn/sparc32/v9/submul_1.asm: Likewise. * mpn/sparc32/v9/sqr_diagonal.asm: New file. 2001-02-16 Kevin Ryde * configure.in: Fix flags selection when $CC is a compiler known to us. * demos/expr/exprfr.c (e_mpfr_cos, e_mpfr_sin): mpfr_sin_cos now allows NULL for one parameter. * mpfr/*: Update to 20010215. * mpfr/trunc.c: Use -DOPERATION scheme, and gmp mpn_zero_p. * mpfr/sqrt.c: Use plain mpn_sqrtrem, not mpn_sqrtrem_new. * mpfr/sqrtrem.c: Remove file. * mpfr/Makefile.am (libmpfr_a_SOURCES): Add isnan.c and set_ui.c, remove sqrtrem.c and srandom.h. * configfsf.guess: Update to 2001-02-13. * configfsf.sub: Update to 2001-02-16. * config.sub (j90, t90): Remove special handing, configfsf.sub now ok. * Makefile.am (MPF_OBJECTS): Add a couple of missing $U's. * tune/tuneup.c: Identify compiler used (GCC and Sun C so far). 2001-02-15 Torbjorn Granlund * mpn/sparc32/v9/mul_1.asm: Change `ld' to `lduw' and `st' to `stw'. * mpn/sparc32/v9/addmul_1.asm: Likewise. * mpn/sparc32/v9/submul_1.asm: Likewise. 2001-02-14 Torbjorn Granlund * mpn/mips3/mips.m4: New file. * configure.in (mips*-*-irix[6789]*): Use mips3/mips.m4. * mpn/powerpc64/sqr_diagonal.asm: New file. * mpn/mips3/sqr_diagonal.asm: New file. 2001-02-12 Torbjorn Granlund * mpn/powerpc32/sqr_diagonal.asm: New file. * mpn/generic/sqr_basecase.c: Remove declaration of mpn_sqr_diagonal. Fix typo in header comment. 2001-02-12 Kevin Ryde * mpn/generic/mul.c, mpn/generic/mul_n.c, gmp-impl.h: Use mpn_mul_basecase for squaring below new BASECASE_SQR_THRESHOLD. * tune/tuneup.c gmp-impl.h: Tune BASECASE_SQR_THRESHOLD. * Makefile.am (libgmp.la, libmp.la): Revert change to build from mpn/libmpn.la etc, go back to explicitly listed objects. * configure.in: Recognise sparc64-*-*, not just sparc64-*-linux*. 2001-02-11 Torbjorn Granlund * mpn/asm-defs.m4 (sqr_diagonal): New define_mpn. * mpn/alpha/sqr_diagonal.asm: New file. 2001-02-11 Kevin Ryde * gmp.texi (Low-level Functions): Note mpn_get_str clobbers its input plus 1 extra limb. * mpfr/add.c,agm.c,exp2.c,exp3.c,generic.c,log2.c,pi.c,print_raw.c, set_d.c,sin_cos.c,sqrtrem.c,sub.c: Apply some tweaks for K&R. * tests/mpz/reuse.c, tests/mpq/t-md_2exp.c, demos/pexpr.c, demos/expr/t-expr.c: Ditto. * configure.in (HAVE_ABI_$abi): New define in config.m4. * gmp-impl.h (mpn_sqr_diagonal): Add prototype and define. * tune/speed.c,speed.h,common.c,many.pl: Add measuring of mpn_sqr_diagonal. * gmp.texi, acinclude.m4: Mention x86 solaris 2.7 has the reg->reg movq bug the same as 2.6. * mpfr/Makefile.am (EXTRA_DIST): Add mpfr-test.h and mpf2mpfr.h. * mpn/x86/README: Merge contents of README.family. * mpn/x86/README.family: Remove file. * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Add mode1o, gcd_finda, invert_limb, sqr_diagonal; remove mod_1_rs; sort alphabetically. 2001-02-10 Torbjorn Granlund * configure.in (gmp_mpn_functions_optional): List sqr_diagonal. * mpn/powerpc32/aix.m4: Use unnamed csects. * mpn/powerpc64/aix.m4: Likewise. * acconfig.h: Add #undef of mpn_sqr_diagonal. Remove lots of spacing. * configure.in (syntax testing section): Match power* instead of powerpc*. * mpn/power: Convert files to `.asm'. Prefix umul_ppmm and sdiv_qrnnd. Update some comments. 2001-02-09 Kevin Ryde * acconfig.h: Add HAVE_NATIVE_mpn_modexact_1_odd and HAVE_NATIVE_mpn_modexact_1c_odd. * configure.in (CCAS): Don't override a user selection. * mpq/cmp_ui.c: DIVIDE_BY_ZERO if den2==0. 2001-02-08 Torbjorn Granlund * mpn/generic/sqr_basecase.c: Use mpn_sqr_diagonal when appropriate. 2001-02-07 Kevin Ryde * gmp.texi (Low-level Functions): mpn_preinv_mod_1 now undocumented. * mpn/generic/random2.c (myrandom): Use rand() on mingw. * mpn/alpha/gmp-mparam.h: Update tuned parameters. 2001-02-05 Torbjorn Granlund * mpn/alpha/ev6/gmp-mparam.h: Retune. 2001-02-05 Kevin Ryde * Makefile.am (libgmp, libmp): Construct from mpn/libmpn.la etc rather than explicitly listed objects. * urandom.h: Use rand() on mingw. * mpn/powerpc64/lshift.asm,addsub_n.asm: Use r1 not 1. 2001-02-04 Torbjorn Granlund * mpn/ia64/copyi.asm: New file. * mpn/ia64/copyd.asm: New file. 2001-02-04 Kevin Ryde * mpn/alpha/ev5/gmp-mparam.h, mpn/mips3/gmp-mparam.h, mpn/powerpc32/gmp-mparam.h, mpn/powerpc64/gmp-mparam.h, mpn/sparc64/gmp-mparam.h, mpn/x86/*/gmp-mparam.h: Update tuned parameters. * mpn/x86/i486: New directory. * configure.in (i486-*-*): Use it. * mpn/x86/i486/gmp-mparam.h: New file. * mpn/x86/pentium/mode1o.asm: New file. * mpn/x86/p6/mode1o.asm: New file. * tune/many.pl: Use $(ASMFLAGS_PIC) and $(CFLAGS_PIC). * gmp.texi (Integer Division): Another rewording of 2exp divisions. 2001-02-03 Torbjorn Granlund * mpn/arm/gmp-mparam.h: Tune. * mpn/ia64/popcount.asm: Put a `;;' break at end of main loop. * configure.in (arm*-*-*): Set gcc_cflags in order to pass $fomit_frame_pointer. * tests/mpz/t-mul.c (base_mul): Remove an unused variable. 2001-02-02 Torbjorn Granlund * demos/pexpr.c (TIME): New macro. (main): Use TIME--print timing more accurately. (setup_error_handler): Increase RLIMIT_DATA to 16 Mibyte. * longlong.h (arm): Add __CLOBBER_CC to add_ssaaaa and sub_ddmmss. 2001-02-02 Kevin Ryde * configure.in: Don't remove gmp-mparam.h and mpn source links under --no-create since in that case they're not re-created. * demos/expr: New directory. * Makefile.am (SUBDIRS, allprogs): Add it. * demos/expr/README, Makefile.am, expr.c, exprv.c, exprz.c, exprza.c, exprq.c, exprqa.c, exprfa.c, exprf.c, exprfr.c, exprfra.c, expr.h, expr-impl-h.in, run-expr.c, t-expr.c: New files. * configure.in: Generate demos/expr/Makefile & demos/expr/expr-impl.h. * Makefile.am: Remove mpfr from main libgmp. * mpfr/Makefile.am: Build and install separate libmpfr.a. * mpfr/*: Update to mpfr 2001. * gmp-h.in (__GNU_MP_VERSION_MINOR): Bump to 2. * Makefile.am (libtool -version-info): Bump appropriately. * NEWS: Updates. * tune/divrem1div.c, tune/divrem1inv.c, tune/divrem2div.c, tune/divrem2inv.c: Renamed from divrem_1_div.c, divrem_1_inv.c, divrem_2_div.c, divrem_2_inv.c, to be unique in DOS 8.3 filenames. * tune/Makefile.am (libspeed_la_SOURCES): Update. * mpn/x86/*/README, mpn/x86/README.family: Misc updates. * tune/README: Misc updates. * doc/configuration: Misc updates. * mpn/x86/pentium/mmx/gmp-mparam.h: Change UDIV_PREINV_TIME to UDIV_NORM_PREINV_TIME. * mpz/pprime_p.c: Use ASSERT_ALWAYS instead of abort. * rand.c (__gmp_rand_lc_scheme): Add "const". (struct __gmp_rand_lc_scheme_struct): Make astr "const char *". * demos/calc/calc.y, demos/calc/calclex.l: Add kron function. * tests/devel/try.c: Partial rewrite, new scheme of function types, allow result validation functions, add sqrtrem and jacobi testing. * tune/many.pl: Corresponding updates. * tests/devel/Makefile.am: Add a convenience rule for libtests.la. * tests/refmpz.c: New file. * tests/Makefile.am: Add it. * tests/misc.c (mpz_erandomb, mpz_erandomb_nonzero): New functions. * tests/tests.h: Add prototypes. * mpn/x86/k6/cross.pl: Add a couple more exceptions. * gmp.texi: Don't use @nicode{'\0'}, it doesn't come out right in tex. (Introduction to GMP): Mention Cray vector systems. (Build Options): Describe --enable-mpfr, refer to its manual. Add Crays under supported CPUs. (Debugging): Add notes on source file paths. (Autoconf): New section. (Assigning Integers): Note truncation by mpz_set_d, mpz_set_q and mpz_set_f. (Converting Integers): Note the size mpz_get_str allocates. (Floating-point Functions): Rewrite introduction, clarifying some points about precision handling. (Converting Floats): Note the size mpf_get_str allocates, and that it gives an empty string for zero. Add mpf_get_si and mpf_get_ui. (Float Comparison): Give the formula mpf_reldiff calculates. (Miscellaneous Float Functions): Add mpf_integer_p and mpf_fits_*_p. (Random Number Functions): Misc rewordings for clarity. (Random State Initialization): Ditto. (Custom Allocation): Remove note on deallocate_function called with 0, misc rewording and clarifications. (Exact Remainder): New section. (Binary GCD): A few words on initial reduction using division. (Accelerated GCD): Refer to exact remainder section. (Extended GCD): Extra remarks on single versus double selection. (Jacobi Symbol): Update for mpz/jacobi.c rewrite and modexact_1_odd. (Modular Powering Algorithm): Refer to exact remainder section. (Assembler SIMD Instructions): Update remarks on MMX. (Contributors): Amend to "Divide and Conquer" division. (References): Tweak some formatting. Add "Proof of GMP Fast Division and Square Root Implementations" by Paul Zimmermann. 2001-01-31 Torbjorn Granlund * configure.in: Don't ever pass -mips3; let ABI flags imply ISA. 2001-01-31 Kevin Ryde * tune/time.c: Remove unnecessary longlong.h. (speed_endtime): Add some extra diagnostics. * tests/mpz/t-fdiv_ui.c, tests/mpz/t-tdiv_ui.c: Use unsigned long for the divisor, not mp_limb_t. * tests/mpz/t-jac.c (try_base): Use %llu for long long limb. * tests/trace.c: Add for strlen. * tune/freq.c (speed_cpu_frequency_proc_cpuinfo): Ignore "cycle frequency" of 0, allow "BogoMIPS" as well as "bogomips". * macos/Makefile.in: Add mpf/fits_s.c and mpf/fits_u.c objects. 2001-01-30 Torbjorn Granlund * longlong.h: Add add_ssaaaa and sub_ddmmss for 64-bit sparc. 2001-01-29 Torbjorn Granlund * mpn/powerpc64/addmul_1.asm: Prefix registers with an `r'. * mpn/powerpc64/submul_1.asm: Likewise. * mpn/powerpc64/mul_1.asm: Likewise. * configure.in (alpha*-*-*): Amend last change to handle pca*. 2001-01-29 Kevin Ryde * tune/speed.h (SPEED_ROUTINE_INVERT_LIMB_CALL): Don't let the compiler optimize everything away. * tune/speed.c, tune/speed.h, tune/common.c, tune/Makefile.am: Measure operator_div, operator_mod, mpn_divrem_2_div, mpn_divrem_2_inv, mpn_sb_divrem_m3, mpn_sb_divrem_m3_div, mpn_sb_divrem_m3_inv, mpn_dc_divrem_sb_div, mpn_dc_divrem_sb_inv. * tune/divrem_2_div.c, tune/divrem_2_inv.c, tune/sb_div.c, tune/sb_inv.c: New files. * tune/tuneup.c, gmp-impl.h, tune/speed.h, tune/common.c, tune/Makefile.am: Tune SB_PREINV_THRESHOLD and DIVREM_2_THRESHOLD. * mpn/generic/divrem_2.c: Use new DIVREM_2_THRESHOLD. * mpn/generic/sb_divrem_mn.c: Use new SB_PREINV_THRESHOLD. * mpn/x86/p6/mmx/lshift.asm, mpn/x86/p6/mmx/rshift.asm: New files, just m4 include()ing the P55 code. * configure.in (pentium[23]-*-*): Remove x86/pentium/mmx from path. 2001-01-27 Kevin Ryde * configure.in (AC_CHECK_FUNCS): Add srand48. * tune/speed.c: Use this test. * acinclude.m4 (GMP_GCC_MARCH_PENTIUMPRO): Allow "egcs-" prefix on gcc --version, warn if the format is unrecognised. (GMP_COMPARE_GE): Guard against empty $1 not only on last arg. (GMP_INIT, GMP_FINISH, GMP_PROG_M4): Obscure or eliminate literal "dnl"s since autoconf thinks they indicate faulty macros. * mpz/get_str.c, mpf/get_str.c: Make allocated string block exactly strlen(str)+1 bytes. * mpz/dump.c, mpf/dump.c, tests/mpz/convert.c: Use this size when freeing. * tests/mpf/t-conv.c: Ditto, and ensure x==0 is exercised. * tests/mpz/t-fits.c: New file. * tests/mpz/Makefile.am: Add it. * tests/mpf/t-fits.c: New file. * tests/mpf/t-get_si.c: New file. * tests/mpf/t-int.c: New file. * tests/mpf/Makefile.am: Add them. * mpf/fits_s.c: New file. * mpf/fits_u.c: New file. * mpf/get_si.c: New file. * mpf/get_ui.c: New file. * mpf/int_p.c: New file. * Makefile.am, mpf/Makefile.am: Add them. * gmp-h.in (mpf_fits_*_p, mpf_get_si, mpf_get_ui, mpf_integer_p): Add prototypes. * tests/memory.c (tests_allocate, tests_reallocate): Guard against size==0. * tests/mpz/*.c, tests/mpq/*.c, tests/mpf/*.c: Uses tests_start and tests_end. * gmp-impl.h (USE_LEADING_REGPARM): Fix conditionals. 2001-01-23 Kevin Ryde * configure.in, mpn/Makeasm.am (ASMFLAGS_PIC): New substitution, allowing -DPIC to be suppressed on cygwin. (CFLAGS_PIC): New substitution, use it and $(CCAS) directly, rather than $(LIBTOOL), avoiding a problem with FreeBSD 2.2.8. * mpn/x86/k6/mode1o.asm, mpn/x86/k7/mode1o.asm: Remove an unnecessary +[.-L(here)] from _GLOBAL_OFFSET_TABLE_, avoids a segv from gas 1.92.3. * mpn/x86/README.family: Add notes on the problem. 2001-01-20 Torbjorn Granlund * configure.in (alpha*-*-*): Default `flavour' to ev4. 2001-01-19 Kevin Ryde * assert.c, gmp-impl.h (__gmp_assert_fail): Change return type to void, since it's no longer used in expressions. * mpn/x86/addsub_n.S: Remove file, since it doesn't work and it upsets tune/many.pl. * mpz/jacobi.c: Rewrite, but still binary algorithm; accept zero and negative denominators; merge mpz_jacobi and mpz_legendre, add mpz_kronecker; use mpn directly, add special cases for size==1. * gmp.texi (Number Theoretic Functions): Update. * gmp-h.in (mpz_kronecker): Add prototype. * gmp-impl.h (USE_LEADING_REGPARM): New macro. * tests/mpz/t-jac.c: Test mpz_kronecker. * mpz/legendre.c: Remove file. * Makefile.am, mpz/Makefile.am: Update. * longlong.h (alpha count_leading_zeros): Use __attribute__ ((const)) when possible, add parameter to prototype. (ia64 udiv_qrnnd): Use for all compilers, not just gcc. (pentium count_trailing_zeros): Use count_leading_zeros. * acinclude.m4 (GMP_C_ATTRIBUTE_CONST, GMP_C_ATTRIBUTE_NORETURN): New macros. * configure.in: Use them. * gmp-impl.h (ATTRIBUTE_CONST, ATTRIBUTE_NORETURN): New macros. (mpn_invert_limb): Add ATTRIBUTE_CONST. (__gmp_assert_fail): Add ATTRIBUTE_NORETURN. 2001-01-18 Kevin Ryde * gmp-h.in, gmp-impl.h (__gmp_allocate_func, __gmp_reallocate_func, __gmp_free_func): Move prototypes from gmp-impl.h to gmp-h.in, for the benefit of gmp++.h. * gmp-impl.h, tests/misc.c, tests/tests.h: Move MPZ_SET_STR_OR_ABORT and MPF_SET_STR_OR_ABORT to mpz_set_str_or_abort and mpf_set_str_or_abort in libtests. * tests/mpz/convert.c, tests/mpz/t-bin.c, tests/mpz/t-get_si.c, tests/mpz/t-jac.c, tests/mpz/t-misc.c, tests/mpq/t-md_2exp.c, tests/mpq/t-set_f.c, tests/mpf/t-conv.c, tests/mpf/t-misc.c: Update. * mpn/generic/sqrtrem.c: Use MPN_COPY_INCR (for when rp==NULL). * tests/mpz/reuse.c: Only run mpz_divexact_gcd on positive divisors. 2001-01-18 Torbjorn Granlund * demos/pexpr.c (main): Accept -vml option. (fns): List `hamdist', `pow', `nextprime'. (mpz_eval_expr): Return -1 for `popc' of negative. (mpz_eval_expr): Handle `hamdist', `pow', `nextprime'. 2001-01-15 Kevin Ryde * mpn/alpha/ev5/mode1o.c: New file. * tune/freq.c (speed_cpu_frequency_measure): Check cycles_works_p before running speed_cyclecounter. * tune/speed.h (cycles_works_p): Add prototype. 2001-01-13 Torbjorn Granlund * tests/rand/t-rand.c (farr): Fix typo. (zarr): Fix typo. 2001-01-12 Kevin Ryde * mpz/kronsz.c: Don't depend on right shifting a negative. * mpn/x86/gmp-mparam.h: New file. * mpn/x86/pentium/mmx/mul_1.asm: New file. 2001-01-11 Torbjorn Granlund * mpz/kronsz.c: Temporary workaround for Cray right shift oddities. Explicitly compare against zero in tests. 2001-01-10 Kevin Ryde * mpz/kronzs.c: Don't depend on right shifting a negative. 2001-01-09 Torbjorn Granlund * tests/t-constants.c: Disable some undefined tests. (CHECK_MAX_S): Remove workaround for gcc 2.95.2 bug recently added. 2001-01-09 Kevin Ryde * tests/t-constants.c: Add more diagnostics. (CHECK_MAX_S): Fix for gcc 2.95.2 -mpowerpc64 -maix64. * mpn/x86/k6/mode1o.asm: New file. * mpn/x86/k7/mode1o.asm: New file. * mpn/asm-defs.m4 (modexact_1_odd, modexact_1c_odd): New define_mpn's. (__clz_tab, modlimb_invert_table, PROLOGUE, EPILOGUE): Add asserts for GSYM_PREFIX. * mpn/x86/x86-defs.m4 (Zdisp): Add a movzbl. * tests/mpz/t-jac.c (check_a_zero): New test. (check_squares_zi): Fix to use (a^2/b), not (a*b/b); revert last change avoiding a,b=0, both are fine. (try_2den): Don't use mpz_kronecker_ui for the expected answer. (try_*): Call abort rather than exit. * mpz/kronzu.c, mpz/kronzs.c: Fix for a=0. * tune/tuneup.c (USE_PREINV_MOD_1): Fix to use new DATA_HIGH_LT_R. 2001-01-08 Torbjorn Granlund * urandom.h: Amend 2000-11-21 change to also handle cygwin. 2001-01-08 Kevin Ryde * tune/many.pl: Updates for move to tests/devel, add modexact_1_odd, don't assume C files can't have carry-in entrypoints, remove $(TRY_TESTS_OBJS) now in libtests. * tests/devel/try.c, tests/refmpn.c, tests/tests.h: Remove mpn_mod_1_rshift testing. * tune/tuneup.c (fft_step_size): Test for overflow using the actual mp_size_t, don't use BITS_PER_INT. * tune/speed.c (r_string): "r" is a limb, use BITS_PER_MP_LIMB and change LONG_ONES to LIMB_ONES. * tune/time.c (M_2POWU): Use INT_MAX rather than BITS_PER_INT. * extract-dbl.c (BITS_PER_PART): Use BITS_PER_MP_LIMB not BITS_PER_LONGINT. * mpz/inp_raw.c, mpz/out_raw.c: Add private defines of BITS_PER_CHAR. * mpz/fac_ui.c, tests/mpz/t-fac_ui.c: Don't use BITS_PER_LONGINT. * tests/mpz/t-get_si.c: Don't use BITS_PER_LONGINT, do the LONG_MAX tests with some explicit code. * mpn/*/gmp-mparam.h, acinclude.m4, tests/t-constants.c (BITS_PER_LONGINT, BITS_PER_INT, BITS_PER_SHORTINT, BITS_PER_CHAR): Remove defines, remove probings, remove tests. * tune/tuneup.c (MODEXACT_1_ODD_THRESHOLD): Add tuning. * tune/speed.c,speed.h,common.c: Add measuring of mpn_modexact_1_odd, mpn_gcd_finda, and an "N" form for mpn_gcd_1. * tests/mpz/t-jac.c (check_squares_zi): Ensure random a,b != 0. 2001-01-07 Kevin Ryde * configure.in (gmp_mpn_functions): Add mode1o, remove mod_1_rs. * mpn/generic/mod_1_rs.c: Remove file, no longer needed. * gmp-h.in (mpn_mod_1_rshift): Remove prototype and define. * mpq/set_f.c: Use MPN_STRIP_LOW_ZEROS_NOT_ZERO. * mpz/kronzu.c, mpz/kronzs.c, mpz/kronuz.c, mpz/kronsz.c: Use mpn_modexact_1_odd, new style MPN_STRIP_LOW_ZEROS_NOT_ZERO, and new JACOBI macros. Various rearrangements supporting all this. * mpn/generic/gcd_1.c: Use mpn_modexact_1_odd, reduce u%v if u much bigger than v when size==1, some rearrangements supporting this. * gmp-impl.h (JACOBI_*): More macros, add some casts to "int". (MPN_STRIP_LOW_ZEROS_NOT_ZERO): Add a "low" parameter. (mpn_modexact_1_odd, mpn_modexact_1c_odd): Add prototype and defines. (MODEXACT_1_ODD_THRESHOLD): New threshold. (MPN_MOD_OR_MODEXACT_1_ODD, JACOBI_MOD_OR_MODEXACT_1_ODD): New macros. * mpn/generic/mode1o.c: New file. * tests/mpz/reuse.c: Add testing of mpz_divexact_gcd. * tests/mpz/t-fac_ui.c: Use libtests for memory leak checking. * tests/mpz/t-fib_ui.c: Add a usage comment. * tests/mpz/bit.c: Use libtests. * tests/mpz/t-scan.c: Remove unused subroutines. * tests/devel/try.c: Use libtests, define PROT_NONE if the system doesn't. * tests/spinner.c, tests/x86check.c: Use tests.h. * tests/trace.c: Use tests.h, add mpf_trace. * tests/refmpn.c: Use tests.h, add refmpn_malloc_limbs_aligned, refmpn_tstbit, refmpn_neg. * tune/common.c, tune/speed.h: Update for functions moved to tests/misc.c. * tune/Makefile.am, tests/mpz/Makefile.am, tests/mpq/Makefile.am, tests/mpf/Makefile.am: Use tests/libtests.la. * configure.in (AC_OUTPUT): Update for new directories. (x86 CALLING_CONVENTIONS_OBJS): Use .lo for libtests.la, allow ansi2knr on x86check.c. * tests/Makefile.am: Establish new libtests.la convenience library, add mpz, mpq, mpf, mpbsd subdirectories. * tests/tests.h: New file. * mpn/tests/ref.h,try.h: Remove files, now in tests.h. * tests/mpf/ref.c: Move to tests/refmpf.c, rename functions to refmpf. * tests/mpf/t-add.c, tests/mpf/t-sub.c: Use libtests. * tests/mpf/Makefile.am: Update. * tests/memory.c: New file. * tests/misc.c: New file, a few subroutines from the test programs. * mpz/tests, mpq/tests, mpf/tests, mpbsd/tests: Move directories to tests/mpz etc. * mpz/Makefile.am, mpq/Makefile.am, mpf/Makefile.am, mpbsd/Makefile.am (SUBDIRS): Remove. * tests/devel: New directory. * mpn/tests/*.c: Move programs to tests/devel. * mpn/tests/Makefile.am, mpn/tests/README: Move to tests/devel, update. * mpn/tests/ref.c: Move to tests/refmpn.c. * mpn/tests/spinner.c,trace.c,x86call.asm,x86check.c: Move to tests directory. * tests/t-constants.c: Add checks of HIGHBIT, MAX and MIN constants, simplify ANSI vs K&R stringizing, use correct printf format types, do all tests before aborting. 2001-01-05 Torbjorn Granlund * mpn/cray/ieee/gmp-mparam.h: Retune. 2001-01-05 Kevin Ryde * configure.in (mp.h): Only create this under --enable-mpbsd. * demos/calc: New subdirectory, move demos/calc* to it. * demos/calc/Makefile.am: New file, split from demos/Makefile.am. * demos/Makefile.am: Update. * configure.in (AC_OUTPUT): Add demos/calc/Makefile. * tests/t-constants.c (CALC_BITS_PER_TYPE etc): Use a run-time test for how many bits work in a give type, don't assume bits==8*sizeof. 2001-01-04 Kevin Ryde * mpz/fits_s.c, mpz/fits_u.c: New files, split from fits.c, use plain UINT_MAX etc, not MPZ_FITS_UTYPE_SDT etc. * mpz/fits.c: Remove file. * mpz/Makefile.am, macos/Makefile.in: Update. * gmp-impl.h (UNSIGNED_TYPE_MAX etc): Remove these generic forms. (MPZ_FITS_[SU]TYPE_SDT): Remove these. (UINT_MAX etc): Provide a full set of defaults. * gmp-h.in (__GMP_MP_SIZE_T_INT): New define. * mpz/tests/t-scan.c: New file. * mpz/tests/Makefile.am (check_PROGRAMS): Add it. * mpz/scan0.c, mpz/scan1.c: Rewrite, don't read beyond allocated memory, support negatives, return ULONG_MAX for no bit found. * gmp.texi (Integer Logic and Bit Fiddling): Update. 2001-01-03 Torbjorn Granlund * mpz/tests/dive.c: Generate test operands using new random functions. * mpz/tests/io.c: Likewise. * mpz/tests/logic.c: Likewise. * mpz/tests/t-2exp.c: Likewise. * stack-alloc.c (__gmp_tmp_alloc): Round `now' to required alignment. * stack-alloc.h (__TMP_ALIGN): Append `L'. * gmp-impl.h: For Cray, #include limits.h. (LONG_MIN): New #define. (ULONG_HIGHBIT): #define in terms of ULONG_MAX. (LONG_HIGHBIT): #define as LONG_MIN. (USHRT_MAX): New name for USHORT_MAX. (SHRT_MAX): New name for SHORT_MAX. (SHRT_MIN): New #define. (USHORT_HIGHBIT,SHORT_HIGHBIT): Removed. * mpbsd/tests/t-misc.c (check_itom [data]): *SHORT* => *SHRT*; remove code disabling a test for Cray. * tests/t-constants.c (CHECK_CONSTANT): Cast parameters to long. * mpn/generic/mul_n.c (mpn_kara_sqr_n): Remove unused variable `t'. (mpn_kara_mul_n): Likewise. * mpz/fac_ui.c (MPZ_SET_1_NZ): Actually use `__z'. * mpz/tests/t-jac.c (main, check_squares_zi): Generate test operands using new random functions. All changes below on this date for enabling `make; make check' with C++ compilers: * mpz/tests/t-pow_ui.c (debug_mp, ref_mpz_pow_ui): Provide prototypes. * mpz/tests/t-mul.c (debug_mp, base_mul, ref_mpz_mul): Provide prototypes. (dump_abort): Provide prototype and declare properly for C++. * mpz/tests/t-jac.c: #include stdlib.h and sys/time.h. * mpz/tests/t-fdiv.c (dump_abort): Provide prototype and declare properly for C++. (debug_mp): Provide prototype. * mpz/tests/t-fdiv_ui.c: Likewise. * mpz/tests/t-gcd.c: Likewise. * mpz/tests/t-powm.c: Likewise. * mpz/tests/t-powm_ui.c: Likewise. * mpz/tests/t-sqrtrem.c: Likewise. * mpz/tests/t-tdiv_ui.c: Likewise. * mpz/tests/t-tdiv.c: Likewise. * mpz/tests/t-2exp.c: #include stdlib.h and sys/time.h. Remove #include of longlong.h. * mpz/tests/io.c: #include config.h, stdlib.h, sys/time.h, and conditionally unistd.h. * mpz/tests/dive.c: #include stdlib.h and sys/time.h. (dump_abort): Provide prototype and declare properly for C++. (debug_mp): Provide prototype. * mpz/tests/logic.c: Likewise. * mpz/tests/convert.c (debug_mp): Provide prototype. * mpz/tests/t-root.c (debug_mp): Likewise. * mpz/tests/bit.c: #include stdlib.h and sys/time.h. * mpq/tests/t-get_d.c: #include stdlib.h and sys/time.h. (dump): Provide prototype and declare properly for C++. * mpq/tests/t-cmp_ui.c: #include stdio.h, stdlib.h and sys/time.h. (ref_mpq_cmp_ui): Declare properly for C++. * mpq/tests/t-cmp.c: #include stdlib.h and sys/time.h. (ref_mpq_cmp): Declare properly for C++. (dump): Delete unused function. * mpf/random2.c (myrandom): New function. (mpf_random2): Use it. * mpn/generic/random2.c: #include stdlib.h (for random/mrand48). (myrandom): New function. (mpn_random2): Use it. * mpf/tests/t-add.c: #include stdlib.h and sys/time.h. (oo): Remove unused function. * mpf/tests/t-conv.c: Likewise. * mpf/tests/t-sub.c: Likewise. * mpf/tests/t-dm2exp.c: Likewise. * mpf/tests/t-muldiv.c: Likewise. * mpf/tests/t-sqrt.c: Likewise. * mpf/tests/reuse.c: #include stdlib.h and sys/time.h. Use PROTO on some typedefs. (oo): Remove function. (dump_abort): Call mpf_dump instead of oo. * mpf/set_str.c: #include stdlib.h (for strtol). * mpf/random2.c: #include stdlib.h (for random/mrand48). * mpn/alpha/udiv_arnnd: File deleted. * Remove K&R function headers. 2001-01-02 Torbjorn Granlund * mpn/generic/mul.c: Clean up spacing and indentation. * mpn/generic/mul_fft.c (mpn_fft_add_modF): Use mpn_decr_u. Clean up spacing and indentation. * extract-dbl.c: Generalize to handle smaller limb sizes. 2001-01-01 Torbjorn Granlund * mpbsd/mout.c: Output newline after "0". 2000-12-31 Torbjorn Granlund * ltmain.sh: Remove space between `#!' and `$SHELL' when generating `libtool'. * mpbsd/tests/t-misc.c (check_itom): Exclude test for all Cray vector systems. Correct comment. 2000-12-31 Kevin Ryde * gmp.texi (ABI and ISA): New enough gcc needed for mips n32 etc, gcc 2.95 needed for sparc 64-bit ABI, gcc 2.8 needed for -mv8plus. * configure.in ([cjt]90,sv1-cray-unicos*): Preserve user specified MPN_PATH, amend test program indenting. (none-*-*): Add -DNO_ASM to gcc to disable longlong.h asm macros in generic C. * config.sub (j90, t90): Preserve these, don't let configfsf.sub turn them into c90. * config.guess (m68k-*-nextstep*,m68k-*-openstep*): Don't transform m68k to m68020, since m68k is already interpreted as 68020. 2000-12-30 Kevin Ryde * mpq/neg.c: Rewrite, use mpn, avoid denominator copy if unnecessary. * mpz/tstbit.c: Rewrite, slightly simplified. * mpz/tests/bit.c (check_tstbit): New test, and add a couple more diagnostics elsewhere. * configure.in (x86 gcc_cflags_cpu): Add -m486 for gcc 2.7.2. (ccbase): Only use a known compiler in eval statements (avoids problems with non-symbol characters). (ccbase): Use GMP_PROG_CC_IS_GNU to identify gcc installed under a different name. (cclist): Use same style $abi as other variables. * acinclude.m4 (GMP_PROG_CC_IS_GNU): New macro. (GMP_GCC_MARCH_PENTIUMPRO): Use $ccbase to identify gcc. (GMP_ASM_TYPE): Define TYPE to empty, not "dnl", when no .type needed. (GMP_ASM_SIZE): Ditto for SIZE, which ensures EPILOGUE on the last line of a file doesn't leave a tab and no newline. (GMP_ASM_UNDERSCORE): Add a prototype for C++. * configure.in (sys/mman.h, mprotect): New tests. * mpn/tests/try.c: Use them, and HAVE_UNISTD_H too. * configure.in (getopt.h): Remove test. * tune/speed.c, mpn/tests/try.c (getopt.h): Remove include, since plain getopt() is in . * configure.in, gmp-h.in (mips*-*-irix6*): Set limb_n32=longlong rather than using _ABIN32. 2000-12-29 Torbjorn Granlund * mpz/tests/reuse.c: Rename dump_abort => dump. * mpz/tests/reuse.c: Generate operands using gmp_rand*. * mpz/tests/convert.c: Likewise. * configure.in: Detect T90-ieee systems; move Cray path selection to after AC_PROG_CC. Invoke AC_PROG_CPP. * mpn/cray/cfp: New directory. Move cfp specific files here. * mpn/cray/cfp/mulwwc90.s: New file. * mpn/cray/cfp/mulwwj90.s: New file. * mpn/cray/mulww.s: Delete. 2000-12-27 Torbjorn Granlund * mpn/cray/ieee/mul_1.c: New file. * mpn/cray/ieee/addmul_1.c: New file. * mpn/cray/ieee/submul_1.c: New file. * mpn/cray/ieee/gmp-mparam.h: New file. * mpn/cray/gmp-mparam.h: Disable UMUL_TIME and UDIV_TIME. * mpn/cray/hamdist.c: New file. * mpn/cray/popcount.c: New file. * mpn/cray/rshift.c: New file. * mpn/cray/lshift.c: New file. * longlong.h: Add count_leading_zeros for _CRAY. Reorganize _CRAY stuff. 2000-12-24 Kevin Ryde * configure.in (alpha*-cray-unicos*): Disable SPEED_CYCLECOUNTER_OBJ, as tune/alpha.asm doesn't suit. * mpn/generic/sqrtrem.c, mpz/pow_ui.c, mpz/powm_ui.c, mpf/get_str.c, mpf/set_str.c: Use mpn_sqr_n when applicable, not mpn_mul_n. 2000-12-23 Torbjorn Granlund * mpn/generic/mul_fft.c: Reformat. (mpn_fft_neg_modF): Remove. (mpn_fft_mul_2exp_modF): Inline mpn_fft_neg_modF. * mpn/cray/gmp-mparam.h: Retune. * configure.in (*-cray-unicos*): Pass `-O3 -htask0'. (vax*-*-*): Fix typo. * mpn/cray/mul_1.c: Use dynamic arrays, get rid of TMP_*. * mpn/cray/addmul_1.c: Likewise. * mpn/cray/submul_1.c: Likewise. * mpn/cray/add_n.c: Likewise. * mpn/cray/sub_n.c: Likewise. * configure.in (default cc_cflags,cc_64_cflags): Remove -g/add -O. (mips*-*-irix[6789]*]): Remove -g from cc_*_cflags. 2000-12-22 Torbjorn Granlund * mpn/generic/mul_n.c: Delete K&R function headers. * mpn/generic/mul_n.c (mpn_kara_mul_n): Clean up type confusion between mp_limb_t and mp_size_t. (mpn_kara_sqr_n): Likewise. * mpn/generic/mul_n.c (mpn_kara_mul_n): Use mpn_incr_u. (mpn_kara_sqr_n): Likewise. * mpn/generic/mul_n.c (mpn_kara_mul_n): Change handling of `sign' to work around GCC 2.8.1 MIPS bug. * configure.in (implied alpha*-cray-unicos*): Remove -g from cc_cflags. 2000-12-21 Torbjorn Granlund * mpn/alpha/invert_limb.asm: Simplify a bit. Add handling of bigend systems. * mpn/alpha/unicos.m4: Define `bigend'. * mpn/alpha/default.m4: Define `bigend' (to expand to nothing). * tests/t-constants.c (CHECK_CONSTANT): Print using %lx. * mpn/alpha/gmp-mparam.h: Remove sizes for plain C types. * mpn/alpha/ev5/gmp-mparam.h: Likewise. * mpn/alpha/ev6/gmp-mparam.h: Likewise. * mpn/alpha/unicos.m4: Define LEA. * mpn/alpha/default.m4: Likewise. * mpn/alpha/invert_limb.asm: Use LEA for loading symbolic addresses. * mpn/alpha/cntlz.asm: Likewise. * mpn/alpha/cntlz.asm: Don't use `ldbu', use slightly slower `ldq_u' + `extbl' instead. * mpn/alpha/unicos.m4: Define EXTERN. * mpn/alpha/default.m4: Define EXTERN (to expand to nothing). * mpn/alpha/cntlz.asm: Declare __clz_tab usign `EXTERN' (for the benefit of Unicos). 2000-12-21 Kevin Ryde * mpn/alpha/unicos.m4 (GSYM_PREFIX): Define for the benefit of __clz_tab. 2000-12-20 Torbjorn Granlund * longlong.h: Add udiv_qrnnd and count_leading_zeros for _CRAYMPP systems. 2000-12-19 Torbjorn Granlund * configure.in (*sparc*-*-*): Remove -g from cc_cflags and acc_cflags. * mpn/generic/sqrtrem.c (mpn_sqrtrem): Separate `limb' values from `size' values. * configure.in (*-cray-unicos*): Add `-Wa,-B' to cc_cflags. * demos/pexpr.c (rstate): New variable. (main): Initialize rstate. (enum op_t): Add RANDOM. (fns): Add field for RANDOM. (mpz_eval_expr): Handle RANDOM. 2000-12-19 Kevin Ryde * mpn/generic/sqrtrem.c: Rewrite by Paul Zimmermann, based on his Karatsuba Square Root algorithm. * gmp.texi (Square Root Algorithm): Update. * tune/many.pl: New file. * mpn/tests/try.c,ref.[ch] (mpn_preinv_mod_1, mpn_sb_divrem_mn, mpn_tdiv_qr, mpn_gcd_finda, mpn_kara_mul_n, mpn_kara_sqr_n, mpn_toom3_mul_n, mpn_toom3_sqr_n): Add testing. * mpn/tests/ref.c: Cast some "0"s in function calls. * mpn/x86/k7/mmx/mod_1.asm: Add preinv_mod_1 entrypoint, remove extra variable for loop termination. * mpn/x86/p6/mmx/mod_1.asm: Remove file, in favour of the following. * mpn/x86/p6/mod_1.asm: New file. * mpn/x86/pentium/mod_1.asm: New file. 2000-12-18 Torbjorn Granlund * configure.in (mips*-*-irix[6789]*): Pass options to compiler using `-Wc'. 2000-12-18 Kevin Ryde * mpn/x86/k6/pre_mod_1.asm: New file. * tune/tuneup.c (USE_PREINV_MOD_1): Tune this, rearrange mpn_divrem_1 and mpn_mod_1 handling in support of it. * tune/Makefile.am: Consequent changes to divrem_1.c and mod_1.c. * gmp-impl.h (USE_PREINV_MOD_1, MPN_MOD_OR_PREINV_MOD_1): New macros. * mpn/generic/perfsqr.c, mpz/pprime_p.c: Use MPN_MOD_OR_PREINV_MOD_1. * configure.in: Let an asm mod_1 provide a preinv_mod_1 entrypoint. * mpn/alpha/default.m4: Remove some newlines, add some asserts. (r0 etc, f0 etc): Use defreg and deflit. (PROLOGUE, PROLOGUE_GP, EPILOGUE): Use GSYM_PREFIX. * mpn/alpha/unicos.m4: Remove some newlines, add some asserts. * mpn/alpha/invert_limb.asm: Remove unused second DATASTART parameter. * mpn/alpha/cntlz.asm: Use mpn_count_leading_zeros and __clz_tab. * mpn/asm-defs.m4 (changecom): Comments on portability. (__clz_tab, modlimb_invert_table): New macros, matching gmp-impl.h. (count_leading_zeros, count_trailing_zeros): New define_mpn's. (PROLOGUE etc): Comments on usage, add some asserts. (OPERATION_[lr]shift): Use m4_not_for_expansion, for the benefit of lorrshift multifunc. * mpn/Makeasm.am (RM_TMP): New variable controlling tmp-*.s removal, for development purposes. * mpz/fac_ui.c: Fix for long long limb by using mpn_mul_1 not mpz_mul_ui, and note some possible enhancements. * mpz/tests/t-fac_ui.c: New test. * mpz/tests/Makefile.am (check_PROGRAMS): Add it. * macos/Makefile.in: Ditto, and add t-fib_ui too. * mpn/generic/[lr]shift.c: Remove some DEBUG code adequately covered by new parameter ASSERTs. * longlong.h (count_trailing_zeros): Assert x!=0. * doc/configuration: Updates for new configure things, add some notes on test setups. 2000-12-16 Torbjorn Granlund * configure.in (*-*-aix): Pass -qmaxmem=20000 to xlc also for 64-bit compiles. * configure.in: Disable shared libs for *-*-ultrix*. 2000-12-15 Torbjorn Granlund * configure.in (powerpc*-*-*): Pass -Wa,-mppc when using gcc. * gmp-impl.h (_EXTERN_INLINE): #define different for GCC and other compilers. * gmp-h.in (__gmp_inline): Remove. * mp-h.in: Likewise. * mpn/generic/gcd.c: Use `inline' instead of `__gmp_inline'. * configure.in (mips*-*-irix[6789]*): Define *_ldflags. 2000-12-14 Torbjorn Granlund * mpn/generic/pre_mod_1.c: Use proper type for udiv_qrnnd parameter `dummy'. * mpn/generic/divrem_1.c: Use explicit `!= 0' in if statement. * mpn/generic/mod_1.c: Likewise. 2000-12-14 Kevin Ryde * config.guess (mips-*-irix[6789]*): Transform to mips64. (m68k-*-nextstep* | m68k-*-openstep*): Transform to m68020. 2000-12-13 Torbjorn Granlund * tests/t-constants.c (main): Conditionalize use of PP_INVERTED. * mpn/mp_bases.c: Handle 4-bit limbs. (main): Add code for generating tables. * mpn/generic/popham.c: Handle limb bitsizes of 4, 8, 16. Suffix all 32-bit constant with `L'. Use CNST_LIMB for 64-bit constants. 2000-12-13 Kevin Ryde * gmp-impl.h (FIB_THRESHOLD): Defaults for 4,8,16 bits per limb, and an arbitrary fallback default. (modlimb_invert): Add efficient code for 8,16 (or 4) bits per limb. * configure.in (mips3, mips64): Don't bother with o32 (mips2 32-bit limb) on IRIX 6. * Makefile.am (SUBDIRS): Put "tests" first so tests/t-constants.c is run first, to pick up any limb size mismatch. * tune/tuneup.c (DIVREM_1, MOD_1): Fix result values, were off by 1. * mpz/fib_ui.c (table1, table2): Add data for 4,8,16 bits per limb. 2000-12-12 Torbjorn Granlund * gmp-impl.h (LIMBS_PER_DOUBLE): Define for any limb bitsize. 2000-12-11 Torbjorn Granlund * mpn/mp_bases.c: Add tables for 8-bit and 16-bit limbs. Round existing `double' values properly. * gmp-h.in (__gmp_randstate_struct): Prefix field names with _mp_ to keep out of user name space. (__gmp_randata_lc): Likewise. * randclr.c, randlc.c, randlc2x.c, randraw.c, randsd.c, randsdui.c: Corresponding changes. * gmp-impl.h (PP): #define for machines with BITS_PER_MP_LIMB of 2, 4, 8, and 16. (PP_FIRST_OMITTED): New, define for various BITS_PER_MP_LIMB. (PP_MASK): Remove. (PP_MAXPRIME): Remove. * mpn/generic/perfsqr.c: Generalize PP handling for machines with limbs of < 32 bits. Allow PP_INVERTED to be undefined. * mpz/pprime_p.c: Likewise. 2000-12-10 Torbjorn Granlund * mpn/generic/mul_1.c: Declare parameters in C89 style. 2000-12-10 Kevin Ryde * tune/Makefile.am (speed_LDFLAGS, speed_ext_LDFLAGS, tune_LDFLAGS): Don't use -all-static, as gcc 2.95.2 on i386 solaris 8 doesn't like it. * configure.in (mips3,mips64): Add ABI=64, name the others ABI=n32 and ABI=o32. * mpn/mips3/gmp-mparam.h (BITS_PER_LONGINT): Remove #define and let configure determine it, since it varies with ABI=64 or ABI=n32. * gmp.texi (ABI and ISA): Update. (mpz_mod_ui): Remark that it's identical to mpz_fdiv_r_ui. (mpn_divexact_by3): Qualify a statement needing mp_bits_per_limb even. * mul_fft.c (mpn_fft_mul_modF_K etc): Patch by Paul Zimmermann to fix results in certain cases of recursing into a further FFT. 2000-12-09 Torbjorn Granlund * mpz/cmpabs.c: Remove unused variable. * mpz/rrandomb.c: Likewise. * mpz/xor.c: Likewise. 2000-12-07 Torbjorn Granlund * mpn/generic/gcdext.c: Handle double carry when computing s1. Merge two code blocks for computing s0 and s1. 2000-12-07 Kevin Ryde * configure.in (hppa*-*-*): Remove -Aa -D_HPUX_SOURCE from cc_cflags/cppflags, and instead let AM_C_PROTOTYPES add it, or -Ae, whichever works. * configure.in (*-*-aix[34]*): Disable shared by default, but let the user override that, if desired. * gmp.texi (Notes for Particular Systems): Update. 2000-12-06 Torbjorn Granlund * mpq/cmp_ui.c: Streamline. 2000-12-06 Kevin Ryde * tune/divrem_1_div.c,divrem_1_inv.c,mod_1_div.c,mod_1_inv.c, gcdext_double.c: New files for measuring. * tune/Makefile.am (libspeed_la_SOURCES): Add them. * tune/speed.c,speed.h,common.c: Add measuring of them. (mpn_preinv_mod_1, mpz_jacobi, mpz_powm_ui): Add measuring. * speed.c (getopt_long): Don't use this, just plain getopt. * configure.in (getopt_long): Remove test. * gmp-impl.h (MPN_KARA_MUL_N_TSIZE, MPN_KARA_MUL_N_MINSIZE, MPN_TOOM3_MUL_N_TSIZE, MPN_TOOM3_MUL_N_MINSIZE): New macros, and assume toom3 square tsize was meant to be the same as the mul (both are overestimates). * tune/tuneup.c, mpn/generic/mul.c, mpn/generic/mul_n.c: Use them. * mpn/generic/mul_n.c (mpn_toom3_sqr_n): Fix an ASSERT to use TOOM3_SQR_THRESHOLD not TOOM3_MUL_THRESHOLD, add a few that might be more realistic size checks. * tune/speed.h (SPEED_ROUTINE_MPN_MUL_N_TSPACE etc): Use minsize. * mpn/generic/divrem_1.c: Partial rewrite, merge fractional part calculation, skip a divide step in more cases, introduce DIVREM_1_NORM_THRESHOLD and DIVREM_1_UNNORM_THRESHOLD. * mpn/generic/mod_1.c: Partial rewrite, skip a divide step in more cases, introduce MOD_1_NORM_THRESHOLD, MOD_1_UNNORM_THRESHOLD. * longlong.h (UDIV_PREINV_ALWAYS): New define, set for alpha and ia64. * tune/tuneup.c (DIVREM_1_NORM_THRESHOLD, DIVREM_1_UNNORM_THRESHOLD, MOD_1_NORM_THRESHOLD, MOD_1_UNNORM_THRESHOLD): Tune these. * gmp-impl.h [TUNE_PROGRAM_BUILD]: Support for this. * tune/Makefile.am (TUNE_MPN_SRCS): Add divrem_1.c and mod_1.c. * gmp-impl.h (UDIV_NORM_PREINV_TIME): Renamed from UDIV_PREINV_TIME. * mpn/generic/perfsqr.c, mpn/generic/sb_divrem_mn.c, mpn/x86/*/gmp-mparam.h: Ditto. * gmp-impl.h (UDIV_UNNORM_PREINV_TIME): New define. * configure.in (AC_C_INLINE, HAVE_INLINE): New test and define. * gmp-impl.h (inline): Remove, use config.h. (_EXTERN_INLINE): Redefine based on HAVE_INLINE. (mpn_zero_p): Use HAVE_INLINE. * acinclude.m4 (GMP_PROG_AR, GMP_PROG_NM): Don't add flags to a user selected $AR or $NM. * tune/tuneup.c (all): Print how long the tuning took. * configure.in (AM_C_PROTOTYPES): Use this, not GMP_ANSI2KNR. * acinclude.m4 (GMP_ANSI2KNR): Remove. * Makefile.am (gmp.h, mp.h): In DISTCLEANFILES not CLEANFILES. * gmp-h.in (mpn_divmod, mpn_divmod_1, mpn_divexact_by3): Cast some zeros, for the benefit of K&R if long!=int. * mpn/lisp/gmpasm-mode.el (gmpasm-comment-start-regexp): Add "*" for the benefit of cray. * compat.c (mpn_divexact_by3, mpn_divmod_1): Return types should be mp_limb_t, not int, and need an actual "return". 2000-12-05 Torbjorn Granlund * mpn/sparc32/v8/supersparc/gmp-mparam.h: Retune. * mpn/alpha/gmp-mparam.h: Tune for 21064. * longlong.h: Reformat to avoid newlines within strings. * gmp-impl.h (inline): Disable if GCC has defined __STRICT_ANSI__. * configure.in: Do a `mkdir tune' before creating tune/sqr_basecase.c. * Makefile.am: Treat mp.h analogously to gmp.h. configure.in (*-*-aix): Pass -qmaxmem=20000 to xlc. * mp-h.in: Renamed from mp.h. Add #define for _LONG_LONG_LIMB. Move some other fixes from gmp-h.in. * mp.h: Removed. * configure.in: Generate mp.h from mp-h.in like we handle gmp-h.in/gmp.h. 2000-12-04 Torbjorn Granlund * acinclude.m4: Fix typo testing for bad HP compiler. 2000-12-03 Torbjorn Granlund * mpbsd/tests/t-misc.c (check_itom): Exclude some tests for Cray CFP systems. * longlong.h (CRAYIEEE umul_ppmm): New. * mpn/cray/gmp-mparam.h (BITS_PER_SHORTINT): 32 => 64. (*_THRESHOLD): Tune. * configure.in: Disable shared libs for *-*-unicos*. 2000-12-03 Kevin Ryde * configure.in, tune/Makefile.am: Create tune/sqr_basecase.c during configure, and use it unconditionally in $(nodist_tuneup_SOURCES). Fixes a problem with sqr_basecase.lo under --disable-static. 2000-12-01 Torbjorn Granlund * mpf/tests/t-get_d.c (LOW_BOUND,HIGH_BOUND): #define for non-IEEE Cray systems. * gmp-impl.h (union ieee_double_extract): Test for _CRAYIEEE. 2000-11-30 Torbjorn Granlund * mpz/tests/t-mul.c (base_mul): Fix re-evaluation problems in macro invocations. (ref_mpz_mul): New name from mpz_refmul. Make static. (base_mul): New name for _mpn_mul_classic. 2000-11-30 Kevin Ryde * configure.in: Rewrite of CC/CFLAGS selection scheme, introduce a notion of ABI, merge compiler and mpn path selection, add flags selection for AR and NM, let CC without CFLAGS work. (AC_PROG_CC): Use this, not GMP_SELECT_CC. * acinclude.m4 (GMP_PROG_CC_WORKS): Don't use AC_TRY_COMPILE, combine cc/cflags parameter. (GMP_PROG_CC_FIND, GMP_CHECK_CC_64BIT, GMP_PROG_CC_SELECT): Remove. * gmp.texi (Installing GMP): Updates for new scheme. * configure.in (AC_CANONICAL_HOST): Use this and $host, not $target. * acinclude.m4, acconfig.h, longlong.h, mpn/x86/x86-defs.m4, mpn/x86/k7/mmx/popham.asm: Ditto, renaming HAVE_TARGET_CPU to HAVE_HOST_CPU. * gmp.texi (Build Options, and elsewhere): Update. * acinclude.m4 (GMP_COMPARE_GE): New macro. (GMP_GCC_MARCH_PENTIUMPRO): Use it, add CC parameter, check for GCC. (GMP_HPC_HPPA_2_0): New macro, adapted from GMP_CHECK_CC_64BIT. * acinclude.m4 (GMP_PROG_AR): New macro, using AC_CHECK_TOOL, adding GMP flags. * configure.in: Use it * gmp-h.in: Renamed from gmp.h. (@define_LONG_LONG_LIMB@): Placeholder for instantiation. (__GNU_MP__): Bump to 3. * acinclude.m4 (GMP_VERSION): Get version from gmp-h.in. * configure.in: Create gmp.h from gmp-h.in to set _LONG_LONG_LIMB. * gmp.texi.h (ABI and ISA): Mention this. * acconfig.h (_LONG_LONG_LIMB): Remove undef. * Makefile.am: Distribute gmp-h.in, not gmp.h. * configure.in (AC_PROG_CPP, AC_PROG_INSTALL, AC_PROG_LN_S): Remove, dragged in by other macros. (gmp_asm_syntax_testing): Renamed from gmp_no_asm_syntax_testing. (AC_EXEEXT, AC_OBJEXT): Remove, done automatically by libtool. * configure.in, acinclude.m4: Remove "" from "`foo`", being unnecessary and not portable. * configure.in (GMP_LDFLAGS): New AC_SUBST flags for libtool link. (powerpc64*-*-aix*): Use for -Wc,-maix to fix shared library creation, but can't build shared and static at the same time. * Makefile.am (libgmp_la_LDFLAGS, libmp_la_LDFLAGS): Use $(GMP_LDFLAGS). * gmp.texi (Notes for Particular Systems): Update AIX problem * configure.in (AC_CONFIG_LINKS): Use where needed, not via gmp_links. (gmp_srclinks): Build up as needed, not via gmp_links. * acinclude.m4 (GMP_INIT): Do CONFIG_TOP_SRCDIR and asm-defs.m4 here. * configure.in (asm-defs.m4): Consequent changes. * acinclude.m4 (GMP_INCLUDE_MPN): Using include_mpn(), replacing GMP_INCLUDE and GMP_SINCLUDE. * configure.in (gmp_m4postinc): Remove this scheme, use GMP_INCLUDE_MPN instead. * configure.in (*-*-sco3.2v5*): Force ac_cv_archive_cmds_need_lc=no, until libtool does this itself. * gmp.texi (Known Build Problems): Remove SCO -lc problem. * configure, INSTALL.autoconf, etc: Update to autoconf 2000-11-29. * acinclude.m4 (GMP_C_SIZES): Use AC_CHECK_SIZEOF. * gmp.texi (Known Build Problems): Remove version.c sed/config.h problem, fixed. * ltmain.sh, aclocal.m4: Update to libtool 2000-11-25. * ltconfig: No longer required, but leave an empty dummy for automake. * gmp.texi (Known Build Problems): Remove SunOS native ar ranlib problem, fixed. * */Makefile.in, aclocal.m4: Update to automake 2000-11-25. * mpbsd/tests/Makefile.am, mpfr/tests/Makefile.am (check_PROGRAMS): Remove dummy, no longer required. * mpbsd/tests/dummy.c, mpfr/tests/dummy.c: Remove files. * depcomp: Remove file, no longer required (with no-dependencies). * texinfo.tex: Update to 2000-11-09. * gmp.texi (Build Options): Mention PDF from gmp.texi. * Makefile.am (MOSTLYCLEANFILES): Add gmp.tmp, from new texinfo.tex. * gmp.texi (Build Options): List alphaev56, alphapca56, alphaev67, hppa2.0n and power among supported CPUs. 2000-11-30 Torbjorn Granlund * mpz/tests/t-mul.c: Increase max operand size from 2^17 bits to 2^19 bits. Misc cleanups. 2000-11-26 Kevin Ryde * tune/tuneup.c (FIB_THRESHOLD): Cope better with different speeds of odd and even sizes. * longlong.h (alpha): Use udiv_qrnnd and count_leading_zeros on all compilers, not just gcc. * pre_mod_1.c: Use conditional subtract to always skip a division. (UMUL_TIME, UDIV_TIME): Remove defaults, now in longlong.h. 2000-11-22 Torbjorn Granlund * mpn/pa64w/gmp-mparam.h: Retune. * mpn/pa64/gmp-mparam.h: Retune. * mpn/sparc64/gmp-mparam.h: Retune. 2000-11-22 Kevin Ryde * gmp-impl.h (ABOVE_THRESHOLD, BELOW_THRESHOLD): New macros. * mpn/generic/gcdext.c: Use them. * mpn/generic/gcdext.c [WANT_GCDEXT_ONE_STEP]: Force only one step. * tune/gcdextos.c, tune/gcdextod.c: New files, one step gcdext, single and double. * tune/Makefile.am (libspeed_la_SOURCES): Add them. (TUNE_MPN_SRCS): Remove gcdext.c. * tune/speed.h, tune/common.c, tune/speed.c: Add measuring. * tune/tuneup.c: Use for GCDEXT_THRESHOLD, plus check if double limb is ever better. Should be more accurate, and hopefully faster. * tune/gcdext_single.c: New file, gcdext forced to single limbs. * tune/Makefile.am: Add it. * tune/speed.h, tune/common.c, tune/speed.c: Add measuring, and of invert_limb. * tune/speed.h (speed_params r): Use mp_limb_t, not long. * tune/speed.h, tune/common.c: Don't "switch" on "r". * tune/speed.c (r_string): Accept limb sized constants. (choice scale): Add a scale factor (eg. "2.33*mpn_add_n"). * tune/common.c (SPEED_ROUTINE_UDIV_QRNND_A): Default r to __mp_bases[10].big_base, being a full limb value. * configure.in (alphapca56*-*-*): Use ev5 mpn path. (am29000*-*-*): Remove this, leave the canonical a29k. (z8k*-*-*, z8kx*-*-*): Changed from z8000, since z8k is canonical. (gmp_mpn_functions_optional): Add invert_limb, use for alpha and ia64. * configure.in (alloca): Accept yes/no/detect, generate an error if "yes" but not available. * gmp.texi (Build Options): Update. * acinclude.m4 (GMP_TRY_ASSEMBLE): Make conftest.out available. (GMP_ASM_ALIGN_FILL_0x90): Use it. * acinclude.m4 (GMP_ASM_X86_MMX) [*-*-solaris*]: Check for solaris 2.6 "as" movq bug. * gmp.texi (Notes for Particular Systems): Update x86 MMX note. 2000-11-21 Torbjorn Granlund * tune/Makefile.am (EXTRA_DIST): List hppa2w.asm. * tune/hppa2.asm: Change level directive to "2.0n". * tune/hppa2w.asm: New file. * configure.in [SPEED_CYCLECOUNTER_OBJS switch]: Separate out hppa2.0w. * mpn/pa64/gmp-mparam.h (BITS_PER_LONGINT): 64 => 32. 2000-11-21 Kevin Ryde * urandom.h (random): No prototype if glibc stdlib.h has already provided it (avoids an int32_t/long conflict). * tune/Makefile.am (LDFLAGS): Use -all-static. (speed-dynamic): Dynamic linked version of speed.c. * tune/README: Update. * mpn/generic/gcd.c (find_a): Use native version if available. * acconfig.h (HAVE_NATIVE_mpn_gcd_finda): Add #undef. * gmp-impl.h (mpn_gcd_finda): Add prototype and define. * mpn/asm-defs.m4 (mpn_gcd_finda): New define_mpn. * tune/gcd_finda_gen.c: #undef any HAVE_NATIVE_mpn_gcd_finda. * configure.in (gmp_mpn_functions_optional): Add gcd_finda. * mpn/x86/k6/gcd_finda.asm: New file. * tune/tuneup.c (POWM_THRESHOLD): Slightly bigger size steps. * gmp-impl.h (__GMP_IMPL_H__): Protect against multiple inclusion. * tune/gcd_bin.c, tune/powm_mod.c, tune/powm_redc.c: Use #undef after gmp-impl.h to force thresholds. * tune/tuneup.c (print_define, fft): No need for #ifndefs on thresholds any more. 2000-11-20 Torbjorn Granlund * mpz/tests/t-powm.c: Analogous changes as made 2000-11-12 to t-mul.c. * mpz/tests/t-powm_ui.c: Likewise. * mpz/tests/t-pow_ui.c: Likewise. * mpz/tests/t-root.c: Likewise. * configure.in [compiler switch]: Pass "-Aa -D_HPUX_SOURCE" to cc for all hppa versions. * mpn/hppa/hppa1_1/udiv_qrnnd.S: Reference data using PC relative addressing (was r19 relative addressing). 2000-11-18 Torbjorn Granlund * rand.c: (__gmp_rand_lc_scheme): Convert strings to hexadecimal. (gmp_randinit): Expect strings in hexadecimal. 2000-11-18 Kevin Ryde * configfsf.guess, configfsf.sub: Update to 2000-11-16. * config.guess (alpha*-*-openbsd*): Do exact cpu detection. 2000-11-14 Torbjorn Granlund * mpz/tests/t-fdiv.c: Analogous changes as made 2000-11-12 to t-mul.c. * mpz/tests/t-tdiv_ui.c: Likewise. * mpz/tests/t-fdiv_ui.c: Likewise. * mpz/tests/t-sqrtrem.c: Likewise. * mpz/tests/t-gcd.c: Likewise. 2000-11-13 Kevin Ryde * mpn/Makeasm.am: New file, splitting out assembler rules. * mpn/Makefile.am, tune/Makefile.am: Use it. * mpn/Makefile.am (@CPP@): Remove this, automake already gives it. * configure.in (AC_CHECK_LIBM): New test, and AC_SUBST it. * Makefile.am (MPFR_LIBADD_OPTION): Use it. * demos/Makefile.am (qcn_LDADD): Ditto. * tune/Makefile.am (libspeed_la_LIBADD): Ditto. * tests/rand/Makefile.am (libstat_la_LIBADD): Ditto. * tune/time.c (timeval_diff_secs): Better calculation. (read_real_time): New measuring method for AIX power/powerpc. (speed_endtime): Protect against negative times. * tune/common.c (speed_measure): Protect against big reps. * tune/freq.c (speed_cpu_frequency_measure_one): Better timeval diff. * tune/speed.h (TIMEVAL_DIFF_SEC,USEC): Remove macros. * configure.in: (sys/systemcfg.h, read_real_time): New tests. 2000-11-13 Torbjorn Granlund * mpz/tests/t-mul.c: Remove #include urandom.h. * mpz/tests/t-tdiv.c: Likewise. * configure.in [SPEED_CYCLECOUNTER_OBJS switch]: Declare hppa.asm as just 32 bits (cyclecounter_size=1). 2000-11-12 Torbjorn Granlund * mpz/tests/t-mul.c (main): Generate random numbers using gmp_rand* functions. (main): Distribute random numbers non-uniformly. (main): Seed by current time if GMP_CHECK_RANDOMIZE is set. (_mpn_mul_classic): Streamline. * mpz/tests/t-tdiv.c: Analogous changes. * demos/pexpr.c (HAVE_sigaltstack): Fix typo in testing for _UNICOS. Also test for __hpux. 2000-11-11 Torbjorn Granlund * mpn/alpha/ev5/gmp-mparam.h: Retune. * mpn/alpha/ev6/gmp-mparam.h: Retune. * mpn/alpha/ev6/add_n.asm: Misc cleanups. * mpn/alpha/ev6/sub_n.asm: New file. 2000-11-10 Torbjorn Granlund * configure.in [path switch] (alphaev6*-*-*): Add alpha/ev5 to path. * mpn/alpha/ev6/add_n.asm: New file. 2000-11-10 Kevin Ryde * mpz/powm.c (redc): Make global under WANT_REDC_GLOBAL. * tune/powm_mod.c, tune/powm_redc.c: New files. * tune/Makefile.am (libspeed_la_SOURCES): Add them. * tune/*: Add measuring of redc, mpz_mod, mpz_powm_mod, mpz_powm_redc. * tune/tuneup.c (POWM_THRESHOLD): Determine from redc and mpz_mod. * tune/Makefile.am (TUNE_MPZ_SRCS): Remove powm. 2000-11-10 Torbjorn Granlund * mpn/mips3/gmp-mparam.h: Retune. * configure.in (os_64bit): Rename to check_64bit_compiler. 2000-11-09 Torbjorn Granlund * configure.in [SPEED_CYCLECOUNTER_OBJS switch]: Choose hppa/hppa2 code depending on $CC64. 2000-11-09 Kevin Ryde * mpn/x86/pentium/mul_1.asm: Unroll 2x, saving 1 c/l when in L1. Add 1c entrypoint. * mpn/x86/pentium/aorsmul_1.asm: Add 1c entrypoints, shave a couple of cycles at entry and exit. * configure.in (power1,2,2sc): Support these as synonyms for plain power. * acinclude.m4 (GMP_ASM_X86_SHLDL_CL): GMP_DEFINE WANT_SHLDL_CL here. (GMP_ASM_X86_MMX, GMP_ASM_X86_SHLDL_CL): Add X86 into the names. * configure.in: Consequent changes. * gmp.texi (Notes for Particular Systems): Remarks about power/powerpc. (Reentrancy): Remarks about simultaneous writing. (Reporting Bugs): Ask for configfsf.guess. 2000-11-08 Kevin Ryde * acinclude.m4 (GMP_FUNC_ALLOCA): New macro. * configure.in: Use it. * gmp-impl.h (alloca): Conditionals and setups as per autoconf (should make alloca available on more non-gcc compilers). * acinclude.m4: Misc reformatting, simplify some quoting. (GMP_ASM_UNDERSCORE, GMP_ASM_X86_MCOUNT): Use $CC $CFLAGS $CPPFLAGS. (GMP_ASM_UNDERSCORE, GMP_ASM_ALIGN_FILL_0x90, GMP_ASM_RODATA): Put AC_REQUIREs outside AC_CACHE_CHECK. (GMP_C_SIZES): Use $srcdir/gmp.h, not -I; use $CPPFLAGS. (GMP_ASM_UNDERSCORE): Use "gmp_compile" variable, and only rm conftes1* conftes2*. (GMP_PROG_NM): New macro, require it in appropriate GMP_ASM_*. (GMP_TRY_ASSEMBLE): New macro, use it in various GMP_ASM_*. * configure.in: Use GMP_PROG_NM. * mpn/tests/spinner.c (spinner_signal): Use RETSIGTYPE. (spinner_init): Force output to unbuffered. * mpn/x86/README.family: Notes about GOT table and imul, misc updates. * mpn/x86/k7/diveby3.asm: Change to 3 operands for immediate imul. * mpn/x86/k6/diveby3.asm: Ditto. 2000-11-06 Torbjorn Granlund * urandom.h: Simplify and make it work properly for 64-bit machines also in environments without `random'. 2000-11-04 Torbjorn Granlund * configure.in [path switch]: Don't match rs6000-*-*, in particular don't assume POWER. * tune/tuneup.c (fft): Remove usleep calls. * config.guess: Don't pass "$@" when it is known to be empty. * Makefile.am (EXTRA_DIST): List configfsf.guess and configfsf.sub. 2000-11-04 Kevin Ryde * configfsf.guess, configfsf.sub: Moved from config.guess and config.sub. * config.guess, config.sub: New files, wrappers around around configfsf versions. * configfsf.guess: Update to FSF 2000-10-23. * configfsf.sub: Update to FSF 2000-10-25. * acinclude.m4 (GMP_ASM_POWERPC_R_REGISTERS): New macro. * mpn/powerpc32/powerpc-defs.m4: New file, regmap.m4 r0 etc macros conditionalized by GMP_ASM_POWERPC_R_REGISTERS. * mpn/powerpc32/regmap.m4: Remove file. * configure.in (powerpc*-*-*): Use all this. * mpz/divegcd.c: New file, providing mpz_divexact_gcd. * Makefile.am, mpz/Makefile.am: Add it. * gmp-impl.h (mpz_divexact_gcd): Add prototype. * mpq/aors.c,canonicalize.c,div.c,mul.c: Use it. * longlong.h [pentium] (count_leading_zeros): New macro. (__clz_tab): Always provide prototype. * acconfig.h (HAVE_TARGET_CPU_): Add x86s. * tune/speed.[ch],common.c (count_leading_zeros, count_trailing_zeros, __udiv_qrnnd_c): Add measuring. * configure.in (X86_PATTERN): Move from here ... * acinclude.m4 (X86_PATTERN): ... to here. (GMP_ASM_RODATA): Use it. * configure.in (srandom): New test. * mpn/tests/try.c: Use it. * tune/speed.c: Ditto, and conditionalize getrusage and headers. 2000-11-02 Kevin Ryde * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Add udiv_qrnnd.c and udiv_w_sdiv.c. * mpn/generic/mul_n.c (mpn_kara_sqr_n): Remove a duplicate subtract at the evaluate stage. 2000-11-01 Torbjorn Granlund * configure.in [compiler switch] (sparc64-*-linux*): Spell gmp_xoptcflags_gcc properly, and pass same options as for other sparcv9 configs. * tune/speed.h (SPEED_ROUTINE_MPN_GET_STR): Fix type of wsize. 2000-10-31 Torbjorn Granlund * configure.in [compiler switch] (sparc64-*-linux*): Remove -mvis from gmp_xoptflags_gcc, this might not be an ultrasparc. Remove -m32 from gmp_cflags_gcc; add -Wa,-xarch=v8plus. 2000-10-29 Torbjorn Granlund * mpn/ia64/lorrshift.asm: New file. * configure.in: New mulfunc `lorrshift' for lshift and rshift. 2000-10-29 Kevin Ryde * mpn/generic/mul_n.c (mpn_kara_sqr_n): Delete code performing superfluous mpn_sub_n calls. * configure.in (found_asm, M4): Account for SPEED_CYCLECOUNTER_OBJ, for the benefit of targets whose only .asm is a cycle counter. * tune/tuneup.c (fft): Remove bogus usleep calls. 2000-10-28 Torbjorn Granlund * mpn/ia64/invert_limb.asm: Get return value for 0x800...00 right. * tune/Makefile.am (EXTRA_DIST): Add ia64.asm. * tune/ia64.asm: Fix typo. * add_n.asm addmul_1.asm mul_1.asm popcount.asm sub_n.asm: Preserve ar.lc as required by ABI. * longlong.h (ia64 udiv_qrnnd): New. * configure.in [path switch] (ia64*-*-*): Set extra_functions. * mpn/ia64/invert_limb.asm: New file. 2000-10-27 Torbjorn Granlund * configure.in [compiler switch]: Get rid of c89 for all hppa flavours--it is an evil compiler! * tune/speed.h (SPEED_ROUTINE_MPN_SET_STR): Fix type of xp. (SPEED_ROUTINE_MPN_GET_STR): Fix type of wp. 2000-10-27 Kevin Ryde * gmp.texi (Fibonacci Number Algorithm): New section. * mpz/tests/t-fib_ui.c: New file. * mpz/tests/Makefile.am (check_PROGRAMS): Add it. * mpz/fib_ui.c: Rewrite, same formulas but using mpn functions and some lookup tables, much faster at small to moderate sizes. * gmp-impl.h (MPZ_FIB_SIZE): New macro. (FIB_THRESHOLD): Establish default here. * tune/tuneup.c (FIB_THRESHOLD): Start search after the new table data. * mpn/x86/x86-defs.m4 (mcount_movl_GOT_ebx): Rename from movl_GOT_ebx, and don't use GSYM_PREFIX with _GLOBAL_OFFSET_TABLE_. * tune/freq.c (speed_cpu_frequency_measure): New test comparing gettimeofday and speed_cyclecounter, should cover many systems. 2000-10-27 Torbjorn Granlund * mpn/ia64/gmp-mparam.h: Retune. 2000-10-26 Torbjorn Granlund * longlong.h (ia64): Set UMUL_TIME and UDIV_TIME. * mpn/ia64/submul_1.c: Fix typo. 2000-10-25 Kevin Ryde * tune/freq.c (speed_cpu_frequency_sysctl): New test, supporting hw.model for BSD flavours. * configure.in (sysctl, sys/param.h): New tests. 2000-10-24 Torbjorn Granlund * tune/freq.c: Explicitly #include config.h before other include files. * mpz/tests/reuse.c (FAIL2): New #define. (main): Use FAIL2. Now this test properly returns non-zero exit status when it fails. * mpn/powerpc32/gmp-mparam.h: Retune. * mpn/powerpc64/gmp-mparam.h: Retune. 2000-10-24 Kevin Ryde * mpn/x86/k6/cross.pl: Support 8 and 16 byte code alignment. * mpq/aors.c, mpq/canonicalize.c: Skip two mpz_divexact calls if gcd gives 1, which should be 60% of the time. * gmp-impl.h (MPZ_EQUAL_1_P): New macro. * mpq/mul.c, mpq/div.c: Use it, and a new DIV_OR_SET. * tune/tuneup.c (xp_block, yp_block): Initialize these with random data. Fixes GCD_ACCEL and GCDEXT thresholds, and latest POWM. 2000-10-23 Torbjorn Granlund * configure.in [SPEED_CYCLECOUNTER_OBJS switch]: Add ia64 case. * mpn/ia64/gmp-mparam.h: Fill in some parameters. * mpn/ia64/submul_1.c: New file. * tune/ia64.asm: New file. * gmp-impl.h (union ieee_double_extract): Handle ia64. * mpn/mp_bases.c: Decrease chars_per_bit_exactly for entry 1 to work around buggy ia64-linux. * longlong.h (ia64 umul_ppmm): Update register flags to match new GCC. 2000-10-22 Torbjorn Granlund * mpn/alpha/ev6/gmp-mparam.h (DC_THRESHOLD): Update. * mpn/alpha/ev6/submul_1.asm: New file. 2000-10-22 Kevin Ryde * tune/gcd_bin.c: New file. * tune/gcd_finda_gen.c: New file. * tune/Makefile.am (libspeed_la_SOURCES): Add them. * tune/speed.[ch],common.c (mpn_gcd_binary, find_a): Add measuring. * * (__gmp_allocate_func etc): Rename from _mp_allocate_func etc. (__gmp_default_allocate etc): Rename from _mp_default_allocate etc. * gmp-impl.h (__GMP_REALLOCATE_FUNC_TYPE, __GMP_REALLOCATE_FUNC_LIMBS): New macros. * gmp-impl.h (DC_THRESHOLD): Establish default here, set to 3*KARA since that's the measured average. * mpn/generic/dc_divrem_n.c, mpn/generic/tdiv_qr.c (DC_THRESHOLD): Remove default. 2000-10-21 Torbjorn Granlund * mpn/Makefile.am (TARG_DIST): Add ia64. 2000-10-21 Kevin Ryde * *: Change BZ -> DC. * mpn/generic/dc_divrem_n.c: Renamed from bz_divrem_n.c. * doc/multiplication: Remove file, now in the manual. * doc/assembly_code: Ditto. * tune/README: Remove some parts now in the manual. * gmp.texi (@m etc): Add and use some new macros. (Integer Division - mpz_[cft]div_*): Merge descriptions, for brevity and to emphasise similarities. (Low-Level Functions - mpn_[lr]shift): Specify count as 1 to mp_bits_per_limb-1. (Algorithms): New chapter. (References): Add some papers. * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): Remove some unused variables. * mpn/generic/mul_fft.c (mpn_fft_best_k): Ditto. * tune/freq.c: New file, split from time.c. * tune/time.c: Rewrite, now more automated. * configure.in, tune/*: Consequent changes. 2000-10-20 Torbjorn Granlund * mpn/ia64/default.m4: New file. * configure.in [config.m4 switch] (ia64*-*-*): Use ia64/default.m4. * mpn/ia64/mul_1.asm: New file. * mpn/ia64/addmul_1.asm: New file. * mpn/ia64/add_n.asm: New file. * mpn/ia64/sub_n.asm: New file. * mpn/ia64/popcount.asm: New file. * mpn/ia64/README: New file. * mpn/alpha/cntlz.asm: Override `.set noat' from ASM_START. * configure.in (HAVE_TARGET_CPU_*): Support hppa1.0, hppa1.1, hppa2.0 by sed'ing the period into `_'. * acconfig.h: Add #undefs for hppa targets. * longlong.h (udiv_qrnnd): Fix typo in last change. * mpz/tstbit.c: Rewrite (partly to work around GCC 2.95.2 HPPA bug). * configure.in [path switch]: (hppa2.0*-*-*): For non-CC64 case, update path. * configure.in [compiler switch]: (hppa2.0w-*-*): Match with same regexp in both places. (hppa*-*-*): New case. (all hppa alternatives): Don't inherit default gmp_cflags_cc, gmp_cflags_c89. 2000-10-18 Torbjorn Granlund * configure.in (alpha*-*-*): Define gmp_xoptcflags_gcc like for alpha*-*-osf*. * longlong.h (x86 udiv_qrnnd): Change `d' => `dx' to avoid K&R C stringification. 2000-10-15 Kevin Ryde * doc/configuration: Updates. * demos/calc.y: Remove some comments. 2000-10-14 Kevin Ryde * gmp.texi (Parameter Conventions, Memory Management): New sections split from "Variable Conventions". (Efficiency, Debugging, Profiling): New sections in "GMP Basics". (Reentrancy): Some rewording, add note on standard I/O. (Build options): Add --enable-assert and --enable-profiling. * configure.in (--enable-profiling): New option. * acinclude.m4 (GMP_ASM_X86_MCOUNT): New macro, finding how to profile. * mpn/x86/x86-defs.m4 (PROLOGUE_cpu, call_mcount): Profiling support. * acinclude.m4, configure.in (GMP_ASM_*): Rename from GMP_CHECK_ASM_*, to follow autoconf conventions. * configure.in: Run GMP_CHECK_ASM tests only if needed. * acinclude.m4 (GMP_CHECK_ASM_MMX): Don't use GMP_CHECK_ASM_TEXT. * mpn/x86/x86-defs.m4 (ASSERT): Allow no condition, to just emit code. 2000-10-13 Kevin Ryde * mpq/md_2exp.c: New file. * mpq/Makefile.am (libmpq_la_SOURCES): Add it. * Makefile.am (MPQ_OBJECTS): Ditto. * gmp.h (mpq_mul_2exp, mpq_div_2exp): Add prototypes. * gmp.texi (Rational Arithmetic): Add documentation. * mpq/tests/t-md_2exp.c: New file. * mpq/tests/Makefile.am (check_PROGRAMS): Add it. * mpn/generic/perfsqr.c: Add/amend some comments. * gmp.texi (Known Build Problems): Note VERSION problem with old sed, do some minor rewording. (Build Options): Add cygwin and djgpp URLs, mention INSTALL.autoconf, mention HTML. (Getting the Latest Version of GMP): Move this ... (Introduction to GMP): ... to here. (Compatibility with older versions): Just refer to 2.x and 3.x, not every minor version. (Initializing Integers): Note restrictions on mpz_array_init'ed variables. (Integer Logic and Bit Fiddling): Note bits are numbered from 0. * INSTALL.autoconf: New file. * Makefile.am (EXTRA_DIST): Add it. * tune/Makefile.am, tune/tuneup.c, configure.in, gmp-impl.h: New scheme for recompiled objects used by tune program. Don't use libgmptune.a, make better use of libtool, work with ansi2knr. * tune/speed.h,common.c (SPEED_ROUTINE_MPZ_POWM): Use s->yp and s->xp_block, make exponent a fixed size. 2000-10-07 Torbjorn Granlund * mpn/mips3/gmp-mparam.h: Retune. * mpn/generic/mul_n.c (USE_MORE_MPN): Revert last change. 2000-10-06 Torbjorn Granlund * mpn/mips3/add_n.s: Decrease carry recurrence from 4 to 3 cycles. * mpn/mips3/sub_n.s: Likewise. 2000-10-04 Torbjorn Granlund * configure.in (sparc64-*-linux*): Set path according to CC64. 2000-10-04 Kevin Ryde * acinclude.m4 (GMP_CHECK_ASM_UNDERSCORE): Use LABEL_SUFFIX, not a hard-coded ":". * config.sub: Don't demand "86" in CPU name for SCO. * configure.in (supersparc-*-*): Remove -DSUPERSPARC. * longlong.h: Use HAVE_TARGET_CPU_supersparc. * configure.in (HAVE_TARGET_CPU_*): AC_DEFINE from $target_cpu. * acconfig.h: Add #undefs, but only for targets of interest. 2000-10-03 Torbjorn Granlund * mpn/alpha/cntlz.asm: Rewrite. * mp_clz_tab.c (__clz_tab): Half table size to 128 entires. * longlong.h (count_leading_zeros): Demand just 128 entries from __clz_tab. * configure.in (mips-sgi-irix6.*): Pass -mips3 in addition to options for n32 ABI. * longlong.h: Move NO_ASM test around all assembly code. From gcc: * longlong.h (count_leading_zeros): Sparclite scan instruction was being invoked incorrectly. Replace __mc68332__ with __mcpu32__. Add ARC support. 2000-10-02 Torbjorn Granlund * mpn/mips3/gmp-mparam.h: Retune for both gcc and cc. * mpn/generic/mul_n.c (USE_MORE_MPN): Remove exception for __mips. (interpolate3): Cast mp_limb_t variables to mp_limb_signed_t when testing sign bit. * mpn/alpha/ev6/gmp-mparam.h: Retune. * mpn/powerpc32/gmp-mparam.h: Retune. * mpn/powerpc64/gmp-mparam.h: Retune. * mpn/x86/pentium/gmp-mparam.h: Retune. * mpn/x86/pentium/mmx/gmp-mparam.h: Retune. * mpn/sparc32/v9/gmp-mparam.h: Retune. * mpn/x86/k6/gmp-mparam.h: Retune. * mpn/x86/p6/gmp-mparam.h: Retune. * mpn/x86/k7/gmp-mparam.h: Retune. * mpn/sparc64/gmp-mparam.h: Retune. * mpn/m68k/gmp-mparam.h: New file. * mpn/alpha/ev5/gmp-mparam.h: New file. * gmp-impl.h (default MPN_COPY): Remove final `;'. * tune/time.c (speed_endtime): Rewrite. * tune/speed.h (SPEED_ROUTINE_MPZ_POWM): Set base to a large value, not 2. * demos/pexpr.c (setup_error_handler): Fix typo. * mpz/powm.c (redc): New function, based on old mpz_redc. Don't multiply here. (mpz_redc): Remove. (mpz_powm): Major changes, partially reverting to mpn calls. Multiply before calling redc. (mpz_powm): Use TMP_ allocation. (mpz_powm): Refine calculation of k (width of exponent window). (mpz_powm): Cast constants to mp_limb_t before left shifting. * longlong.h: Use ia64 count_leading_zeros just when __GNUC__. 2000-09-29 Kevin Ryde * acinclude.m4 (GMP_C_SIZES): New macro. * configure.in: Use it. * acconfig.in (BYTES_PER_MP_LIMB etc): Add #undefs. * mpn/generic/gmp-mparam.h (BYTES_PER_MP_LIMB etc): Remove #defines. * gmp.texi (Known Build Problems): Remove 64-bit generic C gmp-mparam.h problem, now fixed. * configure.in: Only run GMP_PROG_M4 if it's actually needed. 2000-09-27 Torbjorn Granlund * demos/pexpr.c: Clean up code for systems not supporting sigaltstack. Handle old Linux without sigaltstack. Properly disable all stuff related to sigaltstack under Unicos. * mpn/alpha/ev6/addmul_1.asm: Use explicit offset for all load and store insns. Helps old gas. * longlong.h (count_leading_zeros): Define for ia64. 2000-09-27 Paul Zimmermann * mpn/generic/bz_divrem_n.c: Fix qhl handling, simplify. 2000-09-27 Kevin Ryde * mpn/Makefile.in (.SUFFIXES): Regenerate with patched automake to get .s before .c, which is needed to override ansi2knr .c rules. * gmp.texi (mpn_sqrtrem): Fix r2p==NULL return value description to match the code (change by Torbjorn). (mpn_gcd, mpn_gcdext, mpn_sqrtrem, mpn_tdiv_qr): Note most significant limbs must be non-zero. (mpn_gcd, mpn_gcdext, mpn_sqrtrem): Clarify destination size requirements. (mpn_gcd_1): Clarify value must be non-zero, not just size. * gmp-impl.h (mpn_zero_p): New inline function. * mpn/generic/inlines.c: Add gmp-impl.h. * mpf/integer.c, mpz/get_d.c, mpn/generic/mul_fft.c: Use it. * mpn/generic/gcd.c: Use MPN_COPY_INCR not MPN_COPY. * mpf/add_ui.c: Ditto. * mpf/add.c: Ditto, and fix test to skip copy. 2000-09-26 Kevin Ryde * gmp-impl.h, longlong.h, mpn/generic/*.c: Add ASSERTs for various parameter restrictions. * gmp-impl.h (UDIV_PREINV_TIME): New macro. * mpn/generic/sb_divrem_mn.c: Use it. * mpn/generic/perfsqr.c: Ditto. * mpn/x86/*/gmp-mparam.h (UDIV_PREINV_TIME): Add values. * macos/Makefile.in: Add mpz/tests/t-get_si.c, mpf/tests/t-set_f.c, and new multi-function mpz and mpq files. 2000-09-25 Kevin Ryde * randlc.c, randlc2x.c, randsd.c, mpz/urandomb.c, mpz/urandomm.c: Use mpz_ptr and mpz_srcptr for parameters. * gmp.h (gmp_randinit_lc, gmp_randinit_lc_2exp, gmp_randseed, mpz_urandomb, mpz_urandomm): Corresponding change to prototypes. * randsdui.c: Remove wrong K&R parameters part. 2000-09-12 Kevin Ryde * gmp-impl.h (mpn_tdiv_qr): Move prototype from here ... * gmp.h (mpn_tdiv_qr): ... to here. * gmp.texi (Miscellaneous Rational Functions): Comment-out and move version 1 compatibility note to "Compatibility" section. (Rational Number Functions): Ditto for canonicalization note. 2000-09-10 Kevin Ryde * mpn/x86/pentium/com_n.asm: New file. * gmp.texi (Rational Arithmetic): Add mpq_abs. (Miscellaneous Rational Functions): Merge and simplify descriptions of mpq_get_num, mpq_get_den, mpq_set_num, mpq_set_den. * mpq/abs.c: New file. * mpq/Makefile.am (libmpq_la_SOURCES): Add it. * Makefile.am (MPQ_OBJECTS): Add it. * gmp.h (mpq_abs): Add prototype. * mpq/set_den.c: Don't discard sign when copying, this makes the code match the manual. 2000-09-07 Torbjorn Granlund * tune/alpha.asm: Rewrite to actually work right. 2000-09-07 Kevin Ryde * tune/common.c,speed.[ch]: Add measuring of mpn_sqrtrem, mpn_get_str, mpn_set_str. * tune/README: Various updates. 2000-09-06 Torbjorn Granlund * mpz/fits.c: Correct type of `data'. 2000-09-06 Kevin Ryde * gmp.texi (Build Options): Clarify where to find CFLAGS. (Known Build Problems): Note SCO -lc problem. * tune/speed.h (SPEED_ROUTINE_MPN_GCD_CALL): Fix for sizes > 512 limbs. * doc/multiplication: Corrections and additions suggested by Paul. * tune/modlinv.c: New file with alternate modlimb_inverts. * tune/Makefile.am, tune/speed.[ch]: Add measuring of them. * tune/speed.c (FLAG_NODATA): New attribute, use for mpz_bin_uiui, mpz_fib_ui, mpz_fac_ui. * mpn/x86/t-zdisp.sh: New file. * tests/t-modlinv.c: New file. * tests/Makefile.am (check_PROGRAMS): Add it. * mpq/tests/t-set_f.c: New file. * mpq/tests/Makefile.am (check_PROGRAMS): Add it. * gmp-impl.h (MPQ_CHECK_FORMAT): New macro. * mpq/tests/t-get_d.c: Use it. * mpq/set_f.c: New file. * mpq/Makefile.am (libmpq_la_SOURCES): Add it. * Makefile.am (MPQ_OBJECTS): Ditto. * gmp.h: Add prototype. * gmp.texi (Miscellaneous Rational Functions): Document mpq_set_f, correct return type of mpq_set_d. 2000-09-03 Kevin Ryde * mpz/aors_ui.c: New file merging add_ui.c and sub_ui.c, no object code changes. * mpz/add_ui.c, mpz/sub_ui.c: Remove files. * mpz/Makefile.am: Update. * gmp-impl.h (MPZ_FITS_STYPE_SDT, MPZ_FITS_UTYPE_SDT): New macros. * mpz/fits.c: New file merging six separate fits*.c. * mpz/fits_sshort_p.c, fits_sint_p.c, fits_slong_p.c, fits_ushort_p.c, fits_uint_p.c, fits_ulong_p.c: Remove files * mpz/Makefile.am: Use new fits.c, change object names from fits_*_p.lo to fits_*.lo to avoid SunOS 4 native "ar" warnings. * Makefile.am (MPZ_OBJECTS): Change from fits_*_p.lo to fits_*.lo. * acinclude.m4 (GMP_CHECK_ASM_RODATA): New macro, defining RODATA. * configure.in: Use it. * mpn/x86/k[67]/mmx/popham.asm: Use it. * mpn/x86/*/*.asm: Use "TEXT" not ".text". 2000-09-02 Kevin Ryde * mpq/aors.c: New file merging add.c and sub.c, no object code changes. * mpq/add.c, mpq/sub.c: Remove files. * mpq/Makefile.am: Update. * mpz/aors.c: New file merging add.c and sub.c, no object code changes. * mpz/add.c, mpz/sub.c: Remove files. * mpz/Makefile.am, mpbsd/Makefile.am: Update. * configure.in: Re-apply "PROLOGUE.*" regexp change for the benefit of alpha PROLOGUE_GP, lost in path search reorganisation. * mpn/x86/x86-defs.m4 (jadcl0, cmov_simulate, ASSERT, movl_text_address): Don't use "1:" style labels. (Zdisp): Rearrange a bit, switch to all hex. * mpn/x86/README.family: Note SCO "as" doesn't support "1:" style local labels, misc rewordings. 2000-08-29 Torbjorn Granlund * demos/primes.c: Include string.h. * config.guess (x86 variant recog code): Remove dummy*.o files generated by some compilers. 2000-08-28 Kevin Ryde * acinclude.m4 (GMP_CHECK_ASM_ALIGN_FILL_0x90): Fix Solaris 2.8 warning message suppression, add notes about SCO. * Makefile.am (MPZ_OBJECTS etc): Move some comments. 2000-08-25 Kevin Ryde * mpz/pprime_p.c (mpz_millerrabin): Fix a TMP_FREE. * gmp.texi (Copying): Refer to Lesser not Library GPL. (GMP and Reentrancy): Note stack-alloc.c is not reentrant, and that SCO is potentially not reentrant. * acinclude.m4 (GMP_CHECK_ASM_UNDERSCORE): Test by attempting to link with or without an underscore. * gmp.texi (Known Build Problems): Remove SunOS 4 native grep GSYM_PREFIX problem, now fixed. * gmp-impl.h (MODLIMB_INVERSE_3): New constant. * mpn/generic/diveby3.c: Use it instead of own INVERSE_3. * mpn/generic/mul_n.c: Ditto. * tests/t-constants.c: Check it, and PP_INVERTED too. * acinclude.m4 (GMP_GCC_MARCH_PENTIUMPRO): New macro. * configure.in [p6 and athlon] (gmp_optcflags_gcc): Use it to possibly add -march=pentiumpro. * gmp-impl.h (MPZ_SET_STR_OR_ABORT, MPF_SET_STR_OR_ABORT): New macros. * mpz/tests/t-bin.c, mpz/tests/t-get_si.c, mpz/tests/t-jac.c, mpz/tests/t-misc.c: Use them. * mpf/tests/t-conv.c, mpf/tests/t-misc.c: Ditto. * mpz/tests/convert.c: Ditto and amend diagnostics slightly. * mpz/tests/t-misc.c (check_mpz_set_si): Remove a superfluous init. * mpz/tests/io.c: Differentiate between I/O and data conversion errors. * mpn/generic/aors_n.c: New file merging add_n and sub_n, no object code changes. * mpn/generic/add_n.c: Remove file. * mpn/generic/sub_n.c: Remove file. * mpn/generic/aorsmul_1.c: New file merging addmul_1 and submul_1, no object code changes. * mpn/generic/addmul_1.c: Remove file. * mpn/generic/submul_1.c: Remove file. * mpn/generic/popham.c: New file merging popcount and hamdist, no object code changes. * mpn/generic/popcount.c: Remove file. * mpn/generic/hamdist.c: Remove file. 2000-08-24 Torbjorn Granlund * gmp-impl.h (mpn_com_n): Fix typo. 2000-08-23 Torbjorn Granlund * demos/primes.c (main): Don't call mpz_probab_prime_p for numbers that are known to be prime after sieving. (main): Declare and initialize max_s_prime_squared. (MAX_S_PRIME): Increase. (ST_SIZE): Increase. 2000-08-23 Kevin Ryde * gmp-impl.h (ASSERT_ALWAYS): Change to statement style. (JACOBI_TWO_U_BIT1): Remove ASSERT. (MPZ_CHECK_FORMAT): Use ASSERT_ALWAYS as a statement. 2000-08-21 Torbjorn Granlund * gmp-impl.h (ASSERT): Use do..while for dummy version. * mpf/get_str.c: Don't set n_digits from digits_computed_so_far when the converted operand becomes zero. Misc cleanups. 2000-08-21 Kevin Ryde * mpz/fdiv_r_2exp.c, mpz/lcm.c, mpz/urandomm.c: Add missing TMP_MARK/FREE, avoiding memory leak when using stack-alloc.c. 2000-08-20 Kevin Ryde * mpz/set.c [BERKELEY_MP] (move): Add conditionals to build as "move" for libmp. * mpbsd/Makefile.am: Use mpz/set.c, not move.c. * Makefile.am (MPBSD_OBJECTS): Corresponding change. * mpbsd/move.c: Remove file. * mpn/Makefile.am, mpz/Makefile.am, mpq/Makefile.am, mpf/Makefile.am, mpbsd/Makefile.am (-DOPERATION_foo): Use "foo" even for ansi2knr "foo_" objects. Do this with the makefiles to keep the sources cleaner. * mpz/mul_siui.c, mpf/integer.c: Revert to plain OPERATION_* forms. * mpn/lisp/gmpasm-mode.el (gmpasm-remove-from-list): Renamed from gmpasm-delete-from-list, because it's non-destructive. (gmpasm-font-lock-keywords): Add some more keywords. 2000-08-16 Kevin Ryde * tune/mul_n_mpn.c, tune/mul_n_open.c: New files, being forced open-coded and mpn #includes of mpn/generic/mul_n.c. * tune/*: Add measuring of them. * tune/speed.c: Print command line into *.gnuplot file. * mpn/generic/mul_n.c (USE_MORE_MPN): Change to #if not #ifdef for using the value, add #ifndef for providing the default. * mpn/sparc64/gmp-mparam.h (USE_MORE_MPN): Add #ifndef. * tests/t-constants.c: New file. * tests/Makefile.am (check_PROGRAMS): Add it. * mpz/get_si.c: Use LONG_MAX, not BITS_PER_MP_LIMB, so the result doesn't depend on limb size when outside the range of a long (though such results are not actually documented). * mpz/tests/t-get_si.c: New file. * mpz/tests/Makefile.am (check_PROGRAMS): Add it. * mpn/tests/try.c (call): Cast popcount and hamdist calls, for the benefit of long long limb. 2000-08-15 Kevin Ryde * mp.h (mp_set_memory_functions): Add missing #define. * mpbsd/tests/allfuns.c (mp_set_memory_functions): Verify its existence. * mpf/tests/t-misc.c (check_mpf_getset_prec): New test, verifying reverted behaviour of mpf_get_prec. * mpn/tests/ref.c (refmpn_strip_twos): Use refmpn_copyi, not MPN_COPY_INCR. * mpz/mul_siui.c, mpf/integer.c: Recognise OPERATION_*_ forms produced under ansi2knr. * configure.in (mpn_objects, mpn_objs_in_libgmp): Add $U to .c objects when ansi2knr in use. * mpn/Makefile.am (AUTOMAKE_OPTIONS): Enable ansi2knr. (libdummy.la): Add this, not built, to create ansi2knr style rules for all potential .c files. * mpz/Makefile.am, mpq/Makefile.am, mpf/Makefile.am, mpfr/Makefile.am, mpbsd/Makefile.am, mpq/tests/Makefile.am, tests/Makefile.am (AUTOMAKE_OPTIONS): Enable ansi2knr (now everywhere). * Makefile.am (MPZ_OBJECTS, MPQ_OBJECTS, MPF_OBJECTS, MPFR_OBJECTS, MPBSD_OBJECTS, libmp_la_DEPENDENCIES): Add $U to all .lo filenames. 2000-08-03 Torbjorn Granlund * mpn/alpha/ev6/addmul_1.asm: Correct number of cycles to 3.5/28. 2000-08-02 Torbjorn Granlund * Version 3.1 released. * gmp.texi: Rephrase mpf_urandomb documentation. * mpn/alpha/ev6: New directory with ev6/21264 optimized code. * mpn/alpha/ev6/addmul_1.asm: New file. * mpn/alpha/ev6/gmp-mparam.h: New file. 2000-08-02 Kevin Ryde * demos/factorize.c (random): Don't use "inline". * mpfr/log.c, mpfr/mul_ui.c, mpfr/round.c, mpfr/set.c, mpfr/set_d.c: Corrections to K&R parts. * Makefile.am (EXTRA_HEADERS): Omit $(MPFR_HEADERS_OPTION). * mpfr/Makefile.am (EXTRA_DIST): Add mpfr.h. * gmp.texi (Known Build Problems): Note problem stripping libgmp.a. 2000-08-02 Kent Boortz * mpfr: Integrated experimental version of mpfr-0.4. * configure.in: Changes for option --enable-mpfr. * Makefile.am: Changes for option --enable-mpfr. 2000-08-01 Torbjorn Granlund * mpn/generic/popcount.c: Disable SPARC v9 popc_limb pattern. * mpn/generic/hamdist.c: Likewise. 2000-08-01 Kevin Ryde * mpn/tests/try.c (try_init): Account for ALIGNMENTS when sizing source and dest regions. 2000-07-31 Torbjorn Granlund * mpf/get_str.c: Develop three extra digits, not just one. 2000-07-31 Kevin Ryde * gmp.texi (References): Add URL for invariant division. 2000-07-30 Kevin Ryde * tune/time.c (speed_cpu_frequency_proc_cpuinfo): Add support for alpha linux "cycle frequency". * mpn/sparc64/gmp-mparam.h: Re-run tune program for FFT thresholds. 2000-07-29 Kevin Ryde * gmp.texi (ABI and ISA): Add sparc64-*-linux*. * configure.in [sparc64-*-linux*] (gmp_cflags64_gcc): Same flags as under solaris. * configure.in (--enable-fft): New option, default "no". * gmp.texi (Build Options): Describe it. * mpn/generic/mul.c, mpn/generic/mul_n.c [WANT_FFT]: Use it. * tune/tuneup.c [WANT_FFT]: By default don't probe FFTs if not enabled. * NEWS: Multiplication optionally using FFT. * tune/README: Notes on FFT and GCD thresholds, other minor updates. * Makefile.am: Expunge the macos generated files update stuff. 2000-07-28 Kevin Ryde * mpn/x86/*/gmp-mparam.h: Add some FFT thresholds. 2000-07-28 Kent Boortz * macos/Asm*, macos/CmnObj, macos/Mp*: Delete directories. * macos/Makefile: Delete file. * macos/Makefile.cw: Delete file. * macos/config.h: Delete file. * macos/Asm/*.s: Delete files. * macos/configure: Create target directories. Don't transform '(C)' to '(;)' in a 'dnl' line comment in .asm file. * Makefile.am: Delete macos targets. * macos/README: Reflect that we reverted back to a build process that require ""macos/configure" to run on MacOS. This imply that MacPerl is needed for a build in MacOS. 2000-07-27 Kevin Ryde * mpn/generic/mul_fft.c: New file, by Paul Zimmermann, minor mods applied. * configure.in (gmp_mpn_functions): Add it. * mpn/generic/mul.c, mpn/generic/mul_n.c: Use it. * doc/multiplication: Describe it (briefly). * gmp-impl.h (FFT_MUL_THRESHOLD etc): New thresholds. (mpn_fft_best_k, mpn_fft_next_size, mpn_mul_fft, mpn_mul_fft_full): New functions. (numberof, TMP_ALLOC_TYPE etc, _MP_ALLOCATE_FUNC_TYPE etc, UNSIGNED_TYPE_MAX etc): New macros. * tune/*: Add FFT threshold tuning and speed measuring. * tune/common.c: Avoid huge macro expansions for umul and udiv. * mpz/tests/t-bin.c, mpz/tests/t-jac.c, mpz/tests/t-misc.c, mpbsd/tests/t-misc.c, mpf/tests/t-misc.c, mpn/tests/try.c, mpn/tests/spinner.c: Use new gmp-impl.h macros. * demos/Makefile.am (BUILT_SOURCES): Don't need calc.c etc under this. 2000-07-27 Torbjorn Granlund * mpn/ia64/gmp-mparam.h: New file. 2000-07-26 Torbjorn Granlund * demos/isprime.c: Handle any number of arguments and print classification for each. Add `-q' option for old behaviour. 2000-07-26 Kevin Ryde * gmp.texi (Build Options): Mention djgpp stack size. (Notes for Package Builds): New section. (Compatibility with older versions): Update for 3.1, add mpf_get_prec. * demos/factorize.c [__GLIBC__]: Don't declare random() under glibc. * gmp.h (gmp_version): Add prototype and define. * Makefile.am: Keep macos directory generated files up-to-date during development and on a "make dist". 2000-07-25 Torbjorn Granlund * mpn/hppa/gmp-mparam.h: Update threshold values from new `tune' run. * mpn/pa64/gmp-mparam.h: Fill in values from `make tune' run. * mpn/pa64w/gmp-mparam.h: Likewise. * mpn/mips3/gmp-mparam.h: Likewise. * tune/hppa2.asm: Fix typo in .level directive. * configure.in: Add sparc64-*-linux* support (from Jakub Jelinek). * configure: Regenerate. * mpn/sparc64/rshift.asm: Use %g5 instead of volatile stack frame area for return value (from Jakub Jelinek). * mpn/sparc64/lshift.asm: Likewise. * mpf/get_prc.c: Revert Aug 8, 1996 change. * version.c: No longer static. * mpn/pa64/gmp-mparam.h: Only #define *_THRESHOLD if not already defined. * mpn/pa64w/gmp-mparam.h: Likewise. * mpn/arm/gmp-mparam.h: Likewise. * mpn/mips3/gmp-mparam.h: Likewise. 2000-07-25 Kevin Ryde * INSTALL: It's "info -f ./gmp.info" to be sure of hitting the gmp.info in the current directory. * Makefile.am (libmp_la_DEPENDENCIES): Add mpz/cmp.lo, for last mpz/powm.c fix. * mpn/sparc64/addmul1h.asm, mpn/sparc64/submul1h.asm: Renamed from addmul_1h.asm, submul_1h.asm to avoid name conflicts on an 8.3 filesystem. * mpn/sparc64/addmul_1.asm, mpn/sparc64/submul_1.asm, mpn/sparc64/mul_1.asm: Update include_mpn()s. 2000-07-24 Torbjorn Granlund * Update header of all files previously under the Library GPL to instead be under the Lesser GPL. * COPYING.LIB: Now Lesser GPL. * demos/primes.c: Change license to GPL (was Library GPL). * demos/isprime.c: Change license to GPL (was Library GPL). * gmp.h (error code enum): Add GMP_ERROR_BAD_STRING (currently unused). * mpz/tests/t-mul.c: Default SIZE to a function of TOOM3_MUL_THRESHOLD. Improve error messages. Decrease reps. 2000-07-22 Kevin Ryde * tune/speed.h: Decrease the amount of data used for gcd and powm measuring, to make the tune go a bit faster. 2000-07-21 Kent Boortz * macos/Asm*, macos/CmnObj, macos/Mp*: Directories no longer created from configure script, now part of dist. * macos/Makefile * macos/Makefile.cw * macos/config.h * macos/Asm/*.s New files and directories that is the output from configure. This way no Perl installation is required to build on MacOS, just MPW. * macos/configure: Added prefix '__g' to exported assembler labels. Changed to handle new m4 syntax instead of the old cpp syntax in asm. * macos/Makefile.in: Corrected 'clean' target, added 'distclean' and 'maintainer_clean'. Added "mpn/mp_bases.c" to build. * macos/README: Reflect the new build process without configure. Corrected the file structure for Apple MPW installation. 2000-07-21 Torbjorn Granlund * mpf/tests/t-muldiv.c: Relax error limit. Make precision depend on SIZE. Misc changes. * configure: Regenerate. 2000-07-20 Kent Boortz * macos/Makefile.in: Removed hard coded targets, added special targets found in Makefile.am files. * macos/configure: Generate targets from top configure script and Makefile.am files. Made script runnable from Unix for testing. * macos/README: Notes about search paths for includes, contributed by Marco Bambini. * configure.in: Added comment about lines that the "macos/configure" script depend on. 2000-07-20 Torbjorn Granlund * mpz/powm.c (mpz_powm): After final mpz_redc call, subtract `mod' from result if it is greater than `mod'. 2000-07-19 Torbjorn Granlund * mpn/hppa/gmp-mparam.h: Fill in values from `make tune' run. * mpn/alpha/gmp-mparam.h: Likewise. * mpn/powerpc32/gmp-mparam.h: Likewise. * tune/hppa.asm: New file. * tune/hppa2.asm: New file. * configure.in (SPEED_CYCLECOUNTER_OBJS): Set for hppa2*-*-* and hppa*-*-*. * tune/Makefile.am (EXTRA_DIST): Add hppa.asm and hppa2.asm. * tune/speed.h (SPEED_ROUTINE_MPN_BZ_DIVREM_CALL): Declare `marker'; invoke TMP_FREE. * mpn/hppa/hppa1_1/udiv_qrnnd.S: Use "%" instead of "'" for reloc/symbol delimiter. 2000-07-16 Torbjorn Granlund * mpn/powerpc64/gmp-mparam.h: Update with output from tune utility. * mpn/powerpc64/copyi.asm: New file. * mpn/powerpc64/copyd.asm: New file. 2000-07-16 Kevin Ryde * tune/*: Add measuring for umul_ppmm and udiv_qrnnd. 2000-07-14 Kevin Ryde * mpn/x86/k6/k62mmx: New directory. * configure.in (k6[23]*-*-*): Use it. * mpn/x86/k6/k62mmx/copyi.asm, mpn/x86/k6/k62mmx/copyd.asm: Move from mmx directory, improve code alignment a bit. * mpn/x86/k6/k62mmx/lshift.asm, mpn/x86/k6/k62mmx/rshift.asm: Ditto, and improve addressing modes for pre-CXT cores. * mpn/x86/x86-defs.m4 (Zdisp): Add an instruction. * mpn/x86/k6/mmx/lshift.asm, mpn/x86/k6/mmx/rshift.asm: New files, suiting plain K6. * mpn/x86/README, mpn/x86/k6/README: Updates. * mpn/x86/k6/mmx/*.asm: Update some comments. * mpn/tests/Makefile.am: Use $(MAKE) in .asm rules, not "m". * tune/Makefile.am: Use $(EXEEXT) and libtool --config objdir, for the benefit of djgpp. * */Makefile.in: Regenerate with patched automake that adds $(EXEEXT) to EXTRA_PROGRAMS. * mpn/tests/try.c: Add #ifdef to SIGBUS, for the benefit of djgpp. * config.guess: Recognise pc:*:*:* as an x86, for djgpp. * configure: Regenerate with patched autoconf to fix temp file ".hdr" which is invalid on a DOS 8.3 filesystem, and to fix two sed substitutes that clobbered a ":" in $srcdir (eg. a DOS drive spec). * mpz/tests/io.c: Use one fp opened "w+", since separately opened input and output doesn't work on MS-DOS 6.21. * tests/rand/Makefile.am (allprogs): Pseudo-target to build everything. (CLEANFILES): Add EXTRA_PROGRAMS and EXTRA_LTLIBRARIES. (manual-test, manual-bigtest): Add $(EXEEXT) to dependencies. * tests/rand/*/Makefile.in: Regenerate with patched automake that adds $(EXEEXT) to EXTRA_PROGRAMS. 2000-07-13 Torbjorn Granlund * mpz/tests/t-root.c: Also test mpz_perfect_power_p. Generate `nth' so that there will be fewer trivial values. * mpz/root.c: Reverse return value in tests for detecting root of +1 and -1. * mpz/perfpow.c: Use TMP_ALLOC interface. 2000-07-12 Torbjorn Granlund * mpz/perfpow.c (primes): Make it const. 2000-07-06 Kevin Ryde * mpn/x86/k6/cross.pl: New file. * mpn/x86/*/gmp-mparam.h: Updates to thresholds, conditionalize all _TIME defines. * mpn/x86/pentium/mmx/gmp-mparam.h: New file. * mpn/sparc64/gmp-mparam.h: Update thresholds. * mpn/sparc32/v9/gmp-mparam.h: Ditto. 2000-07-04 Kevin Ryde * NEWS: Updates. * mpn/x86/*/README: Miscellaneous updates. * tune/speed-ext.c: New file. * tune/Makefile.am: Add it. * tune/README: Updates. * tune/speed.h (SPEED_ROUTINE_MPN_DIVREM_2): Bug fixes. * demos/calc.y,calclex.l: New files. * demos/calc.c,calc.h,calclex.c: New files, generated from .y and .l. * demos/Makefile.am: Add them. * gmp.h (mpq_swap, mpf_swap): Add prototypes and defines. 2000-07-01 Kevin Ryde * gmp.texi (ABI and ISA): New section, bringing together ABI notes. (Build Options): Add MPN_PATH, various updates. (Build Options): Add note on setting CFLAGS when setting CC. (Notes for Particular Systems): Add -march=pentiumpro problem. (Known Build Problems): Note on gmp-mparam.h for 64-bit generic C. (GMP Variable Conventions): Add some info on user defined functions. (Reporting Bugs): Minor rewording. * configure.in (MPN_PATH): Renamed from mpn_path. * gmp-impl.h (ULONG_MAX,ULONG_HIGHBIT,...,SHORT_MAX): New defines. * mp[zf]/tests/t-misc.c: Use them. * mpbsd/tests/t-misc.c: New file. * mpbsd/tests/Makefile.am: Add it. * Makefile.am (LIBGMP_LT_*, LIBMP_LT_*): Bump version info. * gmp.h (__GNU_MP_VERSION_*): Bump to 3.1. * mpf/tests/Makefile.am (AUTOMAKE_OPTIONS): Add ansi2knr. * Makefile.am (libmp_la_SOURCES): Add mp_set_fns.c, accidentally omitted in gmp 3.0.x. * gmp.texi (Custom Allocation): Note this is available in mpbsd, and some minor rewording. 2000-06-30 Torbjorn Granlund * demos/factorize.c (random): New function, defined conditionally. (factor_using_pollard_rho): Use it, not mrand48. * mpn/cray/README: New file. 2000-06-30 Kevin Ryde * mpn/x86/pentium/aorsmul_1.asm: Add MULFUNC_PROLOGUE. * mpz/tests/t-jac.c: Test limbs on mpn_jacobi_base, not just ulongs. * gmp-impl.h, mpn/tests/try.c, mpn/tests/spinner.c, tune/speed.c: Use config.h unconditionally, not under HAVE_CONFIG_H. * demos/pexpr.c [__DJGPP__]: Patch by Richard Dawe to not use setup_error_handler on djgpp. * tune/*: Locate data to help direct-mapped caches, add measuring of mpz_init/clear, mpz_add and mpz_bin_uiui, various cleanups. * configure.in (AC_CHECK_FUNCS): Add popen. 2000-06-29 Torbjorn Granlund * mpf/mul_2exp.c: Streamline criterion for whether to use mpn_lshift or mpn_rshift. Increase precision when exp is a multiple of BITS_PER_MP_LIMB primarily to make exp==0 be a noop. * mpf/div_2exp.c: Analogous changes. * mpf/tests/t-dm2exp.c: Set u randomly in loop. Perform more mpf_mul_2exp testing. * configure.in: Recognize cray vector processors with a broad `*'; move after alpha* not to match that. 2000-06-28 Kevin Ryde * mpz/tests/io.c: Use a disk file, not a pipe, switch to ansi2knr style, switch from MP_INT to mpz_t, add a couple of error checks. * mpz/tests/Makefile.am (CLEANFILES): Add io.tmp, in case io.c fails. 2000-06-27 Torbjorn Granlund * mpf/tests/t-get_d.c: Be more lax about relative error, to handle Cray floating point format. * mpq/tests/t-get_d.c: Decrease default reps to 1000. * mpf/tests/t-conv.c: Correct type of `bexp'. * configure.in (cray vector machines): Don't inherit gmp_cflags_cc. * tune/Makefile.am (EXTRA_DIST): Delete sparc64.asm. * configure.in (cray vector machines): Set extra_functions. * mpn/cray/mulww.f: New file with vectorizing cray code. * mpn/cray/mulww.s: Generated from mulww.f. * mpn/cray/mul_1.c: New file. * mpn/cray/addmul_1.c: New file. * mpn/cray/submul_1.c: New file. * mpn/cray/add_n.c: New file. * mpn/cray/sub_n.c: New file. 2000-06-26 Kevin Ryde * acinclude.m4 (GMP_CHECK_ASM_ALIGN_FILL_0x90): Fix so it actually detects solaris 2.6, and also suppress warning on solaris 2.8. * configure.in (SPEED_CYCLECOUNTER): Remove spurious "athlon" from sparc case. * mpn/lisp/gmpasm-mode.el: Move keymap to the top of the docstring. 2000-06-21 Kevin Ryde * mpn/generic/mul_n.c (mpn_kara_mul_n, mpn_kara_sqr_n): Use mp_size_t for n2. (mpn_toom3_mul_n, mpn_toom3_sqr_n): Use mp_size_t for size parameters and "l" variables. * gmp-impl.h (mpn_toom3_mul_n, mpn_toom3_sqr_n): Update prototypes. * mpbsd/itom.c, mpbsd/sdiv.c: Add casts for correct handling of -0x80...00 on systems with sizeof(short)==sizeof(int). * mpz/tests/t-misc.c: Move "bin" test from here ... * mpz/tests/t-bin.c: ... to here, and add a new (2k,k) test too. * mpz/tests/Makefile.am (check_PROGRAMS): Add t-bin. * mpz/bin_ui.c [_LONG_LONG_LIMB]: Use mpn_divrem_1, since kacc is a limb not a ulong. * mpz/bin_uiui.c [_LONG_LONG_LIMB]: Ditto, and use mpn_mul_1 too, since nacc is a limb. * mpf/tests/t-misc.c (check_mpf_set_si, check_mpf_cmp_si): New file, testing mpf_set_si, mpf_init_set_si, and mpf_cmp_si. * mpf/tests/Makefile.am (check_PROGRAMS): Add it. * mpz/tests/t-misc.c (check_mpz_set_si, check_mpz_cmp_si): New tests, for mpz_set_si, mpz_init_set_si, and mpz_cmp_si. * mpz/set_si.c, mpz/iset_si.c, mpz/cmp_si.c [_LONG_LONG_LIMB]: Fix handling of -0x80..00. * mpf/set_si.c, mpf/iset_si.c, mpf/cmp_si.c [_LONG_LONG_LIMB]: Ditto. 2000-06-19 Torbjorn Granlund * demos/primes.c: Properly handle arguments `m +n'. 2000-06-17 Torbjorn Granlund * config.sub: Recognize k5 and k6 with common pattern. * mpq/tests/t-get_d.c: Also test mpq_set_d. Misc improvements. * mpq/set_d.c: Special case 0.0. Don't call mpn_rshift with 0 count. Allocate correct amount of memory for numerator. Delete spurious ASSERT_ALWAYS(1). 2000-06-17 Kevin Ryde * mpz/perfsqr.c: Fix so that zero is considered a perfect square. (Was wrongly calling mpn_perfect_square_p with size==0.) 2000-06-16 Kevin Ryde * configure.in: Set k5*-*-* to use basic i386 code until there's something specific. Add path=x86 as a default for x86s. * acinclude.m4 (GMP_CHECK_ASM_ALIGN_LOG): Generate ALIGN_LOGARITHMIC setting, not a full ALIGN definition. (GMP_CHECK_ASM_ALIGN_FILL_0x90): New test. * configure.in [x86-*-*]: Use GMP_CHECK_ASM_ALIGN_FILL_0x90. * mpn/asm-defs.m4 (ALIGN): New macro. * mpn/x86/x86-defs.m4 (ALIGN): Remove supplementary definition. * tune/*: Plain "unsigned" for speed_cyclecounter. * configure.in: Use tune/sparcv9.asm for 32 and 64 bit modes. * tune/sparc64.asm: Remove file. 2000-06-15 Torbjorn Granlund * mpn/x86/k7/mmx/copyi.asm: Use `testb' instead of `test'. * mpn/x86/k7/mmx/copyd.asm: Likewise. * mpn/x86/k7/mmx/lshift.asm: Avoid using `~' (Solaris as problems). * mpn/x86/k7/mmx/rshift.asm: Likewise. * mpn/x86/k6/aors_n.asm: Likewise. * mpn/x86/k7/aors_n.asm: Likewise. * mpn/x86/k7/mul_basecase.asm: Likewise. 2000-06-13 Torbjorn Granlund * tune/sparcv9.asm: Tune, deleting two instructions. * tune/alpha.asm: Update to unified speed_cyclecounter. 2000-06-11 Kevin Ryde * mpz/tests/reuse.c (FAIL): Add a K&R version. Use _PROTO on some typedefs. * mpz/tests/t-misc.c: Add gmp-impl.h for "const". * configure.in: Rework mpn multi-function and optional files. Names standardized, no need for explicit declarations, all picked up in one $path traversal. * doc/configuration: Updates. * tests/rand/t-rand.c (main): Change "usage" to work with K&R. 2000-06-10 Kevin Ryde * mpn/x86/pentium/mmx/popham.asm, mpn/x86/p6/mmx/popham.asm, mpn/x86/p6/p3mmx/popham.asm, mpn/x86/p6/diveby3.asm: Add MULFUNC_PROLOGUE for correct HAVE_NATIVE_* matching. * mpn/x86/x86-defs.m4 (cmov_bytes_tttn): Use eval() on expressions. (cmov_available_p): Switch to list CPUs which do have cmov. * mpn/x86/p6/sqr_basecase.asm, mpn/x86/k6/sqr_basecase.asm, mpn/x86/k7/sqr_basecase.asm: Use eval() for multiplication. * mpn/x86/README.family: Various updates. 2000-06-09 Kevin Ryde * mpbsd/tests/allfuns.c (main): Call exit() instead of doing return. * doc/tasks.html, doc/projects.html: Moved from projects directory. * doc/multiplication: New file. * Makefile.am (EXTRA_DIST): Remove projects, add doc. * Makefile.am (libgmp_la_LIBADD, libmp_la_LIBADD): Remove unnecessary -lm. * INSTALL: Remove -lm from instructions. * demos/Makefile.am (qcn_LDADD): Add -lm. * tune/*: Add measuring for mpn_divrem_2 and modlimb_invert, improve addsub_n. Switch to unified speed_cyclecounter. * configure.in: Update configs for speed_cyclecounter. * gmp-impl.h (MP_LIMB_T_MAX, MP_LIMB_T_HIGHBIT): New macros. * mpn/generic/diveby3.c, mpn/generic/mul_n.c, mpn/generic/gcd.c, tune/speed.c, mpn/tests/ref.c: Use them. * mpn/tests/spinner.c: Remove setitimer, just alarm is enough. * configure.in (AC_CHECK_FUNCS): Remove setitimer. * mpn/tests/x86call.asm: Start with junk in %eax, %ecx, %edx. * mpn/tests/ref.[ch] (refmpn_addsub_nc): New function. * mpn/tests/try.c: Add some support for mpn_addsub_nc. * mpn/tests/Makefile.am (EXTRA_PROGRAMS): Remove addsub_n and addsub_n_2 which don't currently build. * mpn/tests/copy.c: Test MPN_COPY_INCR, not __gmpn_copy. * tests/rand/Makefile.am (libstat_la_LIBADD): Add -lm, no longer on libgmp.la. (findlc_LDADD): Use libstat.la. (AUTOMAKE_OPTIONS): Use ansi2knr. 2000-06-08 Torbjorn Granlund * configure.in (alpha*-*-osf*): Default `flavour' to ev6 for ev6 and higher. (alpha*-*-*): Likewise. (alpha*-*-osf*: gmp_optcflags_cc): Move -arch/-tune flags from gmp_xoptcflags_gcc. * mpn/Makefile.am (TARG_DIST): Add pa64w. * longlong.h: Wrap 64-bit hppa code in #ifndef LONGLONG_STANDALONE. 2000-06-07 Torbjorn Granlund * mpz/remove.c: Fail for `src' being zero. * mpz/tests/reuse.c: Test more functions. (FAIL): New define. * mpz/tests/t-powm.c: Loop during operand generation while they are mathematically ill-defined (used to just skip such tests). * mpz/powm.c (mpz_redc): Clean up argument declarations. * configure.in (gmp_cflags64_gcc): Don't add bogus -mWHAT option. (sparcv9-*-solaris2.[7-9]], gmp_cflags64_gcc): Inherit from previous gmp_cflags64_gcc; pass `-m64 -mptr64'. (ia64*-*-*): New. * mpn/generic/dump.c: Make it work when an mp_limb_t is not `long'. * mpf/set_prc.c: MPN_COPY => MPN_COPY_INCR. 2000-06-06 Torbjorn Granlund * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): Use mpn_incr_u for final carry propagation. * mpz/tests/t-gcd.c: Add calls to mpz_gcdext with argument t == NULL. * mpz/tests/reuse.c: Major rewrite; test many more functions. * mpz/powm_ui.c: When exp is 0, change res assign order in order to handle argument overlap. * mpz/powm.c: When exp is 0, change res assign order in order to handle argument overlap. Handle negative exp and mod arguments. * mpz/gcdext.c: Rework code after mpn_gcdext call to handle argument overlap. * mpz/fdiv_qr.c: Read dividend->_mp_size before calling mpz_tdiv_qr in order to handle argument overlap. * mpz/cdiv_qr.c: Likewise. * mpf/tests/reuse.c: Fix typo that effectively disabled `dis_funcs' tests. Clean up test for mpf_ui_div. 2000-06-06 Kevin Ryde * mpn/x86/p6/sqr_basecase.asm: New file. * mpn/x86/mod_1.asm: Avoid one conditional jump. * mpn/x86/p6/gmp-mparam.h: Update thresholds, #ifndef UMUL_TIME and UDIV_TIME, add COUNT_TRAILING_ZEROS_TIME. * mp_minv_tab.c: New file. * Makefile.am (libgmp_la_SOURCES, libmp_la_SOURCES): Add it. * gmp-impl.h (modlimb_invert): New macro. * mpz/powm.c: Remove mpz_dmprepare, use modlimb_invert instead. * mpn/generic/bdivmod.c: Use modlimb_invert instead of a loop. * mpn/generic/gcd.c: Inline two small mpn_bdivmod calls, use MPN_COPY_INCR not MPN_COPY in one place. 2000-06-05 Torbjorn Granlund * mpf/tests/reuse.c (dsi_funcs): Add mpf_mul_2exp and mpf_div_2exp. (main): Clean up test for mpf_div_ui. * mpf/mul_2exp.c: Correct criterion for whether to use mpn_lshift or mpn_rshift. MPN_COPY => MPN_COPY_INCR. Coerce the two assignments to r->_mp_size. * mpf/div_2exp.c: Use mpn_rshift instead of mpn_lshift when overlap so requires. MPN_COPY => MPN_COPY_INCR. * mpf/tests/t-dm2exp.c: Correct type of res_prec. 2000-06-04 Kevin Ryde * mpz/bin_uiui.c: Fix result for n==0 and n==k. * mpz/bin_ui.c: Fix result for k>n, add support for n<0. * gmp.texi (Number Theoretic Functions): Update mpz_bin_ui to note n<0 is supported. * mpz/tests/t-misc.c: New file. * mpz/tests/Makefile.am (check_PROGRAMS): Add it. 2000-05-31 Kevin Ryde * tune/speed.* (FLAG_R_OPTIONAL): New option for routines, use on mpn_gcd_1 and mpn_mul_basecase. * tune/README: Update. * tune/alpha.asm: New file, by Torbjorn. * tune/Makefile.am (EXTRA_DIST): Add it. * configure.in (alpha*-*-*): Use it. 2000-05-31 Linus Nordberg * doc/configuration: New file. 2000-05-30 Torbjorn Granlund * mpn/generic/mul_basecase.c: Call mpn_mul_2 and mpn_addmul_2 if available. Don't include longlong.h. * doc/isa_abi_headache: New file. 2000-05-30 Linus Nordberg * configure.in (NM): Use AC_PROG_NM rather than AC_CHECK_TOOL to find `nm'. (AC_PROG_NM comes with Libtool and is needed to get the `-B' option (BSD compatible output) included in $NM.) (AR): Use AC_CHECK_PROG rather than AC_CHECK_TOOL to find `ar'. (Now that NM isn't a cross compilation tool, don't give the impression that we know how to cross compile.) (CCAS): Remove spurious comment. * gmp.texi (Notes for Particular Systems): Remove comment about using GNU `nm' on AIX since system nm now works. 2000-05-29 Torbjorn Granlund * mpn/power/mul_1.s: Remove [PR] from first word in function descriptor. * mpn/power/addmul_1.s: Likewise. * mpn/power/submul_1.s: Likewise. 2000-05-28 Kevin Ryde * configure.in, tune/*: Change pentium rdtsc cycle scheme to HAVE_SPEED_CYCLECOUNTER and SPEED_CYCLECOUNTER_OBJS. * tune/pentium.asm: Renamed and converted from rdtsc.asm. * tune/sparcv9.asm: New file, by Torbjorn. * tune/sparc64.asm: New file. * tune/tuneup.c: Put a limit on gcdext search. * gmp.h (mp_set_memory_functions): Add extern "C". * mp.h (__GNU_MP__): Bump to "3". * mpz/add.c,mul.c,powm.c,sub.c,sqrtrem.c,tdiv_qr.c [BERKELEY_MP]: Include mp.h for mpbsd compile. * mpz/gcd.c: Ditto, and remove _mpz_realloc declaration. * gmp.texi (Integer Functions): Flatten @subsections into @sections. (Floating-point Functions): Ditto. (Integer Random Numbers): Split from miscellaneous as a sep section. (Installing GMP): Make nodes for the sections. Add more "@cindex"s. (Known Build Problems): Remove SunOS get_d problem, believed fixed. (Notes for Particular Systems): Remove HPPA note since now PIC. (References): URL for Jebelean. 2000-05-27 Torbjorn Granlund * mpn/pa64w: New directory, contents based on corresponding mpn/pa64 files. * configure.in (hppa2.0w-*-*): New. * mpz/tests/io.c (_INCLUDE_POSIX_SOURCE): Define when __hpux before including stdio.h. * gmp-impl.h: Always define DItype and UDItype. 2000-05-27 Kevin Ryde * tune/common.c (speed_measure): Correction to array sorting, better diagnostic when measuring fails. * tune/time.c: Add microsecond accurate getrusage method. * tune/time.c (speed_cpu_frequency_processor_info): New function. * configure.in (AC_CHECK_FUNCS): Add processor_info. 2000-05-26 Linus Nordberg * gmp.texi (Installing GMP): Shared libraries work for AIX < 4.3 if using GNU nm. 2000-05-26 Torbjorn Granlund * tune/tuneup.c (SIGNED_TYPE_MAX): Shift `-1' instead of `1' to avoid signed overflow. * demos/pexpr.c (setup_error_handler): Don't call sigaltstack on Unicos. 2000-05-25 Torbjorn Granlund * insert-dbl.c: Work around GCC 2.8 bug. * extract-dbl.c: Likewise. * config.sub: Allow i586, i686, i786 again. * config.guess: Use X86CPU for lots more systems. 2000-05-25 Linus Nordberg * mpbsd/tests/dummy.c (main): Call exit() instead of doing return (some old SysV machines don't get this correct, I've heard.) 2000-05-25 Kevin Ryde * mpf/iset_str.c: Initialize _mp_size and _mp_exp to 0, in case no digits in string, so it's the same as a separate init and set_str. 2000-05-24 Torbjorn Granlund * mpz/tests/reuse.c: Use mpz_random2 instead of mpz_random. * mpz/divexact.c: Read pointers after reallocation. Compare `quot' and `den' instead of `qp' and `dp' in overlap check. Use MPN_COPY_INCR for copying from `np'. (*-*-aix4.[3-9]*): Disable shared libs just for problematic AIX versions. * configure.in (*-cray-unicos*): Disable asm syntax checking; set compiler explicitly. * configure.in (hppa*-*-*): Remove code disabling shared libs. 2000-05-24 Linus Nordberg * acinclude.m4 (GMP_PROG_CC_WORKS): Don't report progress to user when doing the AIX specific test to avoid "nested output". 2000-05-22 Kevin Ryde * mp.h (_PROTO): Copy from gmp.h, use on prototypes. Add extern "C" too. * mpbsd/tests/Makefile.am (AUTOMAKE_OPTIONS): Enable ansi2knr. * mpbsd/tests/allfuns.c: Don't execute mout, just link to it. (main): ANSI style definition. * gmp-impl.h (MP_BASE_AS_DOUBLE): Change the expression to something that works on SunOS native cc. Seems to fix the mp*_get_d problems. * mpn/tests/ref.c (refmpn_strip_twos): Use MPN_COPY_INCR. * mpn/tests/Makefile.am: Let .asm.o rules work with absolute $srcdir. 2000-05-21 Kevin Ryde * mpn/x86/k7/sqr_basecase.asm: Replace file with K7 specific code. * mpn/x86/k7/README: Update. * mpn/x86/k7/gmp-mparam.h: Tune thresholds. (COUNT_TRAILING_ZEROS_TIME): New define. * mpn/x86/k6/gmp-mparam.h: Ditto. * mpn/x86/pentium/mmx/popham.asm: New file (include_mpn of K6 version). * mpn/x86/p6/diveby3.asm: New file (include_mpn of P5 version). * mpn/x86/p6/mmx/popham.asm: New file (include_mpn of K6 version). * mpn/x86/p6/p3mmx/popham.asm: New file (include_mpn of K7 version). * configure.in (pentium3-*-*): Add p3mmx to $path. * gmp.texi (Integer Arithmetic): Clarify mpz_jacobi op2; add mpz_*_kronecker_*. (Miscellaneous Integer Functions): Add mpz_odd_p and mpz_even_p. (Low-level Functions): Put mpn_divmod_1 with mpn_divrem_1 and note it's now a macro. (References): Add Henri Cohen. * gmp.h (mpn_addmul_1c, mpn_divrem_1c, mpn_mod_1c, mpn_mul_1c, mpn_submul_1c): Add prototypes. (mpz_odd_p, mpz_even_p): New macros. * mpn/asm-defs.m4 (m4wrap_prepend): New macro. (m4_error): Use it. (m4_not_for_expansion): Corrections to OPERATION symbols. More comments about variations between m4 versions. * mpn/x86/x86-defs.m4 (PROLOGUE): Use m4wrap_prepend (fixes error exit under BSD m4, previously m4_error printed the message but the exit code was 0). * gmp.h (mpn_divmod_1): Change to a macro calling mpn_divrem_1. * mpn/generic/divrem_1.c: Move divmod_1.c code to here, make it static and call it __gmpn_divmod_1_internal. * mpn/generic/divmod_1.c: Remove file. * configure.in (gmp_mpn_functions): Remove divmod_1. * mpn/asm-defs.m4 (define_mpn): Remove divmod_1 and divmod_1c. * compat.c (mpn_divmod_1): Add compatibility function. * tune/*: Remove mpn_divmod_1 measuring (leave just divrem_1). * acconfig.h (HAVE_NATIVE_mpn_*): Add some missing carry-in variants, remove divmod_1. * mpn/x86/diveby3.asm: Use imul, update comments. * demos/qcn.c: New file. * demos/Makefile.am (EXTRA_PROGRAMS): Add it. * mpz/tests/t-jac.c: New file. * mpz/tests/Makefile.am (check_PROGRAMS): Add it. Enable ansi2knr. * mpz/kronsz.c: New file. * mpz/kronuz.c: New file. * mpz/kronzs.c: New file. * mpz/kronzu.c: New file. * mpz/Makefile.am (libmpz_la_SOURCES): Add them. * Makefile.am (MPZ_OBJECTS): Add them. * gmp-impl.h (JACOBI_*, MPN_STRIP_LOW_ZEROS_NOT_ZERO): New macros. * gmp.h (mpz_*_kronecker_*): New defines and prototypes. * mpn/generic/jacbase.c: New file. * mpn/generic/mod_1_rs.c: New file. * configure.in (gmp_mpn_functions): Add them. * gmp.h (mpn_jacobi_base, mpn_mod_1_rshift): New defines and prototypes. * longlong.h (COUNT_TRAILING_ZEROS_TIME): New define. * mpn/tests/ref.c (refmpn_mod_1_rshift): New function. * mpn/tests/try.c: Add mpn_mod_1_rshift. * tune/*: Add measuring for mpn_jacobi_base. * acinclude.m4 (GMP_FINISH): Add ifdefs to allow multiple inclusion of config.m4. (GMP_PROG_M4): Put "good" message through to config.log. * mpz/powm.c: Use a POWM_THRESHOLD for where redc stops. * tune/*: Add mpz_powm measuring, and tune POWM_THRESHOLD. * gmp-impl.h [TUNE_PROGRAM_BUILD] (POWM_THRESHOLD): Conditional redefinition for use when tuning. * mpz/powm_ui.c: Use DIVIDE_BY_ZERO. * mpz/iset_str.c: Initialize _mp_size to 0, in case no digits in string; this makes it the same as a separate init and set_str. 2000-05-20 Kevin Ryde * mpn/asm-defs.m4: Note &,|,^ aren't bitwise in BSD m4 eval(). * mpn/x86/k6/sqr_basecase.asm: Use "%" not "&" in m4 eval()s. * mpn/x86/x86-defs.m4 (Zdisp): Yet more instruction forms. 2000-05-19 Linus Nordberg * acinclude.m4 (GMP_CHECK_CC_64BIT): Don't use shell variable `ac_compile' for our own compile command string since other Autoconf macros may depend on it. 2000-05-19 Kevin Ryde * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): Fix carry propagation in final coefficient additions. 2000-05-18 Linus Nordberg * configure.in: Set NM before looking for compiler since GMP_CHECK_CC_64BIT needs it. * acinclude.m4 (GMP_CHECK_CC_64BIT): Don't execute on target. (GMP_PROG_CC_FIND): Before checking if the compiler knows how to produce 64-bit code, verify that it works at all. The background is that /usr/ucb/cc on Solaris 7 successfully compiles in 64-bit mode but fails when doing final link. (GMP_PROG_CC_WORKS): Report to user what's happening. 2000-05-17 Linus Nordberg * config.guess: Use X86CPU for x86 Cygwin. 2000-05-16 Kevin Ryde * mpn/x86/p6/mmx/divrem_1.asm: New file. * mpn/x86/p6/mmx/mod_1.asm: New file. * mpn/x86/p6/README: Update. * mpn/x86/divrem_1.asm: Update comments. * mpn/x86/mod_1.asm: Ditto. 2000-05-14 Kevin Ryde * tune/speed.h: Run gcd functions on a set of data. * mpn/tests/try.c: New file. * mpn/tests/try.h: New file. * mpn/tests/spinner.c: New file. * mpn/tests/trace.c: New file. * mpn/tests/x86call.asm: New file. * mpn/tests/x86check.c: New file. * mpn/tests/ref.c (refmpn_hamdist): Allow size==0. (refmpn_gcd): New function, and other additions supporting it. * mpn/tests/ref.h: More prototypes. * mpn/tests/Makefile.am: Add try program, use ansi2knr. * mpn/x86/k7/mmx/popham.asm: New file. * mpn/x86/k6/mmx/popham.asm: New file. * mpn/x86/k6/sqr_basecase.asm: Unroll the addmul, for approx 1.3x speedup above 15 limbs. * mpn/x86/k7/README: Update. * mpn/x86/k6/README: Update, and add notes on plain K6 and pre-CXT K6-2 problems. * configure.in (k6*-*-*, athlon-*-*): Add popham. * mpn/x86/pentium/diveby3.asm: New file. * mpn/x86/pentium/README: Update. * gmp.texi (Installing GMP): Add note on bad OpenBSD 2.6 m4. (Reporting Bugs): Ask for config.m4 if asm file related. (I/O of Rationals): New section, add mpq_out_str. (References): Add url for on-line gcc manuals. A few node and menu updates. * INSTALL: Better command line argument checking for test progs. Change MP -> GMP. * configure.in (WANT_ASSERT, USE_STACK_ALLOC, HAVE_PENTIUM_RDTSC): Put descriptions here, not in acconfig.h. (CALLING_CONVENTIONS_OBJS): New AC_SUBST (for mpn/tests/try). (HAVE_CALLING_CONVENTIONS): New AC_DEFINE. (AC_CHECK_HEADERS): Add sys/time.h. (AC_CHECK_FUNCS): Add getpagesize, setitimer. (KARATSUBA_SQR_THRESHOLD): Strip trailing comments from the #define when passing through to config.m4. * acconfig.h (PACKAGE, VERSION, WANT_ASSERT, USE_STACK_ALLOC, HAVE_PENTIUM_RDTSC): No need for #undefs, autoheader gets them from configure.in. * acinclude.m4 (GMP_PROG_M4): Check for broken OpenBSD 2.6 m4 eval(), put messages into config.log. * mpn/asm-defs.m4: Add notes and test for OpenBSD 2.6 m4. * mpq/out_str.c: New file. * mpq/Makefile.am (libmpq_la_SOURCES): Add it. * Makefile.am (MPQ_OBJECTS): Ditto. * gmp.h (mpq_out_str): New define and prototype. 2000-05-12 Kevin Ryde * configure.in (CONFIG_TOP_SRCDIR): Fix to use $srcdir not $top_srcdir (which doesn't exist). * acinclude.m4 (GMP_C_ANSI2KNR): Fix setting U=_. * gmp-impl.h (mpn_com_n, MPN_LOGOPS_N_INLINE): Fix missing "do" (not currently used, probably no ill effect anyway). 2000-05-11 Torbjorn Granlund * randraw.c (lc): Major overhaul (pending rewrite). (_gmp_rand): Rewrite. 2000-05-08 Torbjorn Granlund * mpz/tests/convert.c: Call free via _mp_free_func. * mpf/tests/t-conv.c: Likewise. * memory.c: Add code enabled for DEBUG that adds special patterns around allocated blocks. 2000-05-05 Linus Nordberg * gmp.texi (Miscellaneous Float Functions): Correct parameter list for mpf_urandomb(). * configure.in: Invoke AC_REVISION. 2000-05-05 Kevin Ryde * gmp.texi: Use @dircategory and @direntry. (Installing GMP): Clarification for --target, updates on SunOS problems. (Integer Arithmetic): Add mpz_mul_si. (Initializing Rationals): Add mpq_swap. (Assigning Floats): Add mpf_swap. (Low-level Functions): Add mpn_divexact_by3c, and details of what the calculation actually gives. (Low-level Functions): Note extra space needed by mpn_gcdext, clarify the details a bit. * compat.c: New file, entry points for upward binary compatibility. (mpn_divexact_by3): Compatibility function. * Makefile.am (libgmp_la_SOURCES): Add compat.c. * mpn/tests/ref.c: Rearrange macros for ansi2knr. (div1): Renamed from div to avoid library function. (refmpn_divexact_by3c, refmpn_gcd_1, refmpn_popcount, refmpn_hamdist): New functions. * mpn/tests/ref.h: Add extern "C", add new prototypes. * gmp.h (gmp_randinit, etc): Add extern "C". (_mpq_cmp_ui): Fix prototype name from mpq_cmp_ui. (mpn_divexact_by3): Now a macro calling mpn_divexact_by3c. (mpn_divexact_by3c): New prototype and define. * mpn/x86/diveby3.asm: Change to mpn_divexact_by3c. * mpn/x86/k6/diveby3.asm: Ditto. * mpn/generic/diveby3.c: Ditto. * mpn/asm-defs.m4: Ditto on the define_mpn. * acconfig.h (HAVE_NATIVE_mpn_divexact_by3c): New define. * mpq/swap.c: New file, derived from mpz/swap.c. * mpf/swap.c: Ditto. * mpq/Makefile.am: Add swap.c. * mpf/Makefile.am: Ditto. * Makefile.am: Add two new "swap.lo"s. * mpn/x86/k6/mmx/com_n.asm: Fix an addressing bug (fortunately this code hasn't been used anywhere yet). * mpn/x86/k7/mmx/divrem_1.asm: New file. * mpn/x86/k7/mmx/mod_1.asm: New file. * mpn/x86/k7/diveby3.asm: New file. * mpn/x86/k7/README: Update. * mpn/x86/k7/aorsmul_1.asm: Use new cmovCC, no object code change. * mpn/x86/k7/mul_basecase.asm: Ditto. * mpn/x86/p6/aorsmul_1.asm: Ditto. * mpn/x86/x86-defs.m4 (defframe_empty_if_zero): Eval the argument. (cmovCC): New macros, replacing individual cmovCC_reg_reg forms. (Zdisp): Recognise more instructions. (shldl,etc): Use m4_instruction_wrapper(). (ASSERT, movl_text_address): New macros. * mpn/asm-defs.m4: Add remarks on SunOS /usr/bin/m4 and new OpenBSD m4. (m4_assert_numargs_internal_check): Remove a spurious parameter. (m4_empty_if_zero): Eval the argument. (m4_assert, m4_assert_numargs_range, m4_config_gmp_mparam, m4_instruction_wrapper): New macros. 2000-05-04 Linus Nordberg * gmp.texi (Reporting Bugs): Be explicit about output from running a command. 2000-05-02 Torbjorn Granlund * mpn/generic/bz_divrem_n.c (mpn_bz_divrem_n): Handle non-zero return from first mpn_bz_div_3_halves_by_2 call. (mpn_bz_divrem_aux): Likewise. 2000-04-30 Kevin Ryde * tune/* (GCD_ACCEL_THRESHOLD, GCDEXT_THRESHOLD): Tune these. * mpn/generic/gcdext.c (GCDEXT_THRESHOLD): Rename from THRESHOLD, use with >=, adjust default to 17 accordingly. Use new *_SWAP macros. * mpn/generic/gcd.c (GCD_ACCEL_THRESHOLD): Rename from ACCEL_THRESHOLD, use with >=, adjust default to 5 accordingly. Use new *_SWAP macros. * mpf/get_str.c, mpf/set_str.c, mpf/sub.c, mpz/add.c, mpz/ior.c, mpz/and.c, mpz/sub.c, mpz/xor.c, mpz/ui_pow_ui.c, mpn/generic/mul.c: Use new *_SWAP macros. * stack-alloc.h: Add extern "C" around prototypes. * gmp-impl.h: (MP_PTR_SWAP, etc): New macros. (_mp_allocate_func, etc): Use _PROTO. [TUNE_PROGRAM_BUILD]: More changes in tune program build part. 2000-04-28 Torbjorn Granlund * mpn/pa64/add_n.s: Add `,entry' to export directive. * mpn/pa64/addmul_1.S, mpn/pa64/lshift.s, mpn/pa64/mul_1.S, mpn/pa64/rshift.s, mpn/pa64/sub_n.s, mpn/pa64/submul_1.S, mpn/pa64/umul_ppmm.S: Likewise. * mpn/hppa/hppa1_1/udiv_qrnnd.S: New name for udiv_qrnnd.s. Add PIC support. 2000-04-29 Kevin Ryde * gmp-impl.h [TUNE_PROGRAM_BUILD] (TOOM3_MUL_THRESHOLD_LIMIT): New define. * mpn/generic/mul_n.c [TUNE_PROGRAM_BUILD] (mpn_mul_n): Use TOOM3_MUL_THRESHOLD_LIMIT, not a hard coded 500. * memory.c: Use for malloc etc, and use _PROTO. * stack-alloc.c: Don't use C++ reserved word "this". * urandom.h: Put extern "C" around prototypes. * mpz/powm.c: Switch a couple of parameters to "const", which they are, to satisfy g++. * randraw.c, stack-alloc.c, mpbsd/mout.c, mpbsd/mtox.c: Add casts to help g++. * stack-alloc.c: Provide dual ANSI/K&R function definitions. * mpz/addmul_ui.c,get_d.c,inp_str.c,perfpow.c,powm.c,pprime_p.c, rrandomb.c,set_str.c,ui_pow_ui.c: Ditto. * mpf/integer.c,set_str.c: Ditto. * mpbsd/min.c,xtom.c: Ditto. * mpn/generic/bz_divrem_n.c,dump.c,gcd_1.c,get_str.c,hamdist.c, popcount.c,random.c,random2.c,set_str.c: Ditto. * rand.c: Use for NULL. * mpz/gcd_ui.c,gcdext.c,mul.c,perfpow.c,powm_ui.c,root.c,sqrt.c, sqrtrem.c: Ditto * mpf/sqrt.c,sqrt_ui.c: Ditto. * mpn/generic/perfsqr.c,sqrtrem.c: Ditto. * gmp-impl.h (NULL, malloc, realloc, free): Don't define/declare. (extern "C"): Add around function prototypes. (mpn_kara_mul_n, mpn_kara_sqr_n, mpn_toom3_mul_n, mpn_toom3_sqr_n): Add prototypes. [TUNE_PROGRAM_BUILD] (FIB_THRESHOLD): Add necessary redefinitions for use by tune program. * mpn/generic/mul_n.c: Remove mpn_toom3_mul_n prototype. * acinclude.m4 (GMP_C_ANSI2KNR): New macro. (GMP_CHECK_ASM_MMX, GMP_CHECK_ASM_SHLDL_CL): Fix to use $gmp_cv_check_asm_text which is what GMP_CHECK_ASM_TEXT sets. * configure.in (GMP_C_ANSI2KNR): Use this instead of AM_C_PROTOTYPES, for reasons described with its definition. * demos/Makefile.am (ansi2knr): Use $(top_builddir) nor $(top_srcdir). * mpz/fib_ui.c (FIB_THRESHOLD): Rename from FIB_THRES, for consistency. (FIB_THRESHOLD): Conditionalize so gmp-mparam.h can define a value. (mpz_fib_bigcase): Use >= FIB_THRESHOLD, same as main mpz_fib_ui. * tune/tuneup.c,Makefile.am (FIB_THRESHOLD): Tune this. * configure.in (*-*-aix* gmp_m4postinc): Fix setting (don't overwrite a value just stored). 2000-04-26 Kevin Ryde * mpn/sparc32/udiv_fp.asm: Use mpn_udiv_qrnnd macro. * mpn/sparc32/udiv_nfp.asm: Ditto. * mpn/sparc32/v8/supersparc/udiv.asm: Ditto. * mpn/sparc32/umul.asm: Name the function mpn_umul_ppmm. * mpn/sparc32/v8/umul.asm: Ditto. * mpn/powerpc32/umul.asm: Ditto. * mpn/x86/syntax.h: Remove file, since now unused. * configure.in (x86): Remove -DBROKEN_ALIGN and -DOLD_GAS previously used by .S files. (x86 extra_functions): Add udiv and umul. (GMP_PROG_M4): Use this instead of AC_CHECK_PROG(M4,m4,...) (HAVE_NATIVE_*): Loosen up the regexp to "PROLOGUE.*" so as to accept PROLOGUE_GP on alpha. * acconfig.h (HAVE_NATIVE_mpn_umul_ppmm, udiv_qrnnd, invert_limb): New template defines. * mpn/asm-defs.m4 (mpn_umul_ppmm, mpn_udiv_qrnnd): New define_mpn()s. * longlong.h (umul_ppmm, udiv_qrnnd): Use a library version if it's available and an asm macro isn't. * gmp-impl.h (invert_limb): Ditto. * gmp-impl.h (ASSERT_NOREALLOC): Not a good idea, remove it. * acinclude.m4 (GMP_PROG_M4): New macro. 2000-04-25 Linus Nordberg * gmp.texi (Random State Initialization): Correct arguments to `gmp_randinit'. * acinclude.m4 (GMP_VERSION): Change `eval' --> `m4_eval'. Fix from Kevin. * aclocal.m4: Regenerate. 2000-04-25 Kevin Ryde * mpn/x86/aors_n.asm: Remove parentheses around an immediate that Solaris "as" doesn't like, change by Torbjorn. 2000-04-24 Kevin Ryde * configure.in (AC_CHECK_FUNCS): Add strtoul. * mpn/generic/mul_n.c [TUNE_PROGRAM_BUILD] (mpn_mul_n): Bigger array for karatsuba temporary space for tune program build. (mpn_toom3_sqr_n) Remove an unused variable. * demos/Makefile.am (AUTOMAKE_OPTIONS): Add ansi2knr. Add "allprogs:" pseudo-target. * demos/factorize.c, demos/isprime.c: Switch to ANSI functions, rely on ansi2knr. * gmp.texi (Getting the Latest Version of GMP): Add reference to ftp.gnu.org mirrors list. * INSTALL: Add arg count check to example programs. * mpn/x86/*/*.asm: Convert to FORTRAN ... or rather to FORTRAN-style "C" commenting to support Solaris "as". * mpn/x86/x86-defs.m4: Ditto, and add another Zdisp insn. * mpn/asm-defs.m4 (C): Update comments. * mpn/x86/README.family: Add a note on commenting, remove description of .S files. * mpn/sparc64/addmul_1.asm, mul_1.asm, submul_1.asm: Use include_mpn(). 2000-04-23 Torbjorn Granlund * config.sub: Merge with FSF version of April 23. * mpn/powerpc32: Use dnl/C instead of `#' for comments. * config.guess: Get "model" limit between pentium 2 and pentium3 right. Get rid of code determining `_' prefix; use double labels instead. * config.guess: Partially merge with FSF version of April 22. (Don't bring over NetBSD changes for now.) 2000-04-23 Kevin Ryde * tune/Makefile.am, tune/README, tune/common.c, tune/rdtsc.asm, tune/speed.c, tune/speed.h, tune/time.c, tune/tuneup.c: New files. * tune/Makefile.in: New file, generated from Makefile.am. * gmp-impl.h (ASSERT_NOREALLOC,TMP_ALLOC_LIMBS): New macros. [TUNE_PROGRAM_BUILD] Further mods for tune program builds. * mpz/Makefile.am: Add -DOPERATION_$* for new mul_siui.c. Add rules to build mul_si and mul_ui from a common mul_siui.c. * mpz/mul_siui.c: New file, derived from and replacing mul_ui.c. * gmp.h (mpz_mul_si): New prototype and define. * mpn/tests/*.c [__i386__] (CLOCK): Don't use floating point in CLOCK because cpp can't handle floats in #if's (TIMES is derived from CLOCK by default). * mpn/asm-defs.m4 (include_mpn): New macro. (m4_assert_numargs) Changes to implementation. * mpf/Makefile.am: Add -DOPERATION_$* for new integer.c. Remove explicit rules for floor.o etc. * mpf/integer.c: Use OPERATION_$* for floor/ceil/trunc. * mpn/Makefile.am: Put "tests" in SUBDIRS. * mpn/tests/Makefile.am: New file providing rules to build test programs, nothing done in a "make all" or "make check" though. * mpn/tests/README: New file. * acconfig.h (HAVE_PENTIUM_RDTSC): New define. * configure.in (x86): Rearrange target cases. Add mulfunc aors_n and aorsmul_1 for x86 and pentium (now all x86s). Remove asm-syntax.h generation not needed. Remove now unused family=x86. (sparc) Remove unused family=sparc. (HAVE_PENTIUM_RDTSC) New AC_DEFINE and AM_CONDITIONAL. (AM_C_PROTOTYPES) New test, supporting ansi2knr. (AC_CHECK_HEADERS) Add getopt.h, unistd.h and sys/sysctl.h for tune progs. (AC_CHECK_FUNCS) Add getopt_long, sysconf and sysctlbyname for tune progs. (config.m4 CONFIG_TOP_SRCDIR) Renamed from CONFIG_SRCDIR. (config.m4 asm-defs.m4) Use CONFIG_TOP_SRCDIR and include(). (gmp_m4postinc) Use include_mpn(). (gmp_links) Omit asm-defs.m4/asm.m4 and gmp_m4postinc's. (MULFUNC_PROLOGUE) Fix regexps so all functions get AC_DEFINE'd. (PROLOGUE) Ditto (native copyi and copyd were unused in gmp 3). (KARATSUBA_SQR_THRESHOLD) Copy from gmp-mparam.h into config.m4. (AC_OUTPUT) Add tune/Makefile, mpn/tests/Makefile. * Makefile.am (AUTOMAKE_OPTIONS): Add ansi2knr. (SUBDIRS): Add tune, reorder directories. (MPZ_OBJECTS): Add mpz/mul_si.lo. (libmp_la_SOURCES): Use this for top-level objects, not .lo's. * ansi2knr.c, ansi2knr.1: New files, provided by automake. * mpn/x86/aors_n.asm: Convert add_n.S and sub_n.S to a multi-function aors_n.asm, no object code change. * mpn/x86/pentium/aors_n.asm: Ditto. * mpn/x86/aorsmul_1.asm: Ditto for addmul/submul. * mpn/x86/pentium/aorsmul_1.asm: Ditto. * mpn/x86/lshift.asm, mpn/x86/mul_1.asm, mpn/x86/mul_basecase.asm, mpn/x86/rshift.asm: Convert from .S, no object code change. * mpn/x86/pentium/lshift.asm, mpn/x86/pentium/mul_1.asm, mpn/x86/pentium/mul_basecase.asm, mpn/x86/pentium/rshift.asm: Ditto. * gmp.texi (Reporting Bugs): Itemize the list of things to include. (Miscellaneous Float Functions): Correct typo in mpf_ceil etc argument types. Change @ifinfo -> @ifnottex for benefit of makeinfo --html. Remove unnecessary @iftex's around @tex. 2000-04-22 Torbjorn Granlund * config.guess: Generalize x86 cpu determination code. Now works on Solaris. * mpz/nextprime.c: Rewrite still disabled code. * configure.in: Specifically match freebsd[3-9]. 2000-04-21 Torbjorn Granlund * rand.c: Call mpz_clear for otherwise leaking mpz_t. * mpz/pprime_p.c (mpz_probab_prime_p): Merge handling of negative n into code for handling small positive n. Merge variables m and n. After dividing, simply call mpz_millerrabin. (isprime): Local variables now use attribute `long'. (mpz_millerrabin): New static function, based on code from mpz_probab_prime_p. (millerrabin): Now simple workhorse for mpz_millerrabin. 2000-04-19 Torbjorn Granlund * gmp-impl.h: Fix parenthesis error in test for __APPLE_CC__. 2000-04-18 Linus Nordberg * NEWS: Add info about shared libraries. Remove reference to gmp_randinit_lc. 2000-04-17 Torbjorn Granlund * Version 3.0 released. * mpn/arm/add_n.S: New version from Robert Harley. * mpn/arm/addmul_1.S: Likewise. * mpn/arm/mul_1.S: Likewise. * mpn/arm/sub_n.S: Likewise. * gmp.h (__GNU_MP_VERSION_PATCHLEVEL): Now 0. 2000-04-17 Linus Nordberg * configure.in (hppa2.0*-*-*): Pass `+O3' to cc/c89 in 64-bit mode to avoid compiler bug. (ns32k*-*-*): Fix typo in path. Change by Kevin. (alpha*-*-osf*): New case. Pass assembly flags for architecture to gcc. (alpha*-*-*): Don't bother searching for cc. * configure: Regenerate. * Makefile.am (EXTRA_DIST): Add `macos', `.gdbinit'. * Makefile.in: Regenerate. * mpn/Makefile.am (EXTRA_DIST): Add `m88k', `lisp'. * mpn/Makefile.in: Regenerate. 2000-04-16 Kevin Ryde * README: Updates, and don't duplicate the example in INSTALL. * INSTALL: Minor updates. * gmp.texi (Installing MP): Minor edits, restore CC/CFLAGS description. 2000-04-16 Linus Nordberg * configure.in (*-*-cygwin*): Select BSD_SYNTAX to avoid .type/.size in PROLOGUE for ELF_SYNTAX. Override ALIGN definition from x86/syntax.h. (gmp_xoptcflags_${CC}): New set of variables, indicating ``exclusive optional cflags''. (most sparcs): Use gmp_xoptcflags instead of gmp_optcflags to ensure that we pass CPU type to older gcc. (CFLAGS): CFLAGS on the command line was spoiled. * configure: Regenerate. 2000-04-16 Linus Nordberg * configure.in: Invoke AC_PROG_LIBTOOL directly. * acinclude.m4 (GMP_PROG_CC_FIND): Quote source variable when setting CC64 and CFLAGS64. (GMP_PROG_CC_SELECT): Cache result. (GMP_PROG_LIBTOOL): Remove. * aclocal.m4: Regenerate. * configure: Regenerate. 2000-04-16 Linus Nordberg * tests/rand/t-rand.c (main): Add non-ANSI function declaration. Don't use `const'. 2000-04-16 Torbjorn Granlund * mpn/generic/dump.c: Suppress output of leading zeros. * mpz/inp_str.c: Fix memory leakage. * mpz/tests/reuse.c (dss_func_division): Add a final 1. * longlong.h (alpha count_leading_zeros): Wrap in __MPN. * mpn/alpha/cntlz.asm: Use __gmpn prefix (by means of __MPN). * longlong.h (__umul_ppmm, __udiv_qrnnd): Wrap in __MPN. * mpn/alpha/udiv_qrnnd.S: Use __gmpn prefix. * mpn/hppa/udiv_qrnnd.s: Likewise. * mpn/hppa/hppa1_1/udiv_qrnnd.s: Likewise. * mpn/pa64/udiv_qrnnd.c: Likewise (by means of __MPN). * mpn/pa64/umul_ppmm.S: Likewise. * mpn/sparc32/udiv_fp.asm: Likewise (by means of MPN). * mpn/sparc32/udiv_nfp.asm: Likewise (by means of MPN). * mpn/sparc32/v8/supersparc/udiv.asm: Likewise (by means of MPN). * mpn/generic/tdiv_qr.c: Work around gcc 2.7.2.3 i386 register handling bug. * mpn/generic/tdiv_qr.c: Use udiv_qrnnd instead of mpn_divrem_1 when computing appropriate quotient; mpn_divrem_1 writes too many quotient limbs. * mpn/asm-defs.m4: invert_normalized_limb => invert_limb. * mpn/alpha/invert_limb.asm: mpn_invert_normalized_limb => mpn_invert_limb. * gmp.h: Likewise. * gmp-impl.h (alpha specific): invert_normalized_limb => invert_limb; wrap with __MPN. * longlong.h (alpha udiv_qrnnd): Likewise. 2000-04-16 Kevin Ryde * gmp.h (mp_set_memory_functions,mp_bits_per_limb,gmp_errno): Add #defines so the library symbols are __gmp_*. * errno.c: Include gmp.h. * gmp-impl.h (_mp_allocate_func,etc): Add #defines to __gmp_*. (__clz_tab): New #define to __MPN(clz_tab). * stack-alloc.c (__gmp_allocate_func,etc): Change from _mp_*. * Makefile.am (libmp_la_DEPENDENCIES): Add some mpz files needed for new mpz_powm (pow in libmp). (EXTRA_DIST): Add projects directory. * mpn/*: Change __mpn to __gmpn. * gmp.h (__MPN): Ditto. * stack_alloc.c,stack-alloc.h: Change __tmp to __gmp_tmp. * mpn/generic/sb_divrem_mn.c (mpn_sb_divrem_mn): Avoid gcc 2.7.2.3 i386 register handling bug (same as previously in mpn_divrem_classic). * mpn/generic/divrem.c: Now contains mpn_divrem, which is not an internal function, so remove warning comment. * gmp.texi (Compatibility with Version 2.0.x): Source level only. 2000-04-16 Linus Nordberg * configure.in (hppa1.0*): Prefer c89 to cc. * configure: Regenerate. 2000-04-15 Linus Nordberg * configure.in: If `mpn_path' is set by user on configure command line, use that as path. * configure: Regenerate. 2000-04-15 Linus Nordberg * configure.in (hppa2.0*): Use path "hppa/hppa1_1 hppa" if no 64-bit compiler was found. * configure: Regenerate. 2000-04-15 Linus Nordberg * configure.in: Honor `CC' and `CFLAGS' set by user on configure command line. * acinclude.m4: (GMP_PROG_CC_SELECT): Set CFLAGS if not set already. * aclocal.m4: Regenerate. * configure: Regenerate. 2000-04-15 Linus Nordberg * acinclude.m4 (GMP_PROG_CC_FIND): Remove debug output. Remove commented out code. * aclocal.m4: Regenerate. * configure: Regenerate. * configure.in: Make all `-mcpu' options to gcc optional. * configure: Regenerate. * tests/rand/Makefile.am: Don't do anything for target 'all'. * tests/rand/Makefile.in: Regenerate. 2000-04-15 Kevin Ryde * README: Small updates. * NEWS: Add some things about 3.0. * mpz/Makefile.am (EXTRA_DIST): Remove dmincl.c. * Makefile.am: Use -version-info on libraries, not -release. * mpz/tdiv_qr.c: Add mdiv function header #ifdef BERKELEY_MP. * mpbsd/Makefile.am: Use mpz/tdiv_qr.c, not mdiv.c. * Makefile.am (MPBSD_OBJECTS): Change mdiv.lo to tdiv_qr.lo. (libmp_la_DEPENDENCIES): Add mp_clz_tab.lo. * mpbsd/mdiv.c: Remove file. * config/mt-linux,mt-m68k,mt-m88110,mt-ppc,mt-ppc64-aix,mt-pwr, mt-sprc8-gcc,mt-sprc9-gcc,mt-supspc-gcc,mt-vax,mt-x86, mpn/config/mt-pa2hpux,mt-sprc9,t-oldgas,t-ppc-aix,t-pwr-aix: Remove configure fragments not used since change to autoconf. * mpn/generic/bz_divrem_n.c,sb_divrem_mn.c: Add comment that internal functions are changeable and shouldn't be used directly. 2000-04-15 Linus Nordberg * configure.in: Remove debug output. * configure: Regenerate. 2000-04-15 Torbjorn Granlund * mpn/generic/tdiv_qr.c: Don't use alloca directly. * mpz/tdiv_qr.c: Fix typo. * mpz/tdiv_r.c: Fix typo. * mpz/tdiv_q.c: Fix typo. * configure.in: Disable -march=pentiumpro due to apparent compiler problems. * mpz/powm.c: Replace with new code from Paul Zimmermann. * mpz/tdiv_q.c: Remove debug code. * mpn/generic/divrem.c: Remove C++ style `//' commented-out code. * mpn/generic/sb_divrem_mn.c: Likewise. 2000-04-14 Torbjorn Granlund * mpz/cdiv_q.c: Change temp allocation for new requirements of mpz_tdiv_qr. * mpz/fdiv_q.c: Likewise. * mpn/sparc64/gmp-mparam.h: Set up parameters for TOOM3. * mpz/dmincl.c: Delete file. * mpz/tdiv_qr.c: Rewrite using mpn_tdiv_qr. * mpz/tdiv_r.c: Likewise. * mpz/tdiv_q.c: Likewise. * mpn/generic/tdiv_qr.c: New file. * mpn/generic/bz_divrem_n.c: New file. * mpn/generic/sb_divrem_mn.c: New file. * gmp-impl.h (MPZ_REALLOC): New macro. (mpn_sb_divrem_mn): Declare. (mpn_bz_divrem_n): Declare. (mpn_tdiv_qr): Declare. * configure.in (gmp_mpn_functions): Delete divrem_newt and divrem_1n; add tdiv_qr, bz_divrem_n, and sb_divrem_mn. * mpn/generic/divrem_newt.c: Delete file. * mpn/generic/divrem_1n.c: Delete file. * gmp.h (mpn_divrem_newton): Remove declaration. (mpn_divrem_classic): Remove declaration. * gmp.h (mpn_divrem): Remove function definition. * mpn/generic/divrem.c: Replace mpn_divrem_classic with a mpn_divrem wrapper. 2000-04-14 Kevin Ryde * mpf/dump.c, mpz/dump.c, mpn/generic/dump.c, mpn/generic/divrem.c, mpn/generic/divrem_1n.c, mpn/generic/divrem_2.c, mpn/generic/divrem_newt.c, mpn/generic/mul.c, mpn/generic/mul_basecase.c, mpn/generic/mul_n.c, mpn/generic/sqr_basecase.c, mpn/generic/udiv_w_sdiv.c: Add comment that internal functions are changeable and shouldn't be used directly. * mpq/div.c: Use DIVIDE_BY_ZERO (previously didn't get an exception on zero divisor). * mpf/tests/t-get_d.c, mpz/tests/reuse.c: Add K&R function definitions. * mpz/tests/t-2exp.c: Don't use ANSI-ism 2ul. * gmp.texi (Installing MP): Build problem notes for GSYM_PREFIX and ranlib on native SunOS. Particular systems notes about AIX and HPPA shared libraries disabled. (MP Basics): Add that undocumented things shouldn't be used. (Introduction to MP): Add to CPUs listed. * acinclude.m4 (GMP_CHECK_ASM_UNDERSCORE): Don't depend on C having "void". 2000-04-13 Linus Nordberg * mpn/pa64/udiv_qrnnd.c (__udiv_qrnnd64): Add K&R function definition. * configure.in: Disable shared libraries for hppa*. (mips-sgi-irix6.*): Fix flags for 64-bit gcc. (hppa2.0*-*-*): Prefer c89 to cc. * configure: Regenerate. * gmp.h (gmp_randalg_t): Remove comma after last element. * tests/rand/t-rand.c: Add copyright notice. 2000-04-13 Kevin Ryde * mpn/generic/mul_n.c, mpn/generic/gcdext.c, mpz/nextprime.c, mpz/remove.c, mpz/root.c: Add K&R function definitions. * mpz/rrandomb.c: Fix typo in K&R part. * stack-alloc.c: Add K&R style function pointer declarations. * mpz/root.c: Use SQRT_OF_NEGATIVE on even roots of negatives. Use DIVIDE_BY_ZERO on a "zero'th" root. * configure: Regenerate with autoconf backpatched to fix --srcdir absolute path wildcards that bash doesn't like, change by Linus. * gmp.texi (Integer Arithmetic): Document mpz_nextprime. (Miscellaneous Integer Functions): Fix mpz_fits_* formatting. (Installing MP): Comment-out CC and CFLAGS description. 2000-04-13 Linus Nordberg * rand.c (gmp_randinit): Don't combine va_alist with ordinary arguments for non STDC. 2000-04-13 Torbjorn Granlund * mpz/nextprime.c: Use proper names of new random types and functions. * mpz/rrandomb.c: New file. * mpz/Makefile.am: List it. * mpz/Makefile.in: Regenerate. * Makefile.am: Here too. * Makefile.in: Regenerate. * gmp.h: Declare mpz_rrandomb. 2000-04-12 Linus Nordberg * Makefile.am, demos/Makefile.am, mpbsd/Makefile.am, mpbsd/tests/Makefile.am, mpf/Makefile.am, mpf/tests/Makefile.am, mpn/Makefile.am, mpq/Makefile.am, mpq/tests/Makefile.am, mpz/Makefile.am, mpz/tests/Makefile.am, tests/Makefile.am, tests/rand/Makefile.am (AUTOMAKE_OPTIONS): Add 'no-dependencies'. * Makefile.in, demos/Makefile.in, mpbsd/Makefile.in, mpbsd/tests/Makefile.in, mpf/Makefile.in, mpf/tests/Makefile.in, mpn/Makefile.in, mpq/Makefile.in, mpq/tests/Makefile.in, mpz/Makefile.in, mpz/tests/Makefile.in, tests/Makefile.in, tests/rand/Makefile.in: Regenerate. 2000-04-12 Linus Nordberg * randlc.c (gmp_randinit_lc): Disable function. * gmp.texi (Random State Initialization): Remove gmp_randinit_lc. * acinclude.m4 (GMP_CHECK_CC_64BIT): Compiling an empty main successfully with `-n32' will have to suffice on irix6. * aclocal.m4: Regenerate. * configure.in (sparc): Don't pass -D_LONG_LONG_LIMB to compiler. (mips-sgi-irix6.*): Use compiler option `-n32' rather than `-64' for 64-bit `cc'. Add options for gcc. * configure: Regenerate. * mpf/urandomb.c (mpf_urandomb): Add third parameter 'nbits'. If 'nbits' doesn't make even limbs, shift up result before normalizing. * gmp.h (mpf_urandomb): Add parameter to prototype. * mpf/urandom.c: Rename file to ... * mpf/urandomb.c: ... this. * Makefile.am (MPF_OBJECTS): Change urandom.lo --> urandomb.lo. * Makefile.in: Regenerate. * mpf/Makefile.am (libmpf_la_SOURCES): Change urandom.c --> urandomb.c. * mpf/Makefile.in: Regenerate. * config.in: Regenerate for HAVE_DECL_OPTARG. * randraw.c (_gmp_rand): Fix bug with _LONG_LONG_LIMB. (lc): Change return type. Use one temporary storage instead of two. Handle seed of size 0. Avoid modulus operation in some cases. Abort if M is not a power of 2. Fix bug with 64-bit limbs. Fix bug with small seed, small A and large M. * tests/rand/gen.c (main): Include gmp.h. Remove macros MIN, MAX. Add option '-q'. Don't demand argument N. Change parameters in call to mpf_urandomb. * tests/rand/t-rand.c: New file for testing random number generation. * tests/rand/Makefile.am: Run t-rand for 'make check'. (test, bigtest): Rename to manual-test, manual-bigtest. * tests/rand/Makefile.in: Regenerate. 2000-04-12 Kevin Ryde * gmp-impl.h: Include config.h before TMP_ALLOC, so --disable-alloca works. * mpbsd/Makefile.am: Don't recompile top-level sources here. * Makefile.am (libmp_la_DEPENDENCIES): Put objects here instead, add errno.lo and stack-alloc.lo. * mpn/asm-defs.m4: Add a test and message for the unsuitable SunOS m4. * gmp.texi (Installing MP): Update note on SunOS m4 failure. * acconfig.h: Add copyright notice using @TOP@. * stack-alloc.c: Use _mp_allocate_func, not malloc. * gmp.texi (Installing MP): Note this under --disable-alloca. * gmp.texi (Comparison Functions): mpz_cmp_abs => mpz_cmpabs. (Integer Arithmetic): mpz_prime_p not yet implemented, comment out. (Float Arithmetic): mpf_pow_ui now implemented, uncomment-out. (Miscellaneous Float Functions): Add mpf_ceil, mpf_floor, mpf_trunc. (Low-level Functions): Add mpn_random2, with mpn_random. * mpn/m68k/mc68020/udiv.S: Rename from udiv.s. * mpn/m68k/mc68020/umul.S: Ditto. * mpn/alpha/umul.asm: Rename from umul.s, remove .file and compiler identifiers. * mpn/powerpc32/syntax.h: Removed, no longer used. * mpn/a29k/udiv.s: Remove .file and compiler identifiers. * mpn/a29k/umul.s: Ditto. * mpn/tests/ref.c: Use WANT_ASSERT. * mpn/tests/ref.h: Use _PROTO. * mpbsd/configure.in: Removed, no longer required. * mpf/div.c: Use DIVIDE_BY_ZERO. * mpf/div_ui.c: Ditto. * mpf/ui_div.c: Ditto. * mpq/inv.c: Ditto. * mpf/sqrt.c: Use SQRT_OF_NEGATIVE. * mpz/sqrt.c: Ditto. * mpz/sqrtrem.c: Ditto. * gmp-impl.h (GMP_ERROR,SQRT_OF_NEGATIVE): New macros. (DIVIDE_BY_ZERO): Use GMP_ERROR. (__mp_bases): #define to __MPN(mp_bases). 2000-04-11 Linus Nordberg * tests/rand/stat.c (main): Initialize `l1runs' at declaration. 2000-04-11 Kevin Ryde * mpz/fib_ui.c: Add K&R function definitions. * mpbsd/tests/Makefile.am (TESTS): Add a dummy test to avoid a shell problem with an empty "for tst in $(TESTS) ; ...". * mpbsd/tests/dummy.c: New file. 2000-04-10 Torbjorn Granlund * mpz/bin_uiui.c: Delete several unused variables. Add copyright notice. * mpz/bin_ui.c: Add copyright notice. * longlong.h: Declare __count_leading_zeros for alpha. 2000-04-10 Linus Nordberg * rand.c (gmp_randinit): Change parameter list to (rstate, alg, ...). * gmp.h: Change prototype accordingly. * mpz/pprime_p.c (millerrabin): Change call accordingly. * configure.in: Check for `optarg'. * configure: Regenerate. * mpn/Makefile.am: Remove incorrect comment. * mpn/Makefile.in: Regenerate. * gmp.h: Rename most of the random number functions, structs and some of the struct members. * rand.c (gmp_randinit): Likewise. * randclr.c (gmp_randclear): Likewise. * randlc.c (gmp_randinit_lc): Likewise. * randlc2x.c (gmp_randinit_lc_2exp): Likewise. * randraw.c (lc): Likewise. (_gmp_rand_getraw): Likewise. * randsd.c (gmp_randseed): Likewise. * randsdui.c (gmp_randseed_ui): Likewise. * gmp.texi: Likewise. * gmp.texi: Use three hyphens for a dash. (Low-level Functions): Remove documentation for gmp_rand_getraw. (Random Number Functions): Add info on where to find documentation on the random number functions. * tests/rand/Makefile.am (test, bigtest): Quote argument to grep. * tests/rand/Makefile.in: Regenerate. * tests/rand/gen.c: Declare optarg, optind, opterr if not already declared. (main): Use new names for the random stuff. (main): Don't use strtoul() if we don't have it. Use strtol() instead, if we have it. Otherwise, use atoi(). (main): Use srandom/srandomdev for __FreeBSD__ only. (main): Use new parameter order to gmp_randinit(). * tests/rand/stat.c: Declare optarg, optind, opterr if not already declared. 2000-04-10 Torbjorn Granlund * mpz/pprime_p.c: Pass 0L for mpz_scan1. mpz_mmod => mpz_mod. (millerrabin): Use new random interface. (millerrabin): ... and don't forget to call gmp_randclear. * mpz/nextprime.c: New file. * gmp.h: Declare mpz_nextprime. * mpz/Makefile.am: List nextprime.c. * mpz/Makefile.in: Regenerate. * Makefile.am: List mpz/nextprime.lo. * Makefile.in: Regenerate. 2000-04-10 Kevin Ryde * move-if-change, mpz/tests/move-if-change, mpq/tests/move-if-change, mpf/tests/move-if-change: Remove, no longer used. * Makefile.am (SUBDIRS): Add tests, demos, mpbsd. (libmp.la): New target, conditional on WANT_MPBSD. (libgmp_la_LIBADD): Add -lm. (AUTOMAKE_OPTIONS): Add check-news. (include_HEADERS): Setup to install gmp.h and possibly mp.h. (DISTCLEANFILES): Add generated files. (check): Remove explicit target (now uses check-recursive). * configure.in: Use AM_CONFIG_HEADER. Add --enable-mpbsd setting automake conditional WANT_MPBSD. Output demos/Makefile, mpbsd/Makefile and mpbsd/tests/Makefile. * mpz/Makefile.am: Add SUBDIRS=tests, shorten INCLUDES since now using AM_CONFIG_HEADER. * mpq/Makefile.am: Ditto. * mpf/Makefile.am: Ditto, and add DISTCLEANFILES. * mpn/Makefile.am: Shorten INCLUDES, amend some comments. * mpz/tests/Makefile.am: Use TESTS and $(top_builddir). * mpf/tests/Makefile.am: Ditto. * mpq/tests/Makefile.am: Ditto. * demos/Makefile.am: New file. * mpbsd/Makefile.am: New file, derived from old mpbsd/Makefile.in. * mpbsd/Makefile.in: Now generated from Makefile.am. * mpbsd/realloc.c: Removed, use mpz/realloc.c instead. * mpbsd/tests/Makefile.am: New file. * mpbsd/tests/Makefile.in: New file, generated from Makefile.am. * mpbsd/tests/allfuns.c: New file. * gmp.texi (Top): Use @ifnottex, to help makeinfo --html. (Installing MP): Describe --enable-mpbsd and demo programs. * tests/rand/statlib.c: mpz_cmp_abs => mpz_cmpabs. * tests/rand/Makefile.am (LDADD): Don't need -lm (now in libgmp.la). (EXTRA_PROGRAMS): Not noinst_PROGRAMS. (INCLUDES): Shorten to -I$(top_srcdir) now using AM_CONFIG_HEADER. 2000-04-09 Torbjorn Granlund * mpz/urandomm.c: Get type of count right. Simplify computation of nbits. 2000-04-08 Torbjorn Granlund * mpz/urandomb.c: Fix reallocation condition. Simplify size computation. 2000-04-08 Linus Nordberg * acinclude.m4 (GMP_CHECK_CC_64BIT): Add special handling for HPUX. (GMP_CHECK_ASM_W32): Ditto. * aclocal.m4: Regenerate. * mpn/Makefile.am: Use $(CCAS) for assembling. (.asm.obj): Add rule. * mpn/Makefile.in: Regenerate. * gmp.texi (Miscellaneous Integer Functions): Fix typos. * configure.in: Never pass `-h' to grep. (mips-sgi-irix6.[2-9]*): Try to find 64-bit compiler. (hppa1.0*-*-*): New flag for cc. (hppa2.0*-*-*): Try to find 64-bit compiler. Chose path, set CCAS. * configure: Regenerate. 2000-04-08 Torbjorn Granlund * mpz/bin_ui.c: Don't depend on ANSI C features. * mpz/bin_uiui.c: Likewise. * Makefile.am (MPZ_OBJECTS): mpz/cmp_abs* => mpz/cmpabs*. (MPQ_OBJECTS): Add mpq/set_d.lo. (MPZ_OBJECTS): Add mpz/fits*.lo. * Makefile.in: Regenerate. * mpz/cmpabs.c: New name for mpz/cmp_abs.c. * mpz/cmpabs_ui.c: New name for mpz/cmp_abs_ui.c. * mpz/Makefile.am: Corresponding changes. * mpz/Makefile.in: Regenerate. * gmp.h: mpz_cmp_abs* => mpz_cmpabs*. * mpz/addmul_ui.c (mpn_neg1): Don't depend on ANSI C features. * mpz/invert.c: Use TMP_MARK since we invoke MPZ_TMP_INIT. * gmp.h (mpq_set_d): Declare correctly. (mpz_root): Use _PROTO. (mpz_remove): Use _PROTO. (mpf_pow_iu): Use _PROTO. * mpn/asm-defs.m4 (MPN_PREFIX): Revert previous change. * gmp.h (__MPN): Revert previous change. * mpz/perfpow.c: De-ANSI-fy. Add copyright notice. * mpz/set_d.c: Misc cleanups. * mpq/set_d: New file. * gmp.h: Declare mpq_set_d. * mpq/Makefile.am: List set_d.c. * mpq/Makefile.in: Regenerate. 2000-04-07 Torbjorn Granlund * mpz/fits_sint_p.c: New file. * mpz/fits_slong_p.c: New file. * mpz/fits_sshort_p.c: New file. * mpz/fits_uint_p.c: New file. * mpz/fits_ulong_p.c: New file. * mpz/fits_ushort_p.c: New file. * gmp.h: Declare mpz_fits_*. * mpz/Makefile.am: List fits_* files. * mpz/Makefile.in: Regenerate. 2000-04-06 Kevin Ryde * gmp.texi (Installing MP): Add known build problem SunOS 4.1.4 m4 failure. * mpn/x86/pentium/gmp-mparam.h: Tune thresholds. * mpn/x86/p6/gmp-mparam.h: Ditto. * mpn/x86/k6/gmp-mparam.h: Tune thresholds, add UMUL_TIME, UDIV_TIME. * mpn/x86/k7/gmp-mparam.h: Tune thresholds, amend UMUL_TIME. * mpn/generic/mul_n.c (mpn_kara_mul_n): Add an ASSERT. (mpn_kara_sqr_n): Add an ASSERT, use KARATSUBA_SQR_THRESHOLD. (mpn_toom3_sqr_n): Eliminate second evaluate3. * gmp-impl.h (mpn_com_n,MPN_LOGOPS_N_INLINE): Don't allow size==0. (tune_mul_threshold,tune_sqr_threshold): Conditionalize declarations on TUNE_PROGRAM_BUILD. * mpn/generic/sqr_basecase.c: Add an assert. 2000-04-05 Torbjorn Granlund * gmp.h, mpn/asm-defs.m4: List the same functions for __MPN, but leave some commented out. * gmp-impl.h (MPN_LOGOPS_N_INLINE): Optimize. (mpn_com_n): Optimize. * gmp.h (__MPN): Make it use __gmpn instead of __mpn for consistency. * mpn/asm-defs.m4 (MPN_PREFIX): Likewise. * gmp.h (GMP_ERROR_ALLOCATE): New errcode. * gmp-impl.h (MPN_MUL_N_RECURSE): Delete. (MPN_SQR_RECURSE): Delete. * gmp-impl.h (TARGET_REGISTER_STARVED): New define. * gmp-impl.h (mpn_kara_sqr_n): Remap with __MPN. (mpn_toom3_sqr_n): Likewise. (mpn_kara_mul_n): Likewise. (mpn_toom3_mul_n): Likewise. (mpn_reciprocal): Likewise. * gmp-impl.h (__gmpn_mul_n): Remove declaration. (__gmpn_sqr): Likewise. * gmp.h (mpn_sqr_n): Declare/remap. * mpn/generic/mul.c (mpn_sqr_n): New name for mpn_sqr. * gmp.h (mpn_udiv_w_sdiv): Move __MPN remap from here... * gmp-impl.h: ...to here. 2000-04-05 Linus Nordberg * gmp.texi (Top): Add `Random Number Functions' to menu. (Introduction to MP): Fix typo. (MP Basics): Create menu for all sections. Move `Random Number Functions' to its own chapter. Add nodes for all sections. (Function Classes): Mention random generation functions under miscellaneous. (Miscellaneous Integer Functions): Update mpz_urandomb, mpz_urandomm. (Low-level Functions): Remove mpn_rawrandom. (Random State Initialization): Update. * mpf/urandom.c (mpf_urandomb): Remove SIZE parameter. Normalize result correctly. * gmp.h (mpf_urandomb): Remove SIZE parameter. * randraw.c (gmp_rand_getraw): Handle the case where (1) the LC scheme doesn't generate even limbs and (2) more than one LC invocation is necessary to produce the requested number of bits. 2000-04-05 Torbjorn Granlund * mpn/generic/mul_n.c (INVERSE_3): New name for THIRD, define for any BITS_PER_MP_LIMB. (MP_LIMB_T_MAX): New. (mpn_divexact3_n): Remove. (interpolate3): Use mpn_divexact_by3 instead of mpn_divexact3_n. 2000-04-05 Kevin Ryde * gmp-impl.h (KARATSUBA_MUL_THRESHOLD<2): Remove cpp test. (tune_mul_threshold,tune_sqr_threshold): Add declarations, used in development only. * mpn/x86/k7/sqr_basecase.asm: New file, only a copy of k6 for now. 2000-04-04 Torbjorn Granlund * gmp-impl.h (TOOM3_MUL_THRESHOLD): Provide default. (TOOM3_SQR_THRESHOLD): Provide default. * mpn/generic/mul_n.c: Rewrite (mostly by Robert Harley). * mpn/generic/mul.c: Rewrite (mostly by Robert Harley). * configure.in (sparcv9 64-bit OS): Set extra_functions. 2000-04-04 Linus Nordberg * mpn/generic/rawrandom.c: Remove file and replace with randraw.c on top level. (mpn_rawrandom): Rename to gmp_rand_getraw. * randraw.c: New file; essentially a copy of mpn/generic/rawrandom.c. (gmp_rand_getraw): New function (formerly known as mpn_rawrandom). * mpz/urandomb.c (mpz_urandomb): Change mpn_rawrandom --> gmp_rand_getraw. * mpz/urandomm.c (mpz_urandomb): Ditto. * mpf/urandom.c (mpf_urandomb): Ditto. * gmp.h (gmp_rand_getraw): Add function prototype. (mpn_rawrandom): Remove function prototype. * Makefile.am (libgmp_la_SOURCES): Add randraw.c. * Makefile.in: Regenerate. * configure.in (gmp_mpn_functions): Remove rawrandom. * configure: Regenerate. 2000-04-04 Linus Nordberg * gmp.h (GMP_ERROR enum): Remove comma after last enumeration since the AIX compiler (xlc) doesn't like that. * randlc.c (gmp_rand_init_lc): Allocate enough space for seed to hold any upcoming seed. * randlc2x.c (gmp_rand_init_lc_2exp): Likewise. * mpn/generic/rawrandom.c: Remove debugging code. (mpn_lc): Don't reallocate seed. * mpz/urandomm.c (mpz_urandomm): Implement function. * mpz/urandomb.c (mpz_urandomb): Fix typo in function definition. 2000-04-04 Kevin Ryde * make.bat: Removed (no longer works, no longer supported). * mpn/msdos/asm-syntax.h: Removed (was used only by make.bat). 2000-04-03 Torbjorn Granlund * mpn/generic/brandom.c: New file, replacing random2. 2000-04-02 Torbjorn Granlund * mpn/sparc32/v9/submul_1.asm: Change some carry-form instructions into their plain counterparts. * mpn/sparc64/copyi.asm: Avoid executing ALIGN. * mpn/sparc64/mul_1.asm: Handle overlap of rp/sp. * mpn/sparc64/addmul_1.asm: Likewise. * mpn/sparc64/submul_1.asm: Likewise. 2000-04-01 Linus Nordberg * gmp.h: Fix function prototypes for randomization functions. (__gmp_rand_lc_scheme_struct): Replace `m' with `m2exp'. Remove unused `bits'. (__gmp_rand_data_lc): Add `m2exp' as another way of representing the modulus. (__gmp_rand_state_struct): Remove unused `size'. * rand.c (__gmp_rand_scheme): Use better multipliers. Remove test schemes. Replace `m' with `m2exp'. (gmp_rand_init): Change parameters and return type. Use `m2exp' instead of `m'. Set `gmp_errno' on error. Disable BBS algorithm. * randlc.c (gmp_rand_init_lc): Don't use malloc(). Change parameters. * randclr.c (gmp_rand_clear): Don't use free(). Disable BBS algorithm. Set `gmp_errno' on error. * randlc2x.c (gmp_rand_init_lc_2exp): New function. * randsd.c (gmp_rand_seed): New function. * randsdui.c (gmp_rand_seed_ui): New function. * randlcui.c: Remove unused file. * mpn/generic/rawrandom.c (mpn_rawrandom): Rewrite. (mpn_lc): New static function. * mpz/urandomb.c (mpz_urandomb): Use ABSIZ() instead of SIZ() for determining size of ROP. * mpf/urandom.c (mpf_urandomb): Add third parameter, nbits. (Not used yet!) Change parameter order to mpn_rawrandom(). * Makefile.am (libgmp_la_SOURCES): Add errno.c, randlc2x.c, randsd.c, randsdui.c. Remove randui.c. (MPZ_OBJECTS): Rename urandom.lo --> urandomb.lo. Add urandomm.lo. * Makefile.in: Regenerate. * mpz/Makefile.am (libmpz_la_SOURCES): Change urandom.c --> urandomb.c. Add urandomm.c. * mpz/Makefile.in: Regenerate. * tests/rand/Makefile.am (noinst_PROGRAMS): Change findcl --> findlc. Add gen.static. * tests/rand/Makefile.in: Regenerate. * tests/rand/gen.c (main): Add mpz_urandomm. Add command line options `-C', `-m', extend `-a'. Use *mp*_*rand*() with new parameters. Call gmp_rand_seed(). 2000-04-01 Kevin Ryde * acinclude.m4 (GMP_CHECK_ASM_DATA): Plain .data for hpux. * configure.in (CCAS): No CFLAGS, they're added when it's used. (CONFIG_SRCDIR): New define for config.m4. * mpn/sparc64/addmul_1.asm: Use it for an include(). * mpn/sparc64/submul_1.asm: Ditto. * mpn/sparc64/mul_1.asm: Ditto. 2000-03-31 Linus Nordberg * mpz/urandom.c: Rename to... * mpz/urandomb.c: ...this. * mpz/urandomb.c (mpz_urandomb): Change operand order in call to mpn_rawrandom(). Use ABSIZ() instead of SIZ() when checking size of ROP. * mpz/urandomm.c: New file. 2000-03-31 Kevin Ryde * acinclude.m4 (GMP_CHECK_ASM_MMX): Give a warning when mmx code will be omitted. 2000-03-30 Torbjorn Granlund * mpn/sparc64/mul_1h.asm: New file. * mpn/sparc64/addmul_1h.asm: New file. * mpn/sparc64/submul_1h.asm: New file. * mpn/sparc64/mul_1.asm: Rewrite. * mpn/sparc64/addmul_1.asm: Rewrite. * mpn/sparc64/submul_1.asm: Rewrite. 2000-03-28 Torbjorn Granlund * mpn/sparc32/v9/mul_1.asm: Fix typo in branch prediction. * mpn/sparc32/v9/addmul_1.asm: Likewise. * mpn/sparc32/v9/submul_1.asm: Likewise. 2000-03-25 Kevin Ryde * mpn/lisp/gmpasm-mode.el: Fix some comment detection, use custom, fontify more keywords, turn into a standalone mode. * stamp-vti: New file, generated together with version.texi. * acinclude.m4 (GMP_VERSION,GMP_HEADER_GETVAL): New macros. * configure.in (AM_INIT_AUTOMAKE): Use GMP_VERSION. 2000-03-24 Kevin Ryde * INSTALL: Updates for new configure system. * configure.in: Add gmp_optcflags_gcc for the x86s, setting -mcpu and -march. 2000-03-23 Torbjorn Granlund * demos/pexpr.c (mpz_eval_expr): Properly initialize rhs/lhs for ROOT. 2000-03-23 Kevin Ryde * config.guess (i?86:*:*:*): Use uname -m if detection program fails. * mpn/x86/README: Remove remarks on the now implemented MMX shifts. * mpn/x86/k6/README: Add speed of mpn_divexact_by3, update mpn_mul_1. * gmp.texi (Installing MP): Corrections to target CPUs. * version.c: Use VERSION from config.h, add copyright comment, restore "const" somehow lost. * configure.in (a29k*-*-*): Fix directory name. 2000-03-22 Torbjorn Granlund * demos/pexpr.c (op_t): Add ROOT. (fns): Add ROOT. (mpz_eval_expr): Add ROOT. * mpz/root.c: Handle roots of negative numbers. Fix other border cases. Fix rare memory leakage. * errno.c: New file. 2000-03-21 Torbjorn Granlund * gmp.h (error number enum): New anonymous enum. (gmp_errno): New. * gmp.h (__GNU_MP_VERSION, __GNU_MP_VERSION_MINOR): Bump for GMP 3.0. 2000-03-20 Torbjorn Granlund * mpn/alpha/unicos.m4 (FLOAT64): New define. * mpn/alpha/default.m4 (FLOAT64): New define. * mpn/alpha/invert_limb.asm (C36): Use FLOAT64. 2000-03-21 Kevin Ryde * mpn/x86/k6/diveby3.asm: Tiny speedup. * acinclude.m4 (GMP_CHECK_ASM_SHLDL_CL): New macro. * configure.in: Use it, set WANT_SHLDL_CL in config.m4. * mpn/x86/x86-defs.m4 (shldl,shrdl,shldw,shrdw): New macros, using WANT_SHLDL_CL. * mpn/x86/k6/mmx/lshift.asm: Use shldl macro. * mpn/x86/k7/mmx/lshift.asm: Ditto. * mpn/x86/pentium/mmx/lshift.asm: Ditto. * mpn/x86/k6/mmx/rshift.asm: Use shrdl macro. * mpn/x86/k7/mmx/rshift.asm: Ditto. * mpn/x86/pentium/mmx/rshift.asm: Ditto. * mpn/x86/README.family: Add a note about this. 2000-03-20 Linus Nordberg * mpn/generic/rawrandom.c (mpn_rawrandom): Handle seed value of 0 correctly. * configure.in: Fix detection of alpha flavour. Set compiler options for `sparcv8'. * configure: Regenerate. * rand.c (__gmp_rand_scheme): Clean up some. Use slightly better multipliers. * configure.in (AC_OUTPUT): Add tests/Makefile and tests/rand/Makefile. * acinclude.m4 (AC_CANONICAL_BUILD): Define to `_AC_CANONICAL_BUILD' to deal with incompatibilities between Autoconf and Libtool. (AC_CHECK_TOOL_PREFIX): Likewise. * Makefile.am (EXTRA_DIST): Add directory `tests'. * mkinstalldirs: Update (Automake 2000-03-17). * ltconfig: Update (Libtool 2000-03-17). * ltmain.sh: Ditto. * configure: Regenerate with new autoconf/-make/libtool suite. * aclocal.m4: Ditto. * config.in: Ditto. * all Makefile.in's: Ditto. 2000-03-20 Torbjorn Granlund * demos/pexpr.c (main): Don't allow `-N' for base, require `-bN'. * mpn/alpha/unicos.m4 (cvttqc): New define. * mpn/alpha/invert_limb.asm: Use new define for cvttqc. 2000-03-19 Kevin Ryde * mpn/x86/k6/sqr_basecase.asm: Tiny amendments for 3x3 case. * gmp.texi: Use @include version.texi. Use @email and @uref. (Installing MP): Rewrite for new configure. (Low-level Functions): Add mpn_divexact_by3. * configure.in (--enable-alloca): New option. * acconfig.h (USE_STACK_ALLOC): For --disable-alloca. 2000-03-18 Kent Boortz * macos: New directory with macos port files. 2000-03-17 Torbjorn Granlund * gmp-impl.h (union ieee_double_extract): Check _CRAYMPP. * mpn/asm-defs.m4 (invert_normalized_limb): Define. * mpn/alpha: Translate `.s' files to `.asm'. * configure: Regenerate. * mpn/alpha/invert_limb.asm: Replace dash in file name with underscore. * configure.in: Corresponding change. * configure.in: Assign special "path" for alphaev6. * mpn/alpha/unicos.m4: New file. * configure.in (alpha*-cray-unicos*): [This part of the change commited 2000-03-13 by linus] * mpn/alpha/default.m4: New file. * configure.in (alpha*-*-*): Use it. 2000-03-17 Kevin Ryde * mpn/x86/pentium/rshift.S: Use plain rcrl (not rcrl $1) for shift-by-1 case, significant speedup. * mpn/x86/pentium/README: Add shift-by-1 speed. 2000-03-16 Torbjorn Granlund * config.guess: Handle Cray T3D/E. 2000-03-15 Kevin Ryde * mpn/generic/diveby3.c: New file. * mpn/x86/diveby3.asm: New file. * mpn/x86/k6/diveby3.asm: New file. * gmp.h (mpn_divexact_by3): Prototype and define. * mpn/asm-defs.m4: define_mpn(divexact_by3). * configure.in (gmp_mpn_functions): Add diveby3. * mpn/x86/pentium/sqr_basecase.asm: A few better addressing modes. * configure.in: Add AC_C_STRINGIZE and AC_CHECK_TYPES((void)). * gmp-impl.h (ASSERT): Use them. * mpn/x86/k7/mmx/lshift.asm: New file. * mpn/x86/k7/mmx/rshift.asm: Rewrite simple loop and return value handling, add some pictures. 2000-03-14 Torbjorn Granlund * mpn/sparc32/v8/mul_1.asm: Make PIC actually work. * mpn/sparc32/v8/addmul_1.asm: Likewise. * mpn/sparc32/v8/mul_1.asm: Use m4 ifdef, not cpp #if. * mpn/sparc32/v8/addmul_1.asm: Likewise. * mpn/asm-defs.m4 (C): New define for comments. * mpn/sparc32: Start comments with `C'. * config.guess: Remove `SunOS 6' handling. Recognize sun4m and sun4d architectures under old SunOS. 2000-03-14 Linus Nordberg * configure.in (gmp_srclinks): Set to list of links created by configure. * configure: Regenerate. * Makefile.am (libgmp_la_LDFLAGS): Set version info. (DISTCLEANFILES): Include @gmp_srclinks@. * Makefile.in: Regenerate. 2000-03-13 Linus Nordberg * configure.in: Remove some changequote's by quoting the strings containing `[]'. Add support for `alpha*-cray-unicos*'. AC_DEFINE `_LONG_LONG_LIMB' instead of passing it in CFLAGS. Conditionalize the assembler syntax checks. * configure: Regenerate. * config.in: Regenerate. * acinclude.m4 (GMP_PROG_CCAS): Remove macro. * aclocal.m4: Regenerate. 2000-03-13 Kevin Ryde * mpn/x86/p6/README: New file. * mpn/x86/k6/mul_1.asm: Rewrite, smaller and slightly faster. * mpn/lisp/gmpasm-mode.el: Rewrite assembler comment detection and handling. * configure.in: Separate mmx directories for each x86 flavour. * configure: Regenerate. 2000-03-12 Kevin Ryde * mpn/x86/x86-defs.m4 (ALIGN): Supplement definition from config.m4 so as to pad with nops not zeros on old gas. * mpn/x86/k7/mmx/copyd.asm: Use plain emms (femms is just an alias for emms now). * mpn/x86/k7/mmx/copyi.asm: Ditto. * mpn/x86/k7/mmx/rshift.asm: Ditto. * mpn/x86/x86-defs.m4: Amend comments. * mpn/x86/mod_1.asm: Add comments on speeds. * mpn/x86/pentium/mmx/lshift.asm: New file. * mpn/x86/pentium/mmx/rshift.asm: New file. * mpn/x86/pentium/README: Add speeds of various routines. 2000-03-10 Linus Nordberg * configure.in: Reorganize. Use AC_CHECK_TOOL to find `ar'. Add post-includes `regmap.m4' and `aix.m4' for AIX targets. asm-syntax.h is not needed for PPC or sparc anymore. (powerpc64-*-aix*): Compiler is always 64-bit. Use `-q64 -qtune=pwr3' to xlc and `-maix64 -mpowerpc64' to gcc. Pass `-X 64' to `ar' and `nm'. (pentiummmx): Use GMP_CHECK_ASM_MMX and avoid MMX assembly path if assembler is not MMX capable. (pentium[23]): Likewise. (athlon): Likewise. (k6*): Likewise. * configure: Regenerate. * acinclude.m4 (GMP_PROG_CC_WORKS): New macro. (GMP_PROG_CC_FIND): Use GMP_PROG_CC_WORKS instead of AC_TRY_COMPILER. Make sure that the *first* working 32-bit compiler is used if no 64-bit compiler is found. (GMP_CHECK_ASM_MMX): New macro. * aclocal.m4: Regenerate. * Makefile.in: Regenerate. (CC_TEST removed.) * mpf/Makefile.in: Likewise. * mpn/Makefile.in: Likewise. * mpq/Makefile.in: Likewise. * mpz/Makefile.in: Likewise. * mpf/tests/Makefile.in: Likewise. * mpq/tests/Makefile.in: Likewise. * mpz/tests/Makefile.in: Likewise. * acconfig.h (_LONG_LONG_LIMB): Add. * gmp-impl.h: Include config.h only if HAVE_CONFIG_H is defined. 2000-03-09 Kevin Ryde * mpn/x86/pentium/mul_basecase.S: Small speedup by avoiding an AGI. * mpn/x86/k7/mmx/copyd.asm: Tiny speedup by avoiding popl. * mpn/x86/k7/mmx/copyi.asm: Ditto. * mpn/x86/k7/mul_basecase.asm: Ditto. 2000-03-07 Torbjorn Granlund * config.guess: Better recognize POWER/PowerPC processor type. 2000-03-07 Kevin Ryde * mpn/generic/addsub_n.c: Use HAVE_NATIVE_* now in config.h. * mpn/asm-defs.m4: Add comments about SysV m4. (m4_log2): Don't use <<. (m4_lshift,m4_rshift): New macros. 2000-03-06 Torbjorn Granlund * mpn/powerpc32/regmap.m4: Map cr0 => `0', etc. 2000-03-06 Kevin Ryde * mpn/tests/ref.c (refmpn_divexact_by3): New function. * mpn/tests/ref.h: Prototype. * acconfig.h (WANT_ASSERT): New define. * configure.in (--enable-assert): Turn on WANT_ASSERT. * assert.c: New file. * Makefile.am: Add to build. * gmp-impl.h (ASSERT): New macro. (ASSERT_NOCARRY) Renamed from assert_nocarry. (MPZ_CHECK_FORMAT): Use ASSERT_ALWAYS. * mpn/tests/ref.c: Use ASSERT. * mpf/get_str.c: Use ASSERT_ALWAYS. * mpf/set_str.c: Remove old assert macro. * mpn/x86/x86-defs.m4 (cmovnz_ebx_ecx): New macro. * mpn/x86/p6/aorsmul_1.asm: Use cmov. * mpn/x86/lshift.S: Use %dl with testb, not %edx. No object code change, testb was still getting generated. * mpn/x86/rshift.S: Ditto. 2000-03-03 Torbjorn Granlund * longlong.h: Add IA-64 support. * mpn/powerpc32: Misc cleanups. * mpn/powerpc32/aix.m4: New file (mainly by Linus). * mpn/powerpc64/aix.m4: New file (mainly by Linus). * mpn/powerpc64: Translate `.S' files to `.asm'. * configure.in: Fix tyops. * configure: Regenerate. 2000-03-02 Torbjorn Granlund * mpn/powerpc32/regmap.m4: New file. * mpn/powerpc32: Translate `.S' files to `.asm'. * configure.in: Use mpn/powerpc32/regmap.m4 for powerpc targets except some weird ones. 2000-03-03 Kevin Ryde * mpn/lisp/gmpasm-mode.el: Suppress postscript comment prefixes in filladapt. * mpn/x86/pentium/sqr_basecase.asm: New file. * mpn/x86/pentium/gmp-mparam.h (KARATSUBA_SQR_THRESHOLD): Update. * configure.in: Add --enable-assert, enable k6 logops functions. * mpn/x86/k6/mmx/copyi.asm: Use m4 for divide, not as. * mpn/x86/k6/mmx/copyd.asm: Ditto. * mpn/x86/README.family: Add a note on this. 2000-03-02 Kevin Ryde * mpn/x86/k6/aors_n.asm: Don't use stosl. * mpn/x86/copyi.asm: Use cld to clear direction flag. * mpn/x86/divrem_1.asm: Ditto. * mpn/x86/README.family: Add a note on this. * mpn/x86/k6/mmx/copyi.asm: Rewrite. * mpn/x86/k6/mmx/copyd.asm: New file. * mpn/x86/k6/README: Update, and small amendments. * mpn/x86/x86-defs.m4 (Zdisp): New macro. * mpn/asm-defs.m4 (m4_stringequal_p): New macro. * mpn/x86/p6/aorsmul_1.asm: Use Zdisp to force zero displacements. * mpn/x86/k6/aorsmul_1.asm: Ditto. * mpn/x86/k6/mul_1.asm: Ditto. * mpn/x86/k6/mul_basecase.asm: Ditto. * mpn/x86/k7/aors_n.asm: Ditto. * mpn/x86/k7/aorsmul_1.asm: Ditto. * mpn/x86/k7/mul_1.asm: Ditto. * mpn/x86/k7/mul_basecase.asm: Ditto. * mpn/x86/README.family: Add a note on this. 2000-02-27 Kevin Ryde * mpn/generic/divrem.c (mpn_divrem_classic): Patch to avoid gcc 2.7.2.3 i386 register handling bug. * mpn/x86/k6/aors_n.asm: Rewrite. * mpn/x86/k6/mmx/lshift.asm: Rewrite. * mpn/x86/k6/mmx/rshift.asm: Rewrite. * mpn/x86/k6/README: Update. * mpn/x86/k7/mmx/copyd.asm: Support size==0. * mpn/x86/k7/mmx/copyi.asm: Ditto. * mpn/x86/k6/mmx/copyi.asm: Ditto. * gmp-impl.h: Comment size==0 allowed in MPN_COPY_INCR and MPN_COPY_DECR. * configure.in: Enable x86 copyi, copyd; add k6 com_n. 2000-02-25 Torbjorn Granlund * demos/pexpr.c (power): Move factorial handing code from `factor' to `power'. * demos/factorize.c (factor_using_pollard_rho): Move resetting of `c' to before checking for a non-zero gcd. 2000-02-25 Kevin Ryde * mpn/asm-defs.m4 (MULFUNC_PROLOGUE): New macro by Linus. * mpn/x86/k6/aors_n.asm: Use MULFUNC_PROLOGUE. * mpn/x86/k6/aorsmul_1.asm: Ditto. * mpn/x86/k7/aors_n.asm: Ditto. * mpn/x86/k7/aorsmul_1.asm: Ditto. * mpn/x86/p6/aorsmul_1.asm: Ditto. * mpn/tests/ref.c (refmpn_copyi,refmpn_copyd): Allow size==0. * gmp-impl.h: Move mpn_and_n, mpn_andn_n, mpn_com_n, mpn_ior_n, mpn_iorn_n, mpn_nand_n, mpn_nior_n, mpn_xor_n and mpn_xorn_n here from gmp.h. Use HAVE_NATIVE_mpn_* to make these functions or inlines. * gmp-impl.h: Move mpn_copyd, mpn_copyi here from gmp.h. * gmp-impl.h (MPN_COPY_INCR): Use mpn_copyi if available. * gmp-impl.h (MPN_COPY_DECR): Use mpn_copyd if available. * mpn/x86/k6/mmx/com_n.asm: Moved into mmx subdirectory. * mpn/x86/k6/mmx/copyi.asm: Ditto. * mpn/x86/k6/mmx/lshift.asm: Ditto. * mpn/x86/k6/mmx/rshift.asm: Ditto. * mpn/x86/k7/mmx/rshift.asm: Ditto. * mpn/x86/k6/mmx/logops_n.asm: New file. * configure.in (k6*-*-*): Add logops_n.asm. * mpn/x86/k6/README: Update. * mpn/x86/k7/mmx/copyi.asm: New file. * mpn/x86/k7/mmx/copyd.asm: New file. * mpn/x86/k7/README: Update. 2000-02-24 Kevin Ryde * mpn/x86/x86-defs.m4 (femms): Generate emms if 3dnow not available. * mpn/x86/x86-defs.m4 (FRAME_popl): New macro. * Makefile.am: Add info_TEXINFOS = gmp.texi * mpn/x86/divrem_1.asm: Moved from mpn/x86/k6, allow size==0, conditionalize loop versus decl/jnz. * mpn/x86/mod_1.asm: Ditto. * mpn/x86/divmod_1.asm: Removed. * gmp.texi (mpn_divrem_1,mpn_mod_1): Add that size==0 is allowed. * mpn/tests/ref.c (refmpn_divrem_1c,etc): Allow size==0. * mpn/x86/k6/aors_n.asm: Avoid gas 1.92.3 leal displacement expression problem. * mpn/x86/k6/aorsmul_1.asm: Ditto. * mpn/x86/k6/mul_1.asm: Ditto. * mpn/x86/k6/mul_basecase.asm: Ditto * mpn/x86/k7/aors_n.asm: Ditto. * mpn/x86/k7/aorsmul_1.asm: Ditto. * mpn/x86/k7/mul_1.asm: Ditto. * mpn/x86/k7/mul_basecase.asm: Ditto. * mpn/x86/k7/rshift.asm: Ditto. * mpn/x86/p6/aorsmul_1.asm: Ditto. * mpn/x86/README.family: Describe problem. 2000-02-24 Linus Nordberg * acinclude.m4 (GMP_CHECK_ASM_LSYM_PREFIX): Add dummy symbol to testcase to avoid nm failure. Try nm before piping to grep. * acconfig.h: Undef HAVE_NATIVE_func for every mpn function found in gmp.h. * configure.in: Invoke AC_CONFIG_HEADERS. Don't invoke AM_CONFIG_HEADER; it makes autoconf confused. Dig out entry points declared in assembly code and AC_DEFINE proper HAVE_NATIVE_func. * mpn/asm-defs.m4 (MULFUNC_PROLOGUE): New macro. * mpn/x86/p6/aorsmul_1.asm: Use MULFUNC_PROLOGUE. * mpn/x86/k6/aors_n.asm: Likewise. * Makefile.am (EXTRA_DIST): Add config.in; needed when we don't use AM_CONFIG_HEADER in configure.in. * mpn/Makefile.am (INCLUDES): Add `-I..' for config.h and gmp-mparam.h. * mpf/Makefile.am: Likewise. * mpq/Makefile.am: Likewise. * mpz/Makefile.am: Likewise. * mpf/tests/Makefile.am (INCLUDES): Add `-I../..' for config.h and gmp-mparam.h. * mpq/tests/Makefile.am: Likewise. * mpz/tests/Makefile.am: Likewise. * configure: Regenerate. * aclocal.m4: Regenerate. * config.in: Regenerate. * Makefile.in: Regenerate. * mpf/Makefile.in: Regenerate. * mpn/Makefile.in: Regenerate. * mpq/Makefile.in: Regenerate. * mpz/Makefile.in: Regenerate. * mpf/tests/Makefile.in: Regenerate. * mpq/tests/Makefile.in: Regenerate. * mpz/tests/Makefile.in: Regenerate. 2000-02-23 Kevin Ryde * mpn/x86/addmul_1.S: Amend comments, this code no longer used by PentiumPro. * mpn/x86/submul_1.S: Ditto. * mpn/x86/k6/com_n.asm: Rewrite, smaller but same speed. * mpn/x86/addmul_1.S: Add PROLOGUE and EPILOGUE to get .type and .size for ELF. Rename #define size to n to avoid .size. * mpn/x86/lshift.S: Ditto. * mpn/x86/mul_1.S: Ditto. * mpn/x86/mul_basecase.S: Ditto. * mpn/x86/rshift.S: Ditto. * mpn/x86/submul_1.S: Ditto. * mpn/x86/udiv.S: Ditto. * mpn/x86/umul.S: Ditto. * mpn/x86/pentium/add_n.S: Ditto. * mpn/x86/pentium/addmul_1.S: Ditto. * mpn/x86/pentium/lshift.S: Ditto. * mpn/x86/pentium/mul_1.S: Ditto. * mpn/x86/pentium/mul_basecase.S: Ditto. * mpn/x86/pentium/rshift.S: Ditto. * mpn/x86/pentium/sub_n.S: Ditto. * mpn/x86/pentium/submul_1.S: Ditto. 2000-02-22 Linus Nordberg * acinclude.m4 (GMP_INIT): Use temporary file cnfm4p.tmp for post-defines. (GMP_FINISH): Ditto. (GMP_DEFINE): Add third optional argument specifying location in outfile. (GMP_DEFINE_RAW): New macro. * aclocal.m4: Regenerate. * configure.in: Add `HAVE_TARGET_CPU_$target_cpu' using GMP_DEFINE_RAW. * configure: Regenerate. * mpz/tests/Makefile.am: New test t-root. * mpz/tests/Makefile.in: Regenerate. 2000-02-22 Torbjorn Granlund * mpz/root.c: Complete rewrite; still primitive, but at least correct. * mpz/tests/t-root.c: New test. 2000-02-22 Kevin Ryde * mpn/x86/k7/mul_basecase.asm: New file. * mpn/x86/k7/README: Add mpn_mul_basecase speed. * mpn/x86/k7/gmp-mparam.h: New file. * mpn/x86/x86-defs.m4 (loop_or_decljnz,cmov_bytes): New macros. * mpn/asm-defs.m4 (m4_ifdef_anyof_p): New macro. * mpn/x86/k6/aorsmul_1.asm: New file. * mpn/x86/k6/addmul_1.S: Removed (was a copy of pentium version). * mpn/x86/k6/submul_1.S: Removed (was a copy of pentium version). * mpn/x86/p6/aorsmul_1.asm: Use OPERATION_addmul_1 and OPERATION_submul_1. * mpn/x86/k6/aors_n.asm: Use OPERATION_add_n and OPERATION_sub_n. * configure.in: Declare multi-function files for k6 and p6. * configure.in: Add HAVE_TARGET_CPU_$target_cpu for config.m4. * mpn/asm-defs.m4 (define_not_for_expansion): New macro. * mpn/generic/divrem_1n.c (__gmpn_divrem_1n): New file, split from mpn/generic/divrem_1.c. * mpn/generic/divrem_1.c: Ditto. * configure.in (gmp_mpn_functions): Ditto. 2000-02-21 Torbjorn Granlund * gmp.h: Undo 1996-10-06 NeXT change, it was clearly improperly written. 2000-02-21 Linus Nordberg * configure.in: Link /mpn/asm-defs.m4 to mpn/asm.m4. * configure: Regenerate. 2000-02-21 Linus Nordberg * mpn/x86/k7/aorsmul_1.asm: Change OPERATION_ADDMUL --> OPERATION_addmul_1. Change OPERATION_SUBMUL --> OPERATION_submul_1. * mpn/x86/k7/aors_n.asm: Change OPERATION_ADD --> OPERATION_add_n. Change OPERATION_SUB --> OPERATION_sub_n. * mpn/Makefile.am: Pass -DOPERATION_$* to preprocessors. * mpn/Makefile.in: Regenerate. * configure.in: Symlink mpn/asm-defs.m4 to build-dir/mpn. Link multi-function files to mpn/.asm and remove function name from `gmp_mpn_functions'. * configure: Regenerate. * acinclude.m4 (GMP_FINISH): Tell user what we're doing. * aclocal.m4: Regenerate. 2000-02-21 Kevin Ryde * gmp-impl.h: Rename __gmpn_mul_basecase to mpn_mul_basecase and __gmpn_sqr_basecase to mpn_sqr_basecase, remove __gmpn prototypes. * mpn/x86/mul_basecase.S: Ditto. * mpn/x86/pentium/mul_basecase.S: Ditto. * configure.in (gmp_m4postinc): Use x86-defs.m4 on athlon-*-* too. 2000-02-20 Kevin Ryde * acinclude.m4 (GSYM_PREFIX): Drop $1, change by Linus. * mpn/asm-defs.m4 (PROLOGUE,EPILOGUE): Use GSYM_PREFIX as a string, change by Linus. * mpn/x86/x86-defs.m4: Use GSYM_PREFIX as a string. * mpn/x86/k6/gmp-mparam.h: New file. * mpn/asm-defs.m4 (m4_warning): New macro. * mpn/x86/README: Amendments per new code and directories. * mpn/x86/README.family: New file. * mpn/x86/k6/README: New file. * mpn/x86/k7/README: New file. * mpn/generic/mul_n.c: Rename __gmpn_mul_basecase to mpn_mul_basecase and __gmpn_sqr_basecase to mpn_sqr_basecase. * mpn/generic/mul_basecase.c: Ditto. * mpn/generic/sqr_basecase.c: Ditto. * mpn/generic/mul.c: Ditto. 2000-02-19 Linus Nordberg * configure.in: Don't try to symlink more than one multi-func file. * configure: Regenerate. 2000-02-18 Linus Nordberg * acinclude.m4 (GMP_CHECK_ASM_UNDERSCORE): GMP_DEFINE `GSYM_PREFIX'. Run ACTIONs even when value is found in cache. (GMP_CHECK_ASM_ALIGN_LOG): GMP_DEFINE `ALIGN'. Run ACTIONs even when value is found in cache. * aclocal.m4: Regenerate. * configure.in: Don't define GSYM_PREFIX or ALIGN. Add mechanism for multi-function files. * configure: Regenerate. 2000-02-18 Kevin Ryde * configure.in (gmp_m4postinc): Enable x86-defs.m4. * mpn/x86/k7/mul_1.asm: Fix include. * mpn/x86/k6/mul_basecase.S: Removed (copy of the pentium version). * mpn/x86/k6/mul_basecase.asm: New file. * mpn/x86/k6/sqr_basecase.asm: New file. * mpn/x86/k6/com_n.asm: New file. * mpn/x86/k6/copyi.asm: New file. * gmp.texi (Low-level Functions): Clarify mpn overlaps permitted. * gmp-impl.h (MPN_OVERLAP_P): New macro. * gmp-impl.h (assert_nocarry): New macro. * mpn/tests/ref.c: New file, based in part on other mpn/tests/*.c. * mpn/tests/ref.h: New file. 2000-02-17 Linus Nordberg * Makefile.am (dist-hook): Don't include any emacs backup files (*.~*) in dist. * Makefile.in: Regenerate. 2000-02-17 Torbjorn Granlund * mpn/sparc32/v9/mul_1.asm: Use `rd' to get current PC; get rid of getpc function. * mpn/sparc32/v9/addmul_1.asm: Likewise. * mpn/sparc32/v9/submul_1.asm: Likewise. 2000-02-17 Kevin Ryde * gmp.h: Add prototypes and defines for mpn_and_n, mpn_andn_n, mpn_com_n, mpn_copyd, mpn_copyi, mpn_ior_n, mpn_iorn_n, mpn_mul_basecase, mpn_nand_n, mpn_nior_n, mpn_sqr_basecase, mpn_xor_n, mpn_xorn_n. * mpn/asm-defs.m4: Many additions making up initial version. * mpn/asm-defs.m4 (L): Use defn(`LSYM_PREFIX'). * mpn/x86/x86-defs.m4: New file. * mpn/x86/k6/aors_n.asm: New file. * mpn/x86/k6/divmod_1.asm: New file. * mpn/x86/k6/divrem_1.asm: New file. * mpn/x86/k6/lshift.S: Removed (was a copy of the pentium version). * mpn/x86/k6/lshift.asm: New file. * mpn/x86/k6/mod_1.asm: New file. * mpn/x86/k6/mul_1.S: Removed (was a copy of the pentium version). * mpn/x86/k6/mul_1.asm: New file. * mpn/x86/k6/rshift.S: Removed (was a copy of the pentium version). * mpn/x86/k6/rshift.asm: New file. * mpn/x86/k7/aors_n.asm: New file. * mpn/x86/k7/aorsmul_1.asm: New file. * mpn/x86/k7/mul_1.asm: New file. * mpn/x86/k7/rshift.asm: New file. * mpn/x86/p6/aorsmul_1.asm: New file. * mpn/x86/copyi.asm: New file. * mpn/x86/copyd.asm: New file. * mpn/lisp/gmpasm-mode.el: New file. 2000-02-16 Torbjorn Granlund * mpn/sparc32/v9/mul_1.asm: Conditionalize for PIC. * mpn/sparc32/v9/addmul_1.asm: Likewise. * mpn/sparc32/v9/submul_1.asm: Likewise. * mpn/sparc32/v8/supersparc/udiv.asm: Likewise. * mpn/sparc32/udiv_fp.asm: Likewise. 2000-02-16 Linus Nordberg * configure.in: Add mechanism for including target specific m4-files in config.m4. * configure: Regenerate. * acinclude.m4 (GMP_PROG_CCAS): Begin assembly lines (except labels) with a tab character. HP-UX demands it. (GMP_CHECK_ASM_SIZE): Ditto. (GMP_CHECK_ASM_LSYM_PREFIX): Ditto. (GMP_CHECK_ASM_LABEL_SUFFIX): Set to empty string for HP-UX. (GMP_CHECK_ASM_GLOBL): Change `.xport' --> `.export'. * aclocal.m4: Regenerate. 2000-02-16 Linus Nordberg * acinclude.m4 (GMP_CHECK_ASM_LSYM_PREFIX): Define LSYM_PREFIX as the prefix only, no argument. * aclocal.m4: Regenerate. * configure: Regenerate. * mpn/asm-defs.m4 (L): No argument to LSYM_PREFIX. 2000-02-15 Linus Nordberg * acinclude.m4: Prefix all temporary shell variables with `gmp_tmp_'. (GMP_PROG_CC_FIND): Use defaults if no arguments are passed. Quote use of arguments. (GMP_PROG_CCAS): New macro. (GMP_INIT): New macro. (GMP_FINISH): New macro. (GMP_INCLUDE): New macro. (GMP_SINCLUDE): New macro. (GMP_DEFINE): New macro. (GMP_CHECK_ASM_LABEL_SUFFIX): New macro. (GMP_CHECK_ASM_TEXT): New macro. (GMP_CHECK_ASM_DATA): New macro. (GMP_CHECK_ASM_GLOBL): New macro. (GMP_CHECK_ASM_TYPE): New macro. (GMP_CHECK_ASM_SIZE): New macro. (GMP_CHECK_ASM_LSYM_PREFIX): New macro. (GMP_CHECK_ASM_W32): New macro. * aclocal.m4: Regenerate. * configure.in: Find m4 and nm for target. Use new macros to create config.m4. Prefix all temporary shell variables with `tmp_'. Pass `-X 64' to nm for 64-bit PPC target with 64-bit compiler. * configure: Regenerate. * Makefile.am (dist-hook): *Really* remove all CVS dirs in dist. * Makefile.in: Regenerate. * mpn/Makefile.am: Add target for building .lo and .o from .asm. Pass -DPIC to preprocessor (CPP/m4) when building .lo. Build .o a second time for target .lo, without -DPIC to preprocessor. (SUFFIX): Add `.asm'. (EXTRA_DIST): Add asm-defs.m4. * mpn/Makefile.in: Regenerate. * mpf/Makefile.in: Regenerate. * mpf/tests/Makefile.in: Regenerate. * mpq/Makefile.in: Regenerate. * mpq/tests/Makefile.in: Regenerate. * mpz/Makefile.in: Regenerate. * mpz/tests/Makefile.in: Regenerate. 2000-02-15 Torbjorn Granlund * mpn/sparc32/udiv_fp.asm: Change `RODATA' to `DATA'. * mpn/sparc32/v8/supersparc/udiv.asm: Likewise. * mpn/sparc32/v9/addmul_1.asm: Likewise. * mpn/sparc32/v9/submul_1.asm: Likewise. * mpn/sparc32/v9/mul_1.asm: Likewise. * mpn/sparc32/add_n.asm: Rename `size' -> `n'. * mpn/sparc32/sub_n.asm: Likewise. * sparc32: Rename `.s' and `.S' files to `.asm'. * sparc64: Rename `.s' and `.S' files to `.asm'. 2000-02-11 Torbjorn Granlund * config.sub: Adopt to new config.guess sparc naming conventions. * config.guess (sun4u:SunOS:5.*:*): Change `sparc9' to `sparcv9'. * config.guess (sun4m:SunOS:5.*:*): Change to sun4[md]:SunOS:5.*:* and change `sparc8' to `sparcv8'. * mpn/x86/add_n.S: Use PROLOGUE/EPILOGUE. * mpn/x86/sub_n.S: Likewise. * mpn/x86/syntax.h (PROLOGUE): New name for PROLOG. * mpn/x86/syntax.h (EPILOGUE): New name for EPILOG. 2000-02-11 Linus Nordberg * configure.in: Better path for 64-bit sparc without 64-bit cc. Change sparc8 --> sparcv8. Change sparc9 --> sparcv9. * configure: Regenerate. 2000-02-10 Linus Nordberg * configure.in: Use Autoconf. * Makefile.am: New file. * AUTHORS: New file. * COPYING: New file. * acinclude.m4: New file. * acconfig.h: New file. * configure: Generate. * Makefile.in: Generate. * aclocal.m4: Generate. * config.in: Generate. * install.sh: Remove. * install-sh: New file from Automake. * missing: New file from Automake. * ltconfig: New file from Libtool. * ltmain.sh: New file from Libtool. * mpf/Makefile.am: New file. * mpf/Makefile.in: Generate. * mpf/configure.in: Remove. * mpf/tests/Makefile.am: New file. * mpf/tests/Makefile.in: Generate. * mpf/tests/configure.in: Remove. * mpn/Makefile.am: New file. * mpn/Makefile.in: Generate. * mpn/configure.in: Remove. * mpq/Makefile.am: New file. * mpq/Makefile.in: Generate. * mpq/configure.in: Remove. * mpq/tests/Makefile.am: New file. * mpq/tests/Makefile.in: Generate. * mpq/tests/configure.in: Remove. * mpz/Makefile.am: New file. * mpz/Makefile.in: Generate. * mpz/configure.in: Remove. * mpz/tests/Makefile.am: New file. * mpz/tests/Makefile.in: Generate. * mpz/tests/configure.in: Remove. 2000-02-10 Torbjorn Granlund * mpn/x86/add_n.S: Don't use label L0 twice. * mpn/x86/sub_n.S: Likewise. 2000-01-20 Linus Nordberg * demos/pexpr.c: Don't use setup_error_handler() in windoze. 2000-01-19 Torbjorn Granlund * demos/pexpr.c (sigaltstack): #define to sigstack for AIX. (setup_error_handler): Don't write to ss_size and ss_flags on AIX. 2000-01-11 Torbjorn Granlund * mpn/configure.in (hppa2.0*-*-*): Move assignment of target_makefile_frag to where it belongs. 1999-12-21 Torbjorn Granlund * longlong.h (v9 umul_ppmm): New #define. (v9 udiv_qrnnd): New #define. 1999-12-14 Torbjorn Granlund * mpn/generic/divmod_1.c: Use invert_limb. * mpn/generic/mod_1.c: Use invert_limb. * gmp-impl.h (invert_limb): Put definition here. * mpn/generic/divrem.c (invert_limb): Delete definition. * mpn/generic/divrem_2.c (invert_limb): Delete definition. * gmp.h (mpn_divrem): Inhibit for non-gcc. But declare (undo 1999-11-22 change). * gmp-impl.h (DItype,UDItype): Do these also if _LONG_LONG_LIMB. * longlong.h: Move 64-bit hppa code out of __GNUC__ conditional. * stack-alloc.c (HSIZ): New #define. (__tmp_alloc): Use HSIZ instead of sizeof(tmp_stack). 1999-12-10 Torbjorn Granlund * config.sub: Clean up handling of x86 CPUs: Properly recognize Amd CPUs as unique entities. Use manufacturer's names of processors ("pentium", etc); still match ambiguous names like "i586", "i686", "p6" but be conservative in interpreting them. * configure.in: Recognize x86 CPU types known by config.guess. * mpn/configure.in: Likewise. Add x86/mmx path component as appropriate. (athlon-*-*): Fix typo. * config.guess: Update x86 recog code to initially match more than just i386. Call K6-2 and K6-III for "k62" and "k63" respectively. * config.guess: Recognize x86 CPU types. Update code for FreeBSD, NetBSD, OpenBSD, Linux. 1999-12-08 Torbjorn Granlund * mpf/pow_ui.c: Avoid final squaring in loop. 1999-12-07 Torbjorn Granlund * gmp-impl.h (udiv_qrnnd_preinv2gen): Prefix local variables with `_'. (udiv_qrnnd_preinv2norm): Likewise. From Kevin Ryde: (HAVE_ALLOCA): #define also if defined (alloca). 1999-12-04 Torbjorn Granlund * mpn/tests/add_n.c: Set OPS from CLOCK. * mpn/tests/sub_n.c: Likewise. * mpn/tests/mul_1.c: Likewise. * mpn/tests/addmul_1.c: Likewise. * mpn/tests/submul_1.c: Likewise. * mpn/tests/lshift.c: Update from add_n.c. * mpn/tests/rshift.c: Likewise. 1999-12-03 Torbjorn Granlund * mpn/powerpc64/copy.S: New file. 1999-12-02 Torbjorn Granlund * mpn/sparc64/copy.s: New file. * mpn/tests/copy.c: New file. * mpn/configure.in: Recognize more Amd CPUs; Set special paths for k7 CPU. * configure.in: Recognize Amd x86 CPUs. * mpz/fdiv_r_2exp.c: In rounding code, read in->_mp_size before writing to res->_mp_size. * mpn/powerpc64/*.S: Clean up assembly syntax, add function headers. * mpn/powerpc64/gmp-mparam.h: (KARATSUBA_MUL_THRESHOLD): #define. (KARATSUBA_SQR_THRESHOLD): #define. * mpn/tests/add_n.c (main): Only print test number if TIMES==1 and not printing. (main): Don't run reference code if NOCHECK. * mpn/tests/sub_n.c: Likewise. * mpn/tests/mul_1.c: Likewise. * mpn/tests/addmul_1.c: Likewise. * mpn/tests/submul_1.c: Likewise. * mpn/tests/lshift.c: (main): Only print test number if TIMES==1 and not printing. * mpn/tests/rshift.c: Likewise. 1999-11-22 Torbjorn Granlund * gmp.h (mpz_init_set_str): Declare using __gmp_const. (mpz_set_str): Likewise. (mpf_init_set_str): Likewise. (mpf_set_str): Likewise. (mpn_set_str): Likewise. (__gmp_0): Likewise. (mpn_divrem): Remove separate declaration; it's defined later in this file. * gmp.h: Replace "defined (__STD__)' by (__STDC__-0) in expressions involving more than one term, to handle Sun's compiler that most helpfully sets __STDC__ to 0. * gmp-impl.h: Likewise. * longlong.h: Likewise. 1999-11-21 Torbjorn Granlund * mpn/sparc64/gmp-mparam.h (KARATSUBA_MUL_THRESHOLD): #define. (KARATSUBA_SQR_THRESHOLD): #define. * mpn/sparc64/lshift.s: Compensate stack references for odd stack ptr. * mpn/sparc64/rshift.s: Likewise. * mpn/sparc64/addmul_1.s: Propagate carry properly. * mpn/sparc64/submul_1.s: Likewise. * mpn/sparc64/sub_n.s: Rewrite. * mpn/sparc64/sub_n.s: Get operand order for main subcc right (before scrapping this code for new code). 1999-11-20 Torbjorn Granlund * mpn/sparc64/add_n.s: Rewrite. 1999-11-17 Torbjorn Granlund * mpn/x86/syntax.h (PROLOG): New #define. (EPILOG): New #define. * gmp.h (mpn_addsub_n): Declare. * gmp.h (mpn_add_nc): Declare. * gmp.h (mpn_sub_nc): Declare. * mpn/powerpc64/addsub_n.S: New file. 1999-11-17 Torbjorn Granlund * mpn/alpha/gmp-mparam.h (KARATSUBA_MUL_THRESHOLD): Only #define #ifndef. (KARATSUBA_SQR_THRESHOLD): Likewise. 1999-11-14 Torbjorn Granlund * mpn/x86/mul_1.S: Unroll and optimize for P6 and K7. 1999-11-09 Torbjorn Granlund * mpn/x86/p6/gmp-mparam.h (KARATSUBA_MUL_THRESHOLD): Only #define #ifndef. (KARATSUBA_SQR_THRESHOLD): Likewise. 1999-11-05 Torbjorn Granlund * mpn/generic/addsub_n.c: New file. 1999-11-02 Torbjorn Granlund * config.guess: Handle alpha:FreeBSD with alpha:NetBSD. * configure.in (vax*-*-*): New case. * config/mt-vax: New file. * mpn/vax/add_n.s: Rewrite. * mpn/vax/sub_n.s: Rewrite. 1999-10-31 Torbjorn Granlund * mpn/vax/rshift.s: New file. * mpn/vax/lshift.s: New file. 1999-10-29 Torbjorn Granlund * config.sub: Handle k5 and k6. * mpn/configure.in: Recognize k6. * mpf/tests/t-get_d.c (LOW_BOUND, HIGH_BOUND): New #defines. (main): Tighten error bounds to 14 digits. * longlong.h (default umul_ppmm, when smul_ppmm exists): Rename __m0 => __xm0, __m1 => __xm1. (default smul_ppmm): Likewise. 1999-10-11 Torbjorn Granlund * config.guess: Reverse the test for POWER vs PowerPC. * config.guess (sun4m:SunOS:5.*:*): New case. * config.guess (sun4u:SunOS:5.*:*): New case. 1999-09-29 Torbjorn Granlund * mpn/generic/divrem_2.c: Clean up comments. 1999-09-23 Torbjorn Granlund * mpz/tests/Makefile.in: Use move-if-change when generating binaries. * mpf/tests/Makefile.in: Likewise. * mpq/tests/Makefile.in: Likewise. * mpz/tests/move-if-change: New file. * mpf/tests/move-if-change: New file. * mpq/tests/move-if-change: New file. * gmp.h (mpn_incr_u): New macro (from mpn/generic/mul_n.c). (mpn_decr_u): New macro. * mpn/generic/mul_n.c (mpn_incr): Delete. * mpn/generic/mul_n.c: Update usages mpn_incr => mpn_incr_u. * mpn/generic/divrem_newt.c: Use mpn_incr_u and mpn_decr_u instead of mpn_add_1 and mpn_sub_1. * mpn/generic/sqrtrem.c: Likewise. * mpz/cdiv_q_ui.c: Likewise. * mpz/cdiv_qr_ui.c: Likewise. * mpz/fdiv_q_ui.c: Likewise. * mpz/fdiv_qr_ui.c: Likewise. * mpn/generic/sqrtrem.c: Start single-limb Newton iteration from 18 bits. 1999-07-27 Torbjorn Granlund * mpn/generic/divrem_1.c (__gmpn_divrem_1n): New function. * mpn/generic/divrem_2.c: New file, code from divrem.c, `case 2:'. * mpn/Makefile.in: Compile divrem_2.c. * make.bat: Compile divrem_2.c. * mpn/configure.in (functions): Add divrem_2. * gmp.h: Declare mpn_divrem_2. * mpn/generic/divrem.c: Delete special cases, handle just divisors of more than 2 limbs. * gmp.h (mpn_divrem): Call mpn_divrem_1, mpn_divrem_2, as appropriate. * mpn/generic/divrem.c: Rework variable usage for better register allocation. 1999-07-26 Torbjorn Granlund * mpn/alpha/ev5/add_n.s: Rewrite for better ev6 speed. * mpn/alpha/ev5/sub_n.s: Likewise. 1999-07-21 Torbjorn Granlund * longlong.h (alpha): Define umul_ppmm for cc. * gmp-impl.h (DItype, UDItype): Define for non-gcc if _LONGLONG is defined. 1999-07-15 Torbjorn Granlund * longlong.h (powerpc64 count_leading_zeros): Fix typo. (powerpc64 add_ssaaaa): Fix typos. (powerpc64 sub_ddmmss): Fix typos. 1999-07-14 Torbjorn Granlund * mpz/tests/Makefile.in: Pass XCFLAGS when linking. * mpf/tests/Makefile.in: Likewise. * mpq/tests/Makefile.in: Likewise. * mpn/Makefile.in (.S.o): Pass XCFLAGS. * longlong.h: Add support for 64-bit PowerPC. * config.sub: Handle "powerpc64". * configure.in: Likewise. * mpn/configure.in: Suppress use of config/t-ppc-aix for now, it seems compiler passes proper options. * mpn/powerpc64/*.S: New files. * Makefile.in (FLAGS_TO_PASS): Pass "AR=$(AR)". 1999-07-07 Torbjorn Granlund * demos/pexpr.c (factor): Change alloca call to a malloc/free pair. * mpn/powerpc32/syntax.h: Add #define's for crN. * gmp.h (gmp_rand_algorithm): Remove spurious `,'. 1999-07-05 Torbjorn Granlund * mpn/generic/divrem_1.c: Normalize divisor when needed. 1999-07-02 Torbjorn Granlund * mpn/configure.in (powerpc*-apple-mach): New configuration. * mpn/powerpc32/*: Add support for apple-macho syntax. * mpn/powerpc32/syntax.h: New file. * gmp-impl.h: Don't use `__attribute__' syntax for Apple's perversion of GCC. 1999-05-26 Linus Nordberg * rand.c (gmp_rand_init): Fix typo. * mpn/generic/rawrandom.c (mpn_rawrandom): Count bits, not limbs, to keep track of how many rounds to do in loop. Clean up temporary allocation. Update `seedsize' inside loop. Mask off the correct number of bits from final result. Init `mcopyp' even when not normalizing `m'. * randlc.c (gmp_rand_init_lc): Fix typo (don't call mpz_init_set_ui()). * mpn/generic/rawrandom.c (mpn_rawrandom): Set SIZ(s->seed) when reallocating. * tests/rand/Makefile (test, bigtest): Add 33-bit tests. * tests/rand/gen.c (main): Set precision of variable passed to mpf_urandomb(). Add option `-p'. 1999-05-25 Linus Nordberg * randcm.c: Remove. * randcmui.c: Remove. * Makefile.in: Remove randcm and randcmui. * make.bat: Ditto. * gmp-impl.h: Remove prototypes for __gmp_rand_init_common() and __gmp_rand_init_common_ui(). * randlc.c (gmp_rand_init_lc): Don't call __gmp_rand_init_common(). * randlcui.c (gmp_rand_init_lc_ui): Don't call __gmp_rand_init_common_ui(). * gmp.h (__gmp_rand_state_struct): Remove unused member `maxval'. * randclr.c (gmp_rand_clear): Remove reference to s->maxval. * randcm.c (__gmp_rand_init_common): Ditto * mpn/generic/rawrandom.c (mpn_rawrandom): Don't calculate nlimbs twice. * gmp.h (__gmp_rand_dist): Remove. 1999-05-24 Linus Nordberg * mpn/generic/rawrandom.c: Clean up comments. * gmp.texi: Add documentation for random number generation. 1999-05-21 Linus Nordberg * gmp.h: Typedef `gmp_rand_state' as an array with one element. Change prototypes accordingly. * gmp-impl.h: Change prototypes using `gmp_rand_state'. * rand.c (gmp_rand_init): Take `gmp_rand_state' as argument instead of a pointer to a `gmp_rand_state'. * mpf/urandom.c (mpf_urandomb): Ditto. * mpz/urandom.c (mpz_urandomb): Ditto. * mpn/generic/rawrandom.c (mpn_rawrandom): Ditto. * randcmui.c (__gmp_rand_init_common_ui): Ditto. * randlc.c (gmp_rand_init_lc): Ditto. * randlcui.c (gmp_rand_init_lc_ui): Ditto. * randui.c (gmp_rand_init_ui): Ditto. * randcm.c (__gmp_rand_init_common): Ditto. * randclr.c (gmp_rand_clear): Ditto. * tests/rand/gen.c (main): Pass `s' to rand-funcs instead of address of `s'. 1999-05-20 Linus Nordberg * Makefile.in: Rename randi.c --> rand.c, randi_lc.c --> randlc.c, randicom.c --> randcm.c. Add randui.c, randcmui.c, randlcui.c. * make.bat: Ditto. * gmp.h: Add prototypes for gmp_rand_init_ui() and gmp_rand_init_lc_ui(). * gmp-impl.h: Add prototypes for __gmp_rand_init_common() and __gmp_rand_init_common_ui(). * randlc.c, randcm.c, randclr.c, rand.c: Change #include of to "gmp.h". * randclr.c: Include stdlib.h for free(). * rand.c: Include gmp-impl.h. 1999-05-12 Torbjorn Granlund * mpn/configure.in: Put generic m68k alternative last. 1999-05-04 Torbjorn Granlund * demos/pexpr.c (setup_error_handler): Use sigemptyset to create empty set (for portability). (fns): Fix typo '#if #if'. (mpz_eval_expr): Implement FERMAT and MERSENNE. * demos/pexpr.c: Cast longjmp argument via long to silent warnings on 64-bit hosts. 1999-05-03 Torbjorn Granlund * demos/pexpr.c: Add #defines for GMP 1.x and 2.0 compatibility. * demos/pexpr.c (setup_error_handler): New function; take signal handler setup code from main(), with major modifications to use modern signal interface. (main): Remove signal handler setup code; call setup_error_handler. 1999-04-29 Linus Nordberg * tests/rand/findcl.c (main): Add option '-i' for interval factor. Separate v and merit lose figures. Add '-v' for version. 1999-04-28 Linus Nordberg * tests/rand/statlib.c: Change debugging stuff. * tests/rand/gmpstat.h: Add debug values definitions. * tests/rand/findcl.c (main): Print low and high merit on startup. Print version string on startup. Catch SEGV and HUP. Add option -d for debug. Fix bug making test for v too hard. (sh_status): New function. (sh_status): Flush stdout. Add RCSID. 1999-04-27 Linus Nordberg * tests/rand/Makefile (clean): Add target. 1999-04-27 Linus Nordberg * tests/rand/stat.c: Include gmpstat.h. Add global int g_debug. * tests/rand/spect.c: Include . * tests/rand/findcl.c (main): Input is `m', not all factors of `m'. Print only the very first matching multiplier. Include . Flush stdout. Print "done." when done. * tests/rand/spect.c: Move everything but main() to statlib.c. * tests/rand/findcl.c: New file. * tests/rand/gmpstat.h: New file. * tests/rand/statlib.c (merit, merit_u, f_floor, vz_dot, spectral_test): New functions. 1999-04-27 Torbjorn Granlund * mpn/configure.in: Fix typo, "sparc-*)" was "sparc)". 1999-04-21 Torbjorn Granlund * config.sub: Recognize ev6. 1999-04-12 Linus Nordberg * urandom.c: Split up into randclr.c, randi.c, randi_lc.c, randicom.c. * randclr.c, randi.c, randi_lc.c, randicom.c: New files. * Makefile.in: Remove urandom. Add randclr, randi, randi_lc, randicom. * make.bat: Ditto 1999-03-31 Torbjorn Granlund * configure.in (sparc9-*-solaris2.[789]*, etc): New alternative. * mpn/configure.in: Use mt-sprc9 also for ultrasparc*-*-solaris2*. 1999-03-30 Linus Nordberg * urandom.c (__gmp_rand_scheme): Change NULL->0. Include "gmp.h" instead of . 1999-03-29 Linus Nordberg * gmp.h (__gmp_rand_data_lc): Now holds a, c, m instead of scheme struct. (__gmp_rand_lc_scheme_struct): Remove mpz_t's `a' and `m'. * tests/rand/stat.c (f_freq): Don't print 2nd level results if doing 1st level. * tests/rand/gen.c (main): Set default algorithm to mpz_urandomb. (main): Add option -c. 1999-03-24 Linus Nordberg * tests/rand/Makefile (GMPINC): Rename to GMPH. (GMPH): Add gmp-mparam.h. (CFLAGS): Add -I$(GMPLIBDIR)/mpn 1999-03-23 Linus Nordberg * Makefile.in: Compile top-dir/urandom.c. * make.bat: Ditto. * mpn/Makefile.in: Compile rawrandom.c. * make.bat: Ditto. * mpn/configure.in (functions): Add rawrandom. * gmp.h (__gmp_rand_scheme_struct): Rename to __gmp_rand_lc_scheme_struct. (__gmp_rand_data_lc): Remove member 'n'. Allocate a __gmp_rand_lc_scheme_struct instead of a pointer to one. Add prototype for gmp_rand_init_lc(), mpn_rawrandom(). New prototype for mpz_urandomb(). * urandom.c: New file. (__gmp_rand_init_common): New function. (gmp_rand_init_lc): New function. (gmp_rand_init): Don't init data_lc->n. Call gmp_rand_init_lc() and __gmp_rand_init_common(). (gmp_rand_clear): Remove reference to data_lc->n. * mpz/urandom.c (gmp_rand_init, gmp_rand_clear): Move to new file urandom.c in top-dir. (mpz_urandomb): Add function parameter nbits. Call mpn_rawrandom(). * mpf/urandom.c (mpf_urandomb): Call mpn_rawrandom(). * mpn/generic/rawrandom.c: New file. (mpn_rawrandom): New function. 1999-03-17 Torbjorn Granlund * extract-dbl.c: When packing result, adjust exp when sc == 0. * mpf/tests/t-get_d.c: New file. * mpf/tests/Makefile.in: Compile t-get_d.c. 1999-03-16 Linus Nordberg * mpz/urandom.c (__gmp_rand_scheme): Add extra braces around the mpz_t members. * make.bat: Compile mpz/urandom.c and mpf/urandom.c * tests/rand/statlib.c (ks_table): Use mpf_pow_ui() and exp(). * tests/rand/gen.c: Include unistd.h for getopt. 1999-03-15 Linus Nordberg * mpz/urandom.c (gmp_rand_init): New function. (gmp_rand_clear): New function. (mpz_urandomb): New function. * mpz/Makefile.in: Compile urandom.c * mpf/urandom.c (mpf_urandomb): New function. * mpf/Makefile.in: Compile urandom.c. * gmp.h (__gmp_rand_state_struct, __gmp_rand_scheme_struct): New structs for randomization functions. (gmp_rand_dist, gmp_rand_alogrithm): New enums for randomization functions. (mpz_urandomb, mpf_urandomb): Add prototype. (gmp_rand_init, gmp_rand_clear): Add prototype. * tests/rand/gen.c, stat.c, statlib.c, statlib.h: New files. * tests/rand/Makefile, tests/rand/ChangeLog: New files. 1999-03-15 Torbjorn Granlund * .gdbinit: New file. * mpz/dump.c: New file. * mpz/Makefile.in: Compile dump.c. * make.bat: Likewise. * gmp.h (mpz_dump): Declare. 1999-03-14 Torbjorn Granlund * mpz/tests/reuse.c: Also test mpz_invert and mpz_divexact. * mpz/tests/convert.c: Update to GMP 2 variable syntax. 1999-03-13 Torbjorn Granlund * mpf/README: New file. * mpz/README: New file. * mpf/pow_ui.c: New file. * mpf/Makefile.in: Compile pow_ui.c. * make.bat: Likewise. * gmp.h (mpf_pow_ui): Declare. 1999-03-12 Torbjorn Granlund * mpn/configure.in: Stage 1 of rewrite. * mpn/underscore.h: New name for bsd.h. * mpn/sysv.h: Deleted. * mpn/m68k/*: Don't include sysdep.h. * mpn/pa64/README: New file. 1999-03-11 Torbjorn Granlund * mpn/powerpc32/add_n.S: Add support for both AIX and ELF syntax. Renamed from `.s'. * mpn/powerpc32/sub_n.S: Likewise. * mpn/powerpc32/lshift.S: Likewise. * mpn/powerpc32/rshift.S: Likewise. * mpn/powerpc32/mul_1.S: Likewise. * mpn/powerpc32/addmul_1.S: Likewise. * mpn/powerpc32/submul_1.S: Likewise. * mpn/powerpc32/umul.S: New file. * mpn/sparc32/v8/umul.S: New file. * mpn/sparc32/umul.S: New file. * mpn/x86/umul.S: New file. * mpn/x86/udiv.S: New file. * mpn/Makefile.in (mul_basecase.o): Delete rule. 1999-02-22 Torbjorn Granlund * configure.in (hppa2.0*-*-*): Force use of GCC. * extract-dbl.c: Handle IEEE denormalized numbrs. Clean up. 1998-12-02 Torbjorn Granlund * mpn/Makefile.in (CCAS): New macro. (.s.o): Use CCAS. (.S.o): Likewise. * mpn/Makefile.in (mul_basecase.o): Add dependency. (sqr_basecase.o): Likewise. (mod_1.o): Likewise. * demos/pexpr.c (cputime): Test also __hpux. (cleanup_and_exit): Check SIGXCPU only #ifdef LIMIT_RESOURCE_USAGE. * mpz/tests/t-2exp.c: Use urandom, not random. * mpn/configure.in (arm*-*-*): New alternative. 1998-11-30 Torbjorn Granlund * gmp-impl.h (union ieee_double_extract): Special case for little-endian arm. (LIMBS): Alias for PTR. 1998-11-26 Torbjorn Granlund * longlong.h (m68000 umul_ppmm): Use `muluw', not `mulu'. (m68k stuff): Clean up; add coldfire support. 1998-11-23 Torbjorn Granlund * mpn/mips3/gmp-mparam.h (KARATSUBA_MUL_THRESHOLD): #define. (KARATSUBA_SQR_THRESHOLD): #define. * mpn/sparc32/v9/README: New file. 1998-11-20 Torbjorn Granlund * mpn/x86/README: New file. * mpn/arm/gmp-mparam.h: New file. * mpn/pa64/gmp-mparam.h: New file. * mpn/hppa/gmp-mparam.h: New file. * mpn/x86/pentium/gmp-mparam.h: New file. * mpn/sparc32/v9/gmp-mparam.h: New file. * mpn/powerpc32/gmp-mparam.h: New file. * mpn/x86/p6/gmp-mparam.h: New file. * mpn/alpha/gmp-mparam.h (KARATSUBA_MUL_THRESHOLD): #define. (KARATSUBA_SQR_THRESHOLD): #define. * mpn/configure.in: Point to x86/p6 when appropriate. * mpn/power/umul.s: New file. * mpn/power/sdiv.s: New file. * mpn/pa64/addmul_1.S: New file. * mpn/pa64/submul_1.S: New file. * mpn/pa64/mul_1.S: New file. * mpn/pa64/udiv_qrnnd.c: New file. * mpn/pa64/umul_ppmm.S: New file. * mpn/mips2/umul.s: New file. * mpn/m68k/mc68020/umul.s: New file. * mpn/m68k/mc68020/udiv.s: New file. * mpn/hppa/hppa1_1/umul.s: New file. * mpn/alpha/umul.s: New file. * mpn/a29k/udiv.s: New file. * mpn/a29k/umul.s: New file. 1998-11-17 Torbjorn Granlund * mpn/x86/mul_basecase.S: New file for non-pentiums. * mpn/x86/mul_basecase.S: Move to mpn/x86/pentium. 1998-11-16 Torbjorn Granlund * make.bat: Compile mul_basecase.c and sqr_basecase.c. 1998-11-10 Torbjorn Granlund * mpz/invert.c: Defer writing to parameter `invert' until end. 1998-11-03 Torbjorn Granlund * mpn/pa64/udiv_qrnnd.c: Handle more border cases. 1998-10-29 Torbjorn Granlund * insert-dbl.c: Special case biased exponents < 1; Get boundary for Inf right. * longlong.h (COUNT_LEADING_ZEROS_NEED_CLZ_TAB): New #define. 1998-10-28 Torbjorn Granlund * mpn/powerpc32/submul_1.s: Rewrite, optimizing for PPC604. * mpn/powerpc32/addmul_1.s: Likewise. * mpn/powerpc32/lshift.s: Likewise. 1998-10-23 Torbjorn Granlund * config/mt-sprc9-gcc (XCFLAGS): Add -Wa,-xarch=v8plus. * mpn/sparc32/v9/submul_1.s: New file. 1998-10-21 Torbjorn Granlund * mpn/config/mt-pa2hpux: New file. * mpn/configure.in (hppa2.0*-*-*): Use new 64-bit code. * config.sub: Recognize hppa2.0 as CPU type. * longlong.h (64-bit hppa): Add umul_ppmm and udiv_qrnnd. * mpn/pa64/mul_1.S: New file. * mpn/pa64/addmul_1.S: New file. * mpn/pa64/submul_1.S: New file. * mpn/pa64/umul_ppmm.S: New file. * mpn/pa64/udiv_qrnnd.c: New file. 1998-10-20 Torbjorn Granlund * mpz/pprime_p.c: Pass 1L, not 1, to mpz_cmp_ui. * mpz/fdiv_q_2exp.c: Cast `long' argument to `mp_limb_t' for mpn calls. * mpz/gcd_ui.c: Likewise. * mpz/add_ui.c: Likewise. * mpz/sub_ui.c: Likewise. 1998-10-19 Torbjorn Granlund * mpn/generic/bdivmod.c: Avoid using switch statement with mp_limb_t index. 1998-10-17 Torbjorn Granlund * mpn/sparc32/v9/mul_1.s: Misc cleanups. * mpn/sparc32/v9/addmul_1.s: Misc cleanups. 1998-10-16 Torbjorn Granlund * mpn/tests/{add,sub,}mul_1.c: Print xlimb using mpn_print. * mpz/tests/t-powm.c (SIZE): Increase to 50. (EXP_SIZE): New parameter; use it for computing exp_size. 1998-10-15 Torbjorn Granlund * mpn/generic/divrem_newt.c: Use TMP_ALLOC interface. * mpn/generic/sqrtrem.c: Check BITS_PER_MP_LIMB before defining assembly variants of SQRT. 1998-10-14 Torbjorn Granlund * mpn/tests: Clean up timing routines. Don't include longlong.h where it is not needed. (mpn_print): Handle printing when _LONG_LONG_LIMB. * mpn/tests/{add,sub,}mul_1.c: Generate xlimb with mpn_random2 and do it whether TIMES != 1 or not. * mpn/generic/mul_n.c: Delay assignment of `sign' for lower register pressure. * mpn/sparc32/v9/mul_1.s: New file. * config/mt-sprc9-gcc: New file. * configure.in: Use it. * mpn/configure.in: Use sparc64 for Solaris 2.7 and later with a sparc v9 CPU. * mpn/configure.in: Use sparc32/v9 for Solaris 2.6 or earlier with a sparc v9 CPU. * mpf/sub.c: In initial code for ediff == 0, limit precision before jumping to `normalize'. 1998-10-13 Torbjorn Granlund * mpn/hppa/hppa2_0/add_n.s: New file. * mpn/hppa/hppa2_0/sub_n.s: New file. * mpn/configure.in: Handle hppa2.0 (32-bit code for now). * config.guess: Update from egcs 1.1. (9000/[3478]??:HP-UX:*:*): Properly return 2.0 for all known 2.0 machines. 1998-10-07 Torbjorn Granlund * mpz/root.c (mpz_root): New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_root): Declare. * mpz/perfpow.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_perfect_power_p): Declare. * mpz/remove.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_remove): Declare. * mpz/bin_ui.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_bin_ui): Declare. * mpz/bin_uiui.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_bin_uiui): Declare. 1998-09-16 Torbjorn Granlund * longlong.h: Test for __powerpc__ in addition to _ARCH_PPC. Sat Sep 5 17:22:28 1998 Torbjorn Granlund * mpf/cmp_si.c: Compare most significant mantissa limb before trying to deduce anything from the limb count. * mpf/cmp_ui.c: Likewise. Tue Aug 18 10:24:39 1998 Torbjorn Granlund * mpz/pprime_p.c (mpz_probab_prime_p): Add new code block for doing more dividing. Sat Aug 15 18:43:17 1998 Torbjorn Granlund * mpn/generic/divrem_newt.c: New name for divrem_newton.c. * mpn/Makefile.in: Corresponding changes. * mpn/configure.in: Likewise. Wed Aug 12 23:07:09 1998 Torbjorn Granlund * config.guess: Handle powerpc for NetBSD. Tue Jul 28 23:10:55 1998 Torbjorn Granlund * mpz/fib_ui.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_fib_ui): Declare. Wed Jun 17 22:52:58 1998 Torbjorn Granlund * make.bat: Fix typo, `asm-synt.h' => `asm-syntax.h'. Wed Jun 3 11:27:32 1998 Torbjorn Granlund * config/mt-pwr: New file. * config/mt-ppc: New file. * configure.in: Use the new files. Tue Jun 2 13:04:17 1998 Torbjorn Granlund * mpn/sparc32/v9/addmul_1.s: New file. * mpn/config/mt-sprc9: New file. * mpn/configure.in: Use mt-sprc9. Tue May 26 11:24:18 1998 Torbjorn Granlund * demos/factorize.c (factor_using_pollard_rho): Pass correct parameters in recursive calls; join the two recursion arms. * mpf/set_q.c: Set result sign. When normalizing the numerator, don't allow it to increase in size beyond prec. Tue May 19 17:28:14 1998 Torbjorn Granlund * demos/factorize.c (factor_using_division): Call fflush also for the factor 2. Mon May 18 15:51:01 1998 Torbjorn Granlund * make.bat: Pass -fomit-frame-pointer. Do not pass -g. Tue May 5 01:42:50 1998 Torbjorn Granlund * mpz/Makefile.in (LOCAL_CC): Remove definition. * gmp.h: Get rid of GMP_SMALL stuff. * mpz/Makefile.in: Likewise. * mpq/Makefile.in: Likewise. * mpf/Makefile.in: Likewise. * mpz/invert.c: Fix typo in comment. Mon May 4 23:05:32 1998 Torbjorn Granlund * mpn/generic/sqrtrem.c: Check that __arch64__ is not defined before defining sparc SQRT. Mon Apr 20 19:16:17 1998 Torbjorn Granlund * mpn/generic/gcdext.c: Allow gp to be NULL. 1998-04-03 Torbjorn Granlund * mpn/configure.in: Recognize `alphaev5*', not `alphaev5'. * config.guess: Handle CPU variants for NetBSD. Mon Mar 16 13:07:54 1998 Torbjorn Granlund * mpz/pprime_p.c: Use mpn_mod_1/mpn_preinv_mod_1 for computing mod PP, not mpz_tdiv_r_ui (which expects an `unsigned long'). (mpz_probab_prime_p): Change type of `r' to mp_limb_t. Thu Mar 12 17:19:04 1998 Torbjorn Granlund * gmp.h (mpf_ceil, mpf_floor, mpf_trunc): Add declarations. * config.guess: Update from FSF version. * config.sub: Likewise. * config.guess: Add special handling of alpha-*-NetBSD. Wed Mar 11 00:55:34 1998 Torbjorn Granlund * mpz/inp_str.c: Update from set_str.c. Properly increment `nread' when skipping minus sign. * mpz/set_str.c: Check for empty string after having skipped leading zeros. Mon Mar 9 19:28:00 1998 Torbjorn Granlund * mpz/set_str.c: Skip leading zeros. Wed Mar 4 19:29:16 1998 Torbjorn Granlund * gmp.h (mpz_cmp_si): Cast argument before calling mpz_cmp_ui. * demos/factorize.c: Rewrite. 1998-02-04 Torbjorn Granlund * configure.in (i[3456]86* etc): Check if using gcc before choosing mt-x86. * configure.in (m68*-*-*): New alternative. * config/mt-m68k: New file. * mpn/alpha/invert-limb.s: Put tables in text segment, since not all systems support "rdata". Wed Feb 4 02:20:57 1998 Torbjorn Granlund * gmp.h (__GNU_MP_VERSION_SNAP): New #define. (__GNU_MP_VERSION_MINOR): Now 1. Wed Jan 28 22:29:36 1998 Torbjorn Granlund * longlong.h (alpha udiv_qrnnd): #define UDIV_NEEDS_NORMALIZATION. Wed Jan 28 20:28:19 1998 Torbjorn Granlund * mpz/pprime_p.c (mpz_probab_prime_p): Delete 59 from tried divisors. Mon Jan 26 01:39:02 1998 Torbjorn Granlund * mpz/pprime_p.c (mpz_probab_prime_p): Major overhaul: Check small numbers specifically; check small factors, then perform a fermat test. Tue Jan 13 14:58:28 1998 Torbjorn Granlund * longlong.h (alpha udiv_qrnnd): Call __mpn_invert_normalized_limb and udiv_qrnnd_preinv. Wed Jan 7 01:52:54 1998 Torbjorn Granlund * mpn/configure.in (alpha*, extra_functions): Add invert-limb and remove udiv_qrnnd. * mpn/tests/divrem.c: Get allocations right. * mpn/generic/divrem.c: Conditionally pre-invert most significant divisor limb. Tue Jan 6 23:08:54 1998 Torbjorn Granlund * mpn/generic/divrem_1.c: Rename variables to comply to conventions. Make `i' have type `mp_size_t'. Tue Dec 30 22:21:42 1997 Torbjorn Granlund * mpz/tdiv_qr_ui.c: Return the remainder. * mpz/tdiv_r_ui.c: Likewise. * mpz/tdiv_q_ui.c: Likewise. * gmp.h: Change return type of mpz_tdiv_qr_ui, mpz_tdiv_r_ui, mpz_tdiv_q_ui. * mpz/tdiv_ui.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_tdiv_ui): Declare. Fri Nov 7 04:21:15 1997 Torbjorn Granlund * mpf/integer.c (FUNC_NAME): Fix bogus test for mpf_trunc. * demos/isprime.c: New file. Sat Nov 1 19:32:25 1997 Torbjorn Granlund * mpz/cmp_abs.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_cmp_abs): Declare. * mpz/cmp_abs_ui.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_cmp_abs_ui): Declare. Sat Sep 27 04:49:52 1997 Torbjorn Granlund * mpz/fdiv_r_2exp.c: Get allocation for `tmp' right. * mpz/fdiv_q_2exp.c: In final result adjustment code, handle that intermediate result is zero. * mpz/tests/t-2exp.c: New file. * mpz/tests/Makefile.in: Handle t-2exp.c. Fri Sep 26 16:29:21 1997 Torbjorn Granlund * mpz/divexact.c: Fix typo in test for whether to copy numerator to quotient and move that statement to after handling quotient and denominator overlap. Misc cleanups. * mpn/generic/gcd.c: Change count argument of mpn_lshift/mpn_rshift calls to `unsigned int'. * mpz/divexact.c: Likewise. Mon Sep 22 02:19:52 1997 Torbjorn Granlund * mpz/tests/t-powm.c: Decrease `reps' to 2500. * mpz/tests/t-pow_ui.c: New file. * mpz/tests/Makefile.in: Handle t-pow_ui.c. * mpz/ui_pow_ui.c: Get special cases for exponent and base right. * mpz/pow_ui.c: Increase temp space allocation by 1 limb. Split `rsize' into two variables; compute space allocation into `ralloc'. Sun Sep 7 04:15:12 1997 Torbjorn Granlund * mpn/pa64/lshift.s: New file. * mpn/pa64/rshift.s: New file. * mpn/pa64/sub_n.s: New file. Sat Sep 6 19:14:13 1997 Torbjorn Granlund * mpn/pa64/add_n.s: New file. * mpn/pa64: New directory. Tue Aug 19 16:17:09 1997 Torbjorn Granlund * mpz/swap.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_swap): Declare. * mpn/generic/mul_n.c: Push assignment of x and y pointers into the if/else clauses in several places. (Decreases register pressure.) Mon Aug 18 03:29:50 1997 Torbjorn Granlund * mpn/thumb/add_n.s: New file. * mpn/thumb/sub_n.s: New file. * mpn/arm/add_n.s: New file. * mpn/arm/sub_n.s: New file. * mpz/powm.c: After mpn_mul_n and mpn_mul calls, adjust product size if most significant limb is zero. * mpz/powm_ui.c: Likewise. Fri Aug 15 02:13:57 1997 Torbjorn Granlund * mpn/arm/m/mul_1.s: New file. * mpn/arm/m/addmul_1.s: New file. * mpn/powerpc32/mul_1.s: Rewrite. * mpn/alpha/mul_1.s: Prefix labels with `.'. Mon Aug 11 02:37:16 1997 Torbjorn Granlund * mpn/powerpc32/add_n.s: Rewrite. * mpn/powerpc32/sub_n.s: Rewrite. Sun Aug 10 17:07:15 1997 Torbjorn Granlund * mpn/powerpc32/addmul_1.s: Delete obsolete comments. * mpn/powerpc32/submul_1.s: Likewise. Fri Jul 25 20:07:54 1997 Torbjorn Granlund * mpz/addmul_ui.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_addmul_ui): Declare. * mpz/setbit.c: Add missing code after final `else'. Tue Jul 22 17:45:01 1997 Torbjorn Granlund * mpn/sh/add_n.s: Fix typo. * mpn/sh/sub_n.s: Likewise. * longlong.h (ns32k count_trailing_zeros): Fix typo. * insert-dbl.c: Check for exponent overflow and return Inf. * mpz/get_d.c: Rewrite to avoid rounding errors. Thu May 29 11:51:07 1997 Torbjorn Granlund * mpq/add.c: Swap some usages of tmp1 and tmp2 to make sure their allocation suffices. * mpq/sub.c: Likewise. Wed Apr 16 02:24:25 1997 Torbjorn Granlund * demos/pexpr.c: New file. * mpn/generic/mul_n.c: Misc optimizations from Robert Harley. * gmp-impl.h (MPZ_PROVOKE_REALLOC): New #define. Sat Apr 12 17:54:04 1997 Torbjorn Granlund * mpz/tstbit.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_tstbit): Declare. * mpz/tests/logic.c: Use MPZ_CHECK_FORMAT. * mpz/tests/bit.c: New test. * mpz/tests/Makefile.in: Handle bit.c. * mpz/ior.c: In -OP2,+OP1 case, normalize OP2 after call to mpn_sub_1. * gmp-impl.h (MPZ_CHECK_FORMAT): New #define. Thu Apr 10 00:30:14 1997 Torbjorn Granlund * longlong.h (POWER/PowerPC): Test _ARCH_PWR instead of _IBMR2. Wed Apr 9 18:23:31 1997 Torbjorn Granlund * gmp-impl.h: Move defaulting of UMUL_TIME and UDIV_TIME from here... * longlong.h: ...to here. Sun Mar 30 12:16:23 1997 Torbjorn Granlund * mpn/generic/next_prime.c: New file. * mpn/generic/perfsqr.c: Remove definitions of PP and PP_INVERTED. * gmp-impl.h: Put them here. Fri Mar 28 08:18:05 1997 Torbjorn Granlund * gmp-impl.h (MPN_COPY_INCR, MPN_COPY_DECR): Define as inline asm for for x86, but leave disabled for now. Fri Feb 28 02:39:47 1997 Torbjorn Granlund * mpn/Makefile.in (.S.o): Pass SFLAGS and CFLAGS also to compiler for assembly phase. (.s.o): Pass SFLAGS. Wed Feb 26 06:46:08 1997 Torbjorn Granlund * mpn/configure.in: For Pentium Pro, use default code, not Pentium optimized code. * mpn/x86/addmul_1.S: Unroll and optimize for Pentium Pro. * mpn/x86/submul_1.S: Likewise. Thu Feb 13 08:26:09 1997 Torbjorn Granlund * mpf/Makefile.in: Compile floor.o, ceil.o and trunc.o (from integer.c). * make.bat: Likewise. Wed Feb 5 05:58:44 1997 Torbjorn Granlund * mpn/configure.in (alpha*): Add cntlz to extra_functions. Wed Feb 4 03:30:45 1997 Torbjorn Granlund * mpf/integer.c: New file (supporting mpf_floor, mpf_ceil, mpf_trunc). Mon Feb 3 14:21:36 1997 Torbjorn Granlund * make.bat: Fix typo, set_dfl_prc => set_dfl_prec. Sun Feb 2 02:34:33 1997 Torbjorn Granlund * mpf/out_str.c: After outputting `-', decrement n_digits. Wed Jan 8 02:50:20 1997 Torbjorn Granlund * mpn/generic/divrem.c: qextra_limbs => qxn. Wed Dec 18 07:50:46 1996 Torbjorn Granlund * mpz/tests/t-tdiv.c (SIZE): Increase to 200. Tue Dec 17 19:32:48 1996 Torbjorn Granlund * mpn/generic/divrem.c (mpn_divrem_classic): New name for mpn_divrem. * gmp.h (mpn_divrem): New function. * mpn/generic/divrem_newton.c: New file. * mpn/configure.in (functions): Add divrem_newton. * make.bat: Likewise. Thu Dec 12 17:55:13 1996 Torbjorn Granlund * gmp.h (_GMP_H_HAVE_FILE): Test also __dj_include_stdio_h_. Sat Dec 7 09:40:06 1996 Torbjorn Granlund * mpn/alpha/invert-limb.s: New file. Thu Dec 5 01:25:31 1996 Torbjorn Granlund * mpz/ui_pow_ui.c (mpz_pow2): New (static) function. (mpz_ui_pow_ui): Rewrite. * make.bat: `pre_mod_1.c' => `pre_mod_.c'. Fix typo in path to gmp-mpar.h. Fri Nov 15 00:49:55 1996 Torbjorn Granlund * mpz/ui_pow_ui.c: Rewrite for better speed. Fri Nov 1 16:36:56 1996 Torbjorn Granlund * Makefile.in (recursive make rules): Use `&&' instead of `;' as delimiter. Fri Oct 25 17:12:36 1996 Torbjorn Granlund * gmp-impl.h (Cray/uxp MPN_COPY): Really declare as inline. Thu Oct 24 15:08:19 1996 Torbjorn Granlund * mpn/fujitsu/rshift.c: Fix typo in loop boundaries. Fri Oct 18 03:13:54 1996 Torbjorn Granlund * mpn/configure.in: Recognize `nextstep' for m68k variants; likewise for x86 variants. * mpn/x86/syntax.h (INSND): New macro. * mpn/x86/[lr]shift.S: Use INSND. * mpn/x86/pentium/[lr]shift.S: Likewise. * mpn/config/t-oldgas (SFLAGS): Pass -DOLD_GAS. * gmp-impl.h: In code for determining endianness, test also __BIG_ENDIAN__ and __hppa__. Remove test of __NeXT__. Wed Oct 16 03:50:34 1996 Torbjorn Granlund * mpf/set_str.c: Let `prec' determine precision used in exponentiation code; decrease allocation accordingly. * mpn/vax: Change `jsob*' to `sob*' in all files. Tue Oct 15 03:54:06 1996 Torbjorn Granlund * longlong.h (m88110 udiv_qrnnd): Change type of intermediate quotient to DImode (divu.d generates a 64-bit quotient). * configure.in (m88110*): Fix typo. * mpf/get_str.c: Compute exp_in_base using `double' to avoid overflow. * gmp-impl.h (struct bases): Change type of chars_per_bit_exactly from float to double. * mpn/mp_bases.c (__mp_bases): Give 17 digits for chars_per_bit_exactly field. * mpf/get_str.c: Let `prec' determine precision used in exponentiation code; decrease allocation accordingly. Sun Oct 13 03:31:53 1996 Torbjorn Granlund * longlong.h: Major cleanup. (__udiv_qrnnd_c): Compute remainders using multiply and subtract, not explicit `%' operator. (C umul_ppmm): Get rid of a redundant __ll_lowpart. * mpz/invert.c: Properly detect all operands that would yield an undefined inverse; make sure the inverse is always positive. * mpz/xor.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_xor): Declare. * mpz/tests/logic.c: Also test mpz_xor. * mpz/lcm.c: Special case for when either operand equals 0. Sat Oct 12 01:57:09 1996 Torbjorn Granlund * mpn/generic/gcd.c (find_a): Don't inline on x86. * Makefile.in (CFLAGS): Default to just `-g'. * configure.in: Recognize 386 and 486 wherever other x86 cpus are recognized. * configure.in: Use mt-x86 for all x86 cpus. * config/mt-x86: New file. * mpn/alpha/cntlz.s: New file. Tue Oct 8 00:16:18 1996 Torbjorn Granlund * longlong.h: Define smul_ppmm for Fujitsu vpp/uxp. Rewrite umul_ppmm to actually work on the hardware. * mpn/x86/sub_n.S: Avoid parens around displacement of `leal'. * mpn/x86/add_n.S: Likewise. * mpn/x86/syntax.h (R): Define differently depending on __STDC__. Mon Oct 7 16:48:08 1996 Torbjorn Granlund * longlong.h: Don't test for __NeXT__ in outer 68k conditional; add test for __m68k__. Sun Oct 6 00:59:09 1996 Torbjorn Granlund * gmp.h: Declare mpn_random. * make.bat: Compile mpn/generic/random.c. * longlong.h: Define umul_ppmm for Fujitsu vpp/uxp. * gmp-impl.h: Protect definitions using `__attribute__ ((mode (...)))' with test also for __GNUC_MINOR__. * gmp.h: Don't define macros using __builtin_constant_p when using NeXT's compiler. Fri Oct 4 16:53:50 1996 Torbjorn Granlund * mpz/lcm.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h (mpz_lcm): Declare. Wed Sep 25 00:06:21 1996 Torbjorn Granlund * mpq/tests/t-cmp_ui.c: Make sure numerator and denominator of `b' is within limits of an `unsigned long int'. * mpz/tests/t-powm_ui.c: Change type of exp2 to `unsigned long int'. Tue Sep 24 18:58:20 1996 Torbjorn Granlund * mpz/powm_ui.c: Make result always positive. * urandom.h (urandom): Make it return mp_limb_t. * gmp-impl.h (CNST_LIMB): New macro. * mpn/mp_bases.c: Use CNST_LIMB. * mpn/generic/hamdist.c (popc_limb): Likewise. * mpn/generic/popcount.c (popc_limb): Likewise. * mpn/generic/perfsqr.c: Likewise. Fri Sep 20 03:08:10 1996 Torbjorn Granlund * mpz/pprime_p.c: When n <= 3, don't clear out n before using it. Wed Sep 18 11:22:45 1996 Torbjorn Granlund * mpn/fujitsu/mul_1.c: New file. * mpn/fujitsu/addmul_1.c: New file. * mpn/fujitsu/sub_n.c: New file. * mpn/fujitsu/add_n.c: Mew file. Sun Sep 15 03:13:02 1996 Torbjorn Granlund * mpn/generic/random.c: New file. * mpn/configure.in (functions): Add `random'. * gmp-impl.h (MPN_COPY): Define as annotated inline function for Crays and Fujitsu VPPs. * gmp.h (mp_size_t): Define as `int' for non-MPP Cray. (mp_exp_t): Likewise. * configure.in: Add support for Fujitsu VPP machines. * mpn/configure.in: Likewise. * config.guess: Likewise. * config.sub: Likewise. * mpn/fujitsu/rshift.c: New file. * mpn/fujitsu/lshift.c: New file. * mpn/fujitsu: New directory, for Fujitsu VPP machines. Wed Sep 11 11:34:38 1996 Torbjorn Granlund * mpn/generic/mul_n.c (__gmpn_mul_n): New name for impn_mul_n. Call __gmpn_mul_basecase, not impn_mul_n_basecase; update parameter list to work with __gmpn_mul_basecase. (__gmpn_sqr): New name for impn_sqr_n. Call __gmpn_sqr_basecase, not impn_sqr_n_basecase; update parameter list to work with __gmpn_sqr_basecase. (mpn_mul_n): Update calls to match new names and parameter conventions. * gmp-impl.h (MPN_MUL_N_RECURSE): Likewise. (MPN_SQR_RECURSE): New name for MPN_SQR_N_RECURSE. Update calls to match new names and parameter conventions. * mpn/generic/mul.c: Never perform multiply explicitly here, call __gmpn_mul_basecase instead. Update calls to match new names and parameter conventions. * mpn/x86/mul_basecase.S: New file. * mpn/generic/mul_basecase.c: New file. * mpn/generic/sqr_basecase.c: New file. Wed Sep 4 02:59:21 1996 Torbjorn Granlund * mpz/set_str.c: Let `0b' and `0B' mean base 2. Fri Aug 30 00:44:00 1996 Torbjorn Granlund * longlong.h (x86 umul_ppmm): Work around GCC bug that was triggered by Aug 28 change. * mpbsd/min.c (digit_value_in_base): New function. * mpz/set_str.c: Refine allocation size computation, use chars_per_bit_exactly instead of chars_per_limb. * mpbsd/Makefile.in (.c.o): Add -D_mpz_realloc=_mp_realloc. Wed Aug 28 02:52:14 1996 Torbjorn Granlund * longlong.h (x86 umul_ppmm): Don't cast result operands. (x86 udiv_qrnnd): Likewise. (default smul_ppmm): Fix typo, umul_ppmm => smul_ppmm. (default umul_ppmm): New #define using smul_ppmm. (vax smul_ppmm): New #define. (vax umul_ppmm): Delete. (POWER umul_ppmm): Delete. (IBM 370 smul_ppmm): New #define. (IBM 370 umul_ppmm): Delete. (IBM RT/ROMP smul_ppmm): New #define. (IBM RT/ROMP umul_ppmm): Delete. Tue Aug 27 01:03:25 1996 Torbjorn Granlund * gmp-impl.h (__gmp_0): Make it `const'. * mpn/Makefile.in (clean mostlyclean): Comment out recursive clean of `tests'. * mpn/generic/mul.c: Identify when we do squaring, and call impn_sqr_n_basecase/impn_sqr_n as appropriate. Use KARATSUBA_MUL_THRESHOLD and KARATSUBA_SQR_THRESHOLD. Don't #define KARATSUBA_THRESHOLD. * mpn/generic/mul_n.c: Don't #define KARATSUBA_THRESHOLD. (impn_mul_n, impn_sqr_n): Rewrite, based on code contributed by Robert Harley. (impn_sqr_n_basecase): Rewrite. * gmp-impl.h (KARATSUBA_MUL_THRESHOLD): New #define. (KARATSUBA_SQR_THRESHOLD): Likewise. (MPN_SQR_N_RECURSE): Use KARATSUBA_SQR_THRESHOLD. (MPN_MUL_N_RECURSE): Use KARATSUBA_MUL_THRESHOLD. * configure.in: Fix typo in last change. Mon Aug 26 22:25:18 1996 Torbjorn Granlund * mpn/generic/random2.c: Fix typo, `alpha__' => `__alpha'. * mpf/random2.c: Likewise. Sun Aug 25 00:07:09 1996 Torbjorn Granlund * mpz/tests/t-mul.c: Also test squaring. Fri Aug 16 05:12:08 1996 Torbjorn Granlund * mp_clz_tab.c (__clz_tab): Declare as `const'. * version.c (gmp_version): Likewise. * mpn/generic/sqrtrem.c (even_approx_tab, odd_approx_tab): Likewise. Thu Aug 15 02:34:47 1996 Torbjorn Granlund * gmp.h: Fix typo, `mips__' => `__mips'. * mpf/set_str.c: Allow a number to start with a period, if next position contains a digit. Tue Aug 13 18:41:25 1996 Torbjorn Granlund * mpz/gcdext.c: Get cofactor sign right for negative input operands. Clean up code for computing tt. * mpz/invert.c: Get rid of variable `rv'. * mpz/divexact.c: Test for zero divisor in special case for zero dividend. Mon Aug 12 18:04:07 1996 Torbjorn Granlund * mpz/?div_*_ui.c: Special case for division by 0. * mpz/tdiv_q.c: Likewise. Sat Aug 10 14:45:26 1996 Torbjorn Granlund * mpz/dmincl.c: Special case for division by 0. * mpz/tdiv_*_ui.c: Delete special case for dividend being 0; handle it when computing size after mpn_divmod_1 call. * mp_bpl.c: (__gmp_junk): New variable. (__gmp_0): New constant. * gmp-impl.h (DIVIDE_BY_ZERO): New #define. Fri Aug 9 20:03:27 1996 Torbjorn Granlund * mpz/divexact.c: Test for dividend being zero before testing for small divisors. Thu Aug 8 13:20:23 1996 Torbjorn Granlund * configure.in: Require operating system specification for cpus where assembly syntax differs between system. * Makefile.in (many targets): Change `-' action prefix to `@'. * mpn/Makefile.in: (distclean): Fix typo. * mpq/cmp_ui.c: Rename function to _mpq_cmp_ui. (mpq_cmp_ui): #undef deleted. * mpz/cmp_si.c: Rename function to _mpz_cmp_si. (mpz_cmp_si): #undef deleted. * mpz/cmp_ui.c: Rename function to _mpz_cmp_ui. (mpz_cmp_ui): #undef deleted. * Makefile.in: Corresponding changes. * mpf/get_prc.c: Return the *highest* precision achievable. * mpf/get_str.c: Complete rewrite. * mpf/set_str.c (swapptr): New #define. (assert): New #define. * mpf/set_str.c: Set prec to one more than the saved _mp_prec. Misc cleanups. * mpz/set_str.c: #include string.h. * mpf/out_str.c: #include string.h. * mpbsd/xtom.c: #include string.h and ctype.h. * mpbsd/mout.c: #include string.h. Wed Aug 7 11:46:04 EDT 1996 Ken Weber * mpn/generic/gcd.c: Reorder mpn_gcd argument list. * mpz/gcd.c: Change call to mpn_gcd. * gmp.texi: Update manual entry on mpn_gcd. * mpn/generic/bdivmod.c: Delete limb cache to make mpn_bdivmod reentrant. Wed Aug 7 02:15:38 1996 Torbjorn Granlund * mpf/get_str.c: Rewrite code for converting integral part of a number with both an integral and fractional part. * mpf/set_str.c: Get rid of variable xxx. New variables madj and radj. In exp_in_base==0 case, add madj to msize for EXP field. * mpz/tests/t-gcd.c: Test deleted. Rename t-gcd2.c to t-gcd.c. Increase reps to 2000. * mpz/tests/t-gcd2.c: Get rid of mpz_refgcd. * mpf/set_str.c: Ignore excess limbs in MP,MSIZE. Thu Jul 25 04:39:10 1996 Torbjorn Granlund * mpn/configure.in: Fix typo in setting path, "sparc" => "sparc32". Wed Jul 24 02:27:02 1996 Torbjorn Granlund * mpn/generic/gcdext.c: Reorganize and clean up. Get rid of all signed limb arithmetic. Mon Jul 22 02:39:56 1996 Torbjorn Granlund * mpn/generic/gcdext.c (mpn_gcdext): For large enough operands, work with most significant *two* limbs. (div2): New function (two variants). (THRESHOLD): New #define. * mpz/gcdext.c: Fix typo in MPZ_TMP_INIT call. * longlong.h (alpha UMUL_TIME): Now 30. (alpha UDIV_TIME): Now 350. (x86 UMUL_TIME): Now 10 (let Pentium decide). (SuperSPARC UDIV_TIME): Override default. * extract-dbl.c (MP_BASE_AS_DOUBLE): Don't redefine here. * extract-dbl.c: New name for extract-double.c. * insert-dbl.c: New name for insert-double.c. * Makefile.in: Corresponding changes. * make.bat: Likewise. * mpz/Makefile.in (.c.o): Don't pass non-portable `-f' to cp. * mpq/Makefile.in: Likewise. * mpf/Makefile.in: Likewise. Sat Jul 20 01:35:18 1996 Torbjorn Granlund * mpz/getlimbn.c: Take ABS of integer->_mp_size. * mpz/divexact.c: Use mpn_divmod_1 if divisor is a single limb. Thu Jul 18 00:31:15 1996 Torbjorn Granlund * mpn/generic/popcount.c (popc_limb): Use different masking trick for first step (due to David Seal). * mpn/generic/hamdist.c (popc_limb): Likewise. Wed Jul 17 23:21:48 1996 Torbjorn Granlund * mpn/generic/divrem.c: In MPN_COPY_DECR call, copy dsize - 1 limbs. Sun Jul 14 17:47:46 1996 Torbjorn Granlund * configure.in: Handle sparc9, sparc64, and ultrasparc like sparc8. Thu Jul 11 14:05:54 1996 J.T. Conklin * longlong.h (mc680x0): Define umul_ppmm, udiv_qrnnd, sdiv_qrnnd for the '020, '030, '040, and '332. Define count_leading_zeros for the '020, '030, '040, and '060. Sun Jul 14 15:24:53 1996 Torbjorn Granlund From Joe Keane: * mpq/equal.c: Take ABS of num1_size before passing it to mpn_cmp. Fri Jul 12 17:11:17 1996 Torbjorn Granlund * mpn/generic/sqrtrem.c (SQRT): New asm for x86, but leave it disabled for now. * mpn/generic/sqrtrem.c: Use MP_BASE_AS_DOUBLE. Wed Jul 10 03:17:45 1996 Torbjorn Granlund * cre-mparam.c: Delete obsolete file. * gmp.h: #define _LONG_LONG_LIMB if __mips && _ABIN32. * longlong.h: Test __mips instead of __mips__. Sun Jul 7 23:19:13 1996 Torbjorn Granlund * longlong.h (_PROTO): Define, unless already defined. (alpha __udiv_qrnnd): Declare using _PROTO. (hppa __udiv_qrnnd): Likewise. (sparc __udiv_qrnnd): Likewise. Mon Jul 1 01:44:30 1996 Torbjorn Granlund * config.guess: Update from master version; add Cray x90 handling. Wed Jun 26 05:35:02 1996 Torbjorn Granlund * mpn/power/add_n.s (__mpn_add_n): Work around GAS bug. * mpn/power/sub_n.s (__mpn_sub_n): Likewise. * insert-double.c: Rework loop to avoid potential overflow. * mpq/get_d.c: For vax, if qsize > N_QLIMBS, ignore excess limbs. * mpq/tests/t-get_d.c (SIZE): Special case for vax. * gmp.h (mpX_cmp_ui): #define also when ! __GNUC__. Mon Jun 24 17:13:21 1996 Torbjorn Granlund * longlong.h (vax sdiv_qrnnd): Fix typo. Sat Jun 15 01:33:33 1996 Torbjorn Granlund * gmp.h: Support `small' and `large' type and function variants, controlled by GMP_SMALL. * mpz/Makefile.in (.c.o): Compile each function twice, for small and large variant. (MPZS_OBJS): New variable. (libmpz.a): Include MPZS_OBJS in archive. * mpf/Makefile.in: Analogous changes. * mpq/Makefile.in: Analogous changes. * gmp.h: Prefix all functions with __gmp, to allow namespace-clean internal calls. * mp.h: Rip out __MP_SMALL__ stuff. (__mpz_struct): mp_size_t => int. * mpz/invert.c: #include "gmp-impl.h". Use MPZ_TMP_INIT, not mpz_init. * mpz/gcdext.c: Rewrite to call mpn_gcdext. Fri Jun 14 18:05:29 1996 Torbjorn Granlund * mpn/generic/gcdext.c (s0size): New parameter. * gmp.h (mpn_gcdext): Update prototype. * mpn/generic/gcdext.c: Major rewrite. Mon Jun 10 00:14:27 1996 Torbjorn Granlund * mpn/generic/dump.c: Add missing `else'. Fri Jun 7 03:35:12 1996 Torbjorn Granlund * Makefile.in (gmp_toc.html): Pass -expandinfo to texi2html. Thu Jun 6 19:00:53 1996 Torbjorn Granlund * Version 2.0.2 released. * install.sh: New file. * Makefile.in (INSTALL): Use install.sh. (install-normal): New name for target `install'. (install): New dummy target. * mpz/pow_ui.c: Swap tests for (e == 0) and (bsize == 0). * mpz/ui_pow_ui.c: Swap tests for (e == 0) and (blimb == 0). * config/mt-linux (AR_FLAGS): New file. * configure.in: Use config/mt-linux for all linux systems. Tue Jun 4 03:42:18 1996 Torbjorn Granlund * Version 2.0.1 released. * mpf/tests/ref.c: Cast result of TMP_ALLOC to the right pointer type. * extract-double.c: Test _GMP_IEEE_FLOATS with #if, not plain if. * insert-double.c: Don't #include stdlib.h. * gmp-impl.h (union ieee_double_extract): Test sparc and __sparc. Do not test __sparc__. * mpf/reldiff.c: Change declaration to work around irix5 compiler bug. * mpq/equal.c: Likewise. * mpn/generic/gcd.c: Delete spurious comma at end of enumeration. * mpn/generic/gcdext.c: Add K&R declaration syntax. * stack-alloc.h: Likewise. * insert-double.c: Likewise. * extract-double.c: Likewise. * mpf/tests/reuse.c: Likewise. * mpz/tests/reuse.c: Likewise. * mpf/tests/t-sub.c: Likewise. * mpf/tests/t-add.c: Likewise. * mpf/tests/t-muldiv.c: Likewise. * mpf/tests/t-conv.c: Likewise. * mpf/tests/ref.c: Likewise. * mpn/config/t-oldgas: Renamed from t-freebsd. * mpn/configure.in: Use t-oldgas for freebsd, netbsd, and some linux configurations. * mpn/powerpc32/mul_1.s: Really clear cy before entering loop. * mpn/powerpc32/*.s: Fix power/powerpc syntax issues. * mpn/config/t-ppc-aix: New file. * mpn/configure.in: Use t-ppc-aix for powerpc like t-pwr-aix for power. Wed May 29 02:07:31 1996 Torbjorn Granlund * gmp.h (mp_bits_per_limb): Change qualifier from `const' to __gmp_const. * gmp.h (mpf_init_set_str): Add `const' qualifier for 2nd parameter. * mpf/iset_str.c: Likewise. Mon May 27 00:15:58 1996 Torbjorn Granlund * gmp-impl.h: Declare __gmp_extract_double. * mpz/set_q.c: Delete unused variables. * gmp.h (mpq_equal): Declare. * mpf/eq.c: mpf_cmp2 -> mpf_eq. Fri May 24 03:20:44 1996 Torbjorn Granlund * mpz/iset_d.c: Don't include . * insert-double.c (__gmp_scale2): New name for scal2. * mpz/get_d.c: Corresponding change. * mpf/get_d.c: Likewise. * mpq/get_d.c: Likewise. * gmp-impl.h: Declare __gmp_scale2. * mpn/generic/scan0.c: Clarify comment. * mpz/set_q.c: New file. * Makefile.in: Compile it. * make.bat: Likewise. * gmp.h: Declare mpz_set_q. * insert-double.c: New file. * Makefile.in: Compile it. * make.bat: Likewise. * mpz/get_d.c: New file. * mpz/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h: Declare mpz_get_d. * mpf/get_d.c: New file. * mpf/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h: Declare mpf_get_d. * make.bat: Compile things in alphabetical order. * gmp-impl.h (MP_BASE_AS_DOUBLE): New #define. (LIMBS_PER_DOUBLE): New #define. * extract-double.c: New file. * Makefile.in: Compile it. * make.bat: Likewise. * mpz/set_d.c: Rewrite to use __gmp_extract_double. * mpf/set_d.c: Likewise. * mpn/configure.in: Use t-pwr-aix also for aix 3.2.4 and up. Wed May 22 02:48:35 1996 Torbjorn Granlund * gmp-impl.h: Rework code for defining ieee_double_extract. (IEEE_DOUBLE_BIG_ENDIAN): Macro removed. (_GMP_IEEE_FLOATS): New macro. * mpn/vax/gmp-mparam.h: Delete. * mpn/config/t-pwr-aix: New file. * mpn/configure.in: Use t-pwr-aix for aix 4 and later. Mon May 20 16:30:31 1996 Torbjorn Granlund * gmp.h: In code for setting _GMP_H_HAVE_FILE, test more symbols. * mpf/tests/t-add.c (oo): Add some `l' printf modifiers. * mpf/tests/t-sub.c (oo): Likewise. * mpf/tests/t-conv.c (oo): Likewise. * mpf/tests/t-sqrt.c (oo): Likewise. * mpz/tests/t-mul.c (_mpn_mul_classic): Remove unused variables. * mpn/{pyr,i960,clipper}/*.s: Add missing copyright headers. Fri May 17 02:24:43 1996 Torbjorn Granlund * mpz/set_d.c: Call _mpz_realloc. * mpq/set_z.c: New file. * mpq/Makefile.in: Compile it. * make.bat: Likewise. * gmp.h: Declare mpq_set_z. * mp?/Makefile.in (libmp?.a): Depend on Makefile, not Makefile.in. * mpf/Makefile.in (test): Delete spurious target. * mpq/Makefile.in (test): Likewise. * mpf/out_str.c: Use `e' to separate exponent when base <= 10. * mpn/configure.in: Treat ultrasparc just like sparc v8, until 64-bit compilers are ready. * mpf/set_d.c: Make it work for 64-bit machines. Thu May 16 20:53:57 1996 Torbjorn Granlund * gmp-impl.h: Set IEEE_DOUBLE_BIG_ENDIAN to 0 for little-endian machines. * mpn/x86/gmp-mparam.h: Delete file. * configure.in: Treat microsparc like sparc8. * urandom.h: Test __alpha instead of __alpha__, since the former is the standard symbol. * mpn/generic/random2.c: Likewise. * mpf/random2.c: Likewise. Tue May 14 13:42:39 1996 Torbjorn Granlund (tege@tiny.matematik.su.se) * mpz/set_f.c: New file. * mpz/Makefile.in: Compile it. * gmp.h: Declare mpz_set_f. * mpf/set_q.c: Simplify expression in rsize == nsize if-then-else arms. Tue May 14 13:03:07 1996 Torbjorn Granlund (tege@tiny.matematik.su.se) * make.bat: Add all new files. Sun May 12 22:24:36 1996 Torbjorn Granlund * mpf/set_z.c: New file. * mpf/Makefile.in: Compile it. * gmp.h: Declare mpf_set_z. Sat May 11 19:26:25 1996 Torbjorn Granlund * gmp.h: Declare mpf_set_q. * mpf/set_q.c: Compute prec-1 limbs in mpn_divrem call. Fri May 10 17:37:38 1996 Torbjorn Granlund * mpf/set_q.c: New file. * mpf/Makefile.in: Compile it. * config.sub: Recognize sparc8. Wed May 8 09:19:11 1996 Torbjorn Granlund * mpf/tests/t-dm2exp.c: New file. * mpf/tests/t-add.c: Correct header comment. * mpf/tests/t-sub.c: Likewise. * mpf/tests/t-sqrt.c: Likewise. * mpf/div.c: Misc variable name cleanups. * mpf/div_ui.c: Base more closely on mpf/div.c. * mpf/ui_div.c: Likewise. * mpz/tests/Makefile.in (check): Depend on Makefile. * mpq/tests/Makefile.in (check): Likewise. * mpf/tests/Makefile.in (check): Likewise. * mpf/tests/t-muldiv.c: New file. * mpf/tests/Makefile.in: Compile and run `t-muldiv'. (t-ref.o): Delete spurious rule. * mpf/sqrt.c: Properly detect negative input operand. * mpf/sqrt_ui.c: Delete spurious header comment. * mpf/sqrt.c: Likewise. * mpz/sqrt.c: Likewise. * mpz/tests/reuse.c (main): Read `reps' from command line. * mpf/tests/reuse.c: New file. * mpf/tests/Makefile.in: Compile and run `reuse'. * mpf/mul_ui.c: Disable code for removing low zero limbs. * mpf/div.c: Fix condition for when vp and qp overlaps. * mpf/add_ui.c: When sum equals u, copy up to prec+1 limbs. * mpf/out_str.c: Don't output '\n' after exponent. * mpf/add_ui.c: New special case for when U is completely cancelled. Wed Apr 24 05:33:28 1996 Torbjorn Granlund * Version 2.0 released. * All files: Update FSF's address. * Makefile.in (gmp_toc.html): New name for gmp.html. (TAGS): Depend on force. * mpf/tests/t-conv.c: Pass -base to mpf_set_str. Sat Apr 20 03:54:06 1996 Torbjorn Granlund * Makefile.in (ps): New target, depend on gmp.ps. Fri Apr 19 14:03:15 1996 Torbjorn Granlund * mpf/out_str.c: Print `@' before exponent, not `e'. * make.bat: Update from Makefiles. Thu Apr 18 01:22:05 1996 Torbjorn Granlund * mpf/set_str.c: If parameter `base' is negative, expect exponent to be decimal, otherwise in the same base as the mantissa. Wed Apr 17 17:28:36 1996 Torbjorn Granlund * mpf/set_dfl_prec.c: Don't return anything. * gmp.h: Corresponding changes. * mpf/set_dfl_prec.c: Use `unsigned long int' for bit counts. * mpf/init2.c: Likewise. * mpf/get_prc.c: Likewise. * mpf/set_prc.c: Likewise. * mpf/set_prc_raw.c: Likewise. * mpz/popcount.c: Likewise. * mpz/hamdist.c: Likewise. * mpz/scan1.c: Likewise. * mpz/scan0.c: Likewise. * mpn/generic/popcount.c: Likewise. * mpn/generic/hamdist.c: Likewise. * mpn/generic/scan1.c: Likewise. * mpn/generic/scan0.c: Likewise. * gmp.h: Likewise. * mpf/eq.c: New file, based on mpf/diff.c. * mpf/diff.c: Delete. * mpf/Makefile.in: Corresponding changes. * gmp.h: Likewise. * mpf/reldiff.c: New file. * mpf/Makefile.in: Compile it. * gmp.h: Declare mpf_reldiff. * mpz/iset_d.c: New file. * mpz/Makefile.in: Compile it. * gmp.h: Declare mpz_init_set_d. Tue Apr 16 16:28:31 1996 Torbjorn Granlund * Makefile.in (gmp.html): Pass -acc to texi2html. Mon Apr 15 16:20:24 1996 Torbjorn Granlund * mpf/set_str.c: Switch off code for defaulting the base from the leading characters. * gmp.h (mp?_sign): Delete. (mp?_sgn): New macros. Fri Apr 12 17:23:33 1996 Torbjorn Granlund * Makefile.in (gmp.dvi): Delete tmp.* at end of rule. Wed Apr 10 22:52:02 1996 Torbjorn Granlund (tege@tiny.matematik.su.se) * mpf/random2.c: Change of `exp' param, mp_size_t => mp_exp_t. * gmp.h: Corresponding change. * gmp.h (mp_bits_per_limb): Make it const. Sat Mar 30 01:20:23 1996 Torbjorn Granlund * configure.in: Re-enable recognition of with_gcc. * mpf/Makefile.in (.c.o): Pass XCFLAGS. * mpn/Makefile.in (.c.o): Likewise. * mpz/Makefile.in (.c.o): Likewise. * mpq/Makefile.in (.c.o): Likewise. * mpbsd/Makefile.in (.c.o): Likewise. * mpf/tests/Makefile.in (.c.o): Likewise. * mpz/tests/Makefile.in (.c.o): Likewise. * mpq/tests/Makefile.in (.c.o): Likewise. * Makefile.in (XCFLAGS): Default to empty. (FLAGS_TO_PASS): Pass on XCFLAGS. (.c.o): Pass XCFLAGS. * config/mt-m88110 (XCFLAGS): Define instead of CC. * config/mt-sprc8-gcc (XCFLAGS): Likewise. * config/mt-supspc-gcc (XCFLAGS): Likewise. * configure: Don't default CC to "gcc -O2" is -with-gcc=no was specified. Mon Mar 25 01:07:54 1996 Torbjorn Granlund * urandom.h: Test for __SVR4 in addition to __svr4__. * mp_bpl.c (mp_bits_per_limb): Declare as `const'. * Makefile.in (CFLAGS): `-O2' => `-O'. * mpn/Makefile.in (CFLAGS): Likewise. * gmp-impl.h: Get rid of obsolete field access macros. * mpn/mp_bases.c (__mp_bases): 1e39 => 1e38 to work around Solaris cc compiler bug. * gmp.h (__MPN): Make it work also for non-ANSI compilers. Thu Mar 21 01:07:54 1996 Torbjorn Granlund * mpf/sub.c: New special case for ediff <= 1 before generic code. Simplify generic code for ediff == 0. Rename uexp => exp. Mon Mar 11 18:24:57 1996 Torbjorn Granlund * mpf/tests/*.c: Use ref_mpf_sub for error calculation. * mpf/tests/Makefile.in: Link ref.o to all executables. * mpf/tests/t-sub.c: Make u = v + 1 with 50% probability. Sun Mar 10 21:03:17 1996 Torbjorn Granlund (tege@tiny.matematik.su.se) * mpf/get_str.c: In digit development loop for fractions, change loop condition from `<' to `<='. Thu Mar 7 04:58:11 1996 Torbjorn Granlund * mpn/mp_bases.c (__mp_bases): 1e100 => 1e39 to avoid overflow warning. Wed Mar 6 01:10:42 1996 Torbjorn Granlund * mpf/tests/t-sqrt.c: New file. * mpf/tests/Makefile.in: Corresponding changes. * mpf/sqrt.c: Special case for square root of zero. * mpq/add.c: Clean up variable names. * mpq/sub.c: Update from mpq/add.c. * mpz/divexact.c: abs => ABS. * mpz/gcd.c: Likewise. Rewrite final fixup code, to decrease allocation. Misc cleanups. Tue Mar 5 22:24:56 1996 Torbjorn Granlund * mpn/configure.in: Recognize linuxoldld as a synonym for linuxaout. * gmp.h (mpn_add, mpn_add_1, mpn_sub, mpn_sub_1): Add prototypes. * mpn/configure.in: Use t-freebsd also for netbsd. Mon Mar 4 15:13:28 1996 Torbjorn Granlund * mpq/Makefile.in (cmp.o): Depend on longlong.h. * mpq/equal.c: New file. * mpq/Makefile.in: Corresponding changes. * mpf/tests/t-add.c: New file. * mpf/tests/t-sub.c: Renamed from t-addsub.c. * mpf/tests/ref.c: New file. * mpf/tests/Makefile.in: Corresponding changes. * gmp-impl.h (SIZ, ABSIZ, PTR, EXP, PREC, ALLOC): New #defines. Sun Mar 3 07:45:46 1996 Torbjorn Granlund * mpf/set_str.c: In exponentiation code, allocate 3 extra limbs, not just 2. * mpf/get_str.c: Allocate sufficient space for tstr. When calculating exp_in_base, round result down. * mpf/tests/t-conv.c: New file. * mpf/tests/Makefile.in: Corresponding changes. * mp_bpl.c: New file. * gmp.h: Declare it. * Makefile.in: Corresponding changes. Sat Mar 2 06:27:56 1996 Torbjorn Granlund * mpf/set_prc_raw.c: New file. * mpf/set_prc.c: Renamed from set_prec.c. * mpf/get_prc.c: New file. * mpf/Makefile.in: Corresponding changes. * gmp.h: Declare new functions. * mpn/generic/gcdext.c: Add copyright header. Fri Mar 1 01:22:24 1996 Torbjorn Granlund * mpn/configure.in: For ppc601, search "power" before "powerpc32". * mp?/Makefile.in (AR_FLAGS): New variable. (libmp?.a): Use it. * make.bat: New file. * mpn/msdos: New directory. * mpn/msdos/asm-syntax.h: New file. * mpn/Makefile.in (distclean maintainer-clean): Delete asm-syntax.h. * config.sub: Recognize [ctj]90-cray. * mpn/configure.in: Recognize [ctj]90-cray-unicos*. * mpn/generic/gcdext.c: Don't use alloca directly, use TMP_* macros. * mpn/generic/gcd.c: Split increment from use of USIZE to avoid undefined behaviour. Thu Feb 29 04:11:24 1996 Torbjorn Granlund * Makefile.in (install-info-files): Update for new install-info behaviour. * mpn/power/add_n.s: Rewrite. * mpn/power/sub_n.s: Rewrite. Wed Feb 28 01:34:30 1996 Torbjorn Granlund * mpz/pow_ui.c: Compute allocation more aggressively for small bases. * mpz/ui_pow_ui.c: Likewise. * mpn/mp_bases.c (__mp_bases): Put huge value in 2nd field for index 1. * mpn/generic/sqrtrem.c: sizeof (mp_limb_t) => BYTES_PER_MP_LIMB. * mpn/generic/gcd.c: Likewise. (SIGN_BIT): Compute differently. Mon Feb 26 00:07:36 1996 Torbjorn Granlund * All files: mp_limb => mp_limb_t, mp_limb_signed => mp_limb_signed_t. * Makefile.in (install, install-bsdmp, install-info-files): Depend on installdirs. chmod all installed files. Sun Feb 25 01:47:41 1996 Torbjorn Granlund * mpbsd/configure.in: Delete debugging code. * All Makefile.in: Update clean targets. * Makefile.in (AR_FLAGS): New variable. (libgmp.a): Use it. (libmp.a): Likewise. * VERSION: Delete file. * Makefile.in (installdirs): New target. * mkinstalldirs: New file (from the texinfo package). * Makefile.in (INSTALL, INSTALL_DATA, INSTALL_PROGRAM): New variables. (MAKEINFO, MAKEINFOFLAGS, TEXI2DVI): New variables. (install-info): New target. (install, install-bsdmp): Depend on install-info. ($(srcdir)/gmp.info): Changed from plain gmp.info; put info files into source directory. (distclean, mostlyclean): New targets. (maintainer-clean): New name for realclean. (uninstall): New target. (TAGS): New target. (info, dvi): New targets. (.PHONY): Assign. * Makefile.in (install, install-bsdmp): Use INSTALL_DATA. * mp{n,z,f,bsd}/move-if-change: Delete. * mpbsd/Makefile.in (stamp-stddefh): Delete target. * Makefile.in (.c.o): Pass CFLAGS last. * mpbsd/Makefile.in (.c.o): Likewise. * mpf/Makefile.in (.c.o): Likewise. * mpq/Makefile.in (.c.o): Likewise. * mpz/Makefile.in (.c.o): Likewise. * mpn/Makefile.in (.c.o): Likewise. (.S.o): Likewise. * memory.c: Change allocation error message. * Makefile.in (install): Prefix gmp.h with $(srcdir). (install-bsdmp): Prefix mp.h with $(srcdir). * mp{n,z,f,bsd}/{configure,config.sub}: Delete. * Makefile.in (gmp.dvi): Set TEXINPUTS also for 2nd tex invocation (install targets): Install gmp.info-N. Sat Feb 24 03:36:52 1996 Torbjorn Granlund * mpf/get_str.c: Fix typo. * mpz/legendre.c: Clarify expression with extra parens. * version.c (gmp_version): Not static. * mpf/iset_str.c: Properly return error code. * mpf/add.c: Delete unused variables. * mpf/inp_str.c: Likewise. * mpq/get_d.c: Likewise. * mpn/generic/dump.c: #include . * mpf/dump.c: Likewise. * mpf/set_str.c: #include . (strtol): Declare. * gmp.h: mpn_sqrt => mpn_sqrtrem. * Makefile.in (clean, realclean): Clean in mpbsd. (check): Test in mpf. * mpf/Makefile.in (clean): Clean in tests. * mpq/Makefile.in (clean): Clean in tests. * mpf/tests/Makefile.in: New file. * mpf/tests/configure.in: New file. * mpf/tests/t-addsub.c: New file. * mpf/sub_ui.c: Simply call mpf_sub for now. * mpf/sub.c: Increase prec by 1. * mpf/ui_sub.c: Likewise. Fri Feb 23 00:59:54 1996 Torbjorn Granlund * mpf/ui_sub.c: Fix typos. * mpf/get_str.c: When allocating space for tmp, allow for an extra limb. In code for fraction conversion, add special case for bases that are a power of 2. * mpf/out_str.c: Output leading "0.". Default base to 10, before computing string allocation. * mpf/get_str.c: Make variables for string size have type size_t. * gmp.h: Corresponding change. * mpf/random2.c: Allow creation of prec+1 large mantissas. * mpf/add_ui.c: Don't abort if u < 0; special case for u <= 0. Fix typo in MPN_COPY offset. * mpf/sub_ui.c: Analogous changes. * mpf/set_prec.c: Rewrite. * mpf/init2.c: Compute precision as in set_prec.c. * mpf/div_2exp.c: Special case for u == 0. * mpf/mul_2exp.c: Likewise. Write r->_mp_size always. * mpf/sqrt_ui.c: mpn_sqrt => mpn_sqrtrem. * mpf/sqrt.c: Likewise. When computing new exponent, round quotient towards -infinity. * mpf/add.c: Fix typos. * mpf/sub.c: Fix typos. Thu Feb 22 00:24:48 1996 Torbjorn Granlund * mpz/Makefile.in (stamp-stddefh): Delete target. (test): Delete target. * Makefile.in (stamp-stddefh): Delete target. (cre-stddefh.o): Delete target. (gmp.dvi): Set TEXINPUTS before invoking tex. * cre-stddefh.c: Delete. * mpz/sqrt.c: Fix typo. * mpz/powm.c: Special case for mod == 0. * mpz/powm_ui.c: Likewise. * mpz/get_si.c: Handle -0x80000000 correctly. * mpz/inp_str.c: Now returns size_t. Make it return number of bytes read or error indication. * mpf/inp_str.c: Likewise. * mpz/out_raw.c: Replace by mpz/out_binary.c, with modifications. * mpz/inp_raw.c: Rewrite, using mpz/inp_binary as a base. * mpz/inp_binary.c: Delete. * mpn/Makefile.in (XCFLAGS): Remove variable. (.c.o): Don't pass XCFLAGS. (SFLAGS): Set to nothing. (.S.o): Pass SFLAGS, not XCFLAGS. * mpn/config/t-freebsd (SFLAGS): New name for XCFLAGS. * mpf/out_str.c: Make return number of bytes written or error indication. * mpz/out_str.c: Likewise. * gmp.h: Corresponding changes. * gmp.h (__mpz_struct): mp_size_t => int. (__mpq_struct): Likewise. (__mpf_struct): Likewise. (mp_size_t): int => long int. * mpn/cray: New directory. * mpn/cray/gmp-mparam.h: New file. * mpn/configure.in: Recognize cray variants. * Makefile.in: Set defaults for prefix, libdir, etc. (install): New target. (install-bsdmp): New target. (gmp.html): New target. * stack-alloc.c (__tmp_alloc): Cast void ptrs to char * in comparison. Wed Feb 21 04:35:02 1996 Torbjorn Granlund * gmp.h: Sort mpn declarations. (mpn_gcdext): Add declaration. * mpn/generic/divrem_1.c: New file. * mpn/Makefile.in (divrem_1.o): New rule. * configure.in (functions): Add divrem_1. * mpn/generic/divmod.c: Delete file. * mpn/configure.in (functions): Delete divmod. * Makefile.in (divmod.o): Delete rule. * gmp.h (mpn_divmod): New #define. * gmp.h (mpn_next_bit_set): Delete spurious declaration. * mpn/generic/divrem.c (default case): In code assigning most_significant_q_limb, move reassignment of n0 into if statement. * gmp.h (mpf_inp_str): Fix typo. (mpf_out_str): Make prototype match reality. * mpf/inp_str.c: New file. * mpf/out_str.c: New file. * mpf/Makefile.in: Compile new files. * mpn/Makefile.in (dump.o): Fix dependency path. (inlines.o): Likewise. * mpn/configure.in: Make m68060 be the same as m68000. Clean up m68k configs. Tue Feb 20 01:35:11 1996 Torbjorn Granlund * mpn/generic/sqrtrem.c: Renamed from sqrt. * mpn/configure.in (functions): Corresponding change. * mpn/Makefile.in: Likewise. * mpz/sqrtrem.c: Likewise. * mpz/sqrt.c: Likewise. * mpn/generic/perfsqr.c: Likewise. * Makefile.in (clean): Also remove libmp.a. Don't compile cre-conv-tab.c or mp_bases.c. cre-conv-tab.c: Delete file. (gmp.ps): New rule. * mpn/mp_bases.c: New file. * mpn/Makefile.in: Compile mp_bases.c. * mpz/set_str.c: Skip initial whitespace. * mpf/set_str.c: Likewise. * mpbsd/xtom.c: Likewise. * gmp.h: Add missing mpz declarations. Delete all formal parameter names from declarations. * mpn/Makefile.in: Add dependencies for .c files. * Makefile.in (check): Write recursive make calls separately, not as a loop. (FLAGS_TO_PASS): New variable. Use it for most recursive makes. Mon Feb 19 01:02:20 1996 Torbjorn Granlund * mpn/Makefile.in (.S.o): Pipe cpp output to grep in order to delete lines starting with #. (CPP): Set to $(CC) -E to avoid gcc dependency. * mpn/m68k/syntax.h (moveql): Define to moveq for MIT_SYNTAX. * mpn/hppa/hppa1_1/pa7100/addmul_1.S: Fix typo in s1_ptr alignment code. * mpn/hppa/hppa1_1/pa7100/submul_1.S: Likewise. * gmp.h: Fix typos in #defines of recently added mpn functions. * mpz/inp_str.c: Skip all whitespace, not just plain space. * mpbsd/min.c: Likewise. * mpn/configure.in (functions): Add gcdext. * mpn/generic/gcdext.c: New file. * mpz/legendre.c: mpz_div_2exp => mpz_tdiv_q_2exp. * gmp.h: Surround mpn declarations with extern "C" { ... }. * Makefile.in (check): New target. * mpq/get_d.c: Update comments. Use rsize instead of dsize + N_QLIMBS when possible. Add special case for nsize == 0. * gmp.h (mpq_get_d): Add declaration. (mpq_canonicalize): Likewise. (mpq_cmp_ui): Likewise. (mpf_diff): Likewise. (mpf_ui_sub): Likewise. (mpf_set_prec): Likewise. (mpf_random2): Likewise. * gmp.h (mpz_cmp_ui): New #define. (mpz_cmp_si): New #define. (mpq_cmp_ui): New #define. (mpz_sign): New #define. (mpq_sign): New #define. (mpf_sign): New #define. (mpq_numref): New #define. (mpq_denref): New #define. * mpq/set_z.c: File deleted. * mpq/Makefile.in: Corresponding changes. Sun Feb 18 01:34:47 1996 Torbjorn Granlund * mpbsd/sdiv.c: Use _mp_realloc, not _mpz_realloc. * mpz/inp_binary.c: Default stream to stdin. * mpz/inp_str.c: Likewise. * mpz/inp_raw.c: Likewise. * mpz/out_binary.c: Default stream to stdout. * mpz/out_raw.c: Likewise. * mpz/out_str.c: Likewise. * mpbsd/realloc.c: New file. * mpbsd/Makefile.in: Corresponding changes. * mpbsd/min.c: Rewrite (base on mpz/inp_str.c). * mpbsd/mtox.c: Rewrite (base on mpz/get_str.c). * mpbsd/mout.c: Rewrite (base on mpz/out_str) but make it output spaces in each 10th position. * mpbsd/xtom.c: Rewrite (base on mpz/set_str). * mpq/tests/Makefile.in (st-cmp): New file. * mpq/tests/configure.in (srcname): New file. * mpz/tests/configure.in (srcname): Fix typo. * mpq/cmp.c: Add check using number of significant bits, to avoid general multiplication. Sat Feb 17 11:58:30 1996 Torbjorn Granlund * mpq/cmp_ui.c: Store cy_limb after the mpn_mul_1 calls. * mpq/tests: New directory. * mpq/tests/t-cmp.c: New file. * mpq/tests/t-cmp_ui.c: New file. * mpz/tests/dive.c (main): Generate zero numerator. (get_random_size) : Delete. * mpz/divexact.c: Add special case for 0/x. * gmp.h (mpz_mod): Add declaration. Fri Feb 16 18:18:39 1996 Andreas Schwab * mpn/m68k/*: Rewrite code not to use the INSN macros. (L): New macro to properly prefix local labels for ELF. Fri Feb 16 00:20:56 1996 Torbjorn Granlund * gmp-impl.h (ieee_double_extract): Use plain `unsigned int' for fields. * mpn/generic/inlines.c (_FORCE_INLINES): New #define. Delete conditional __GNUC__. * gmp.h (mpn_add, mpn_sub, mpn_add_1, mpn_sub_1): Only define these if __GNUC__ || _FORCE_INLINES. * mpf/random2.c: Add missing parameter in non-ANSI header. * mpn/generic/gcd.c (SIGN_BIT): Do as #define to work around bug in AIX compilers. * mpq/get_d.c: #define N_QLIMBS. * mpz/divexact.c: Obscure division by 0 to silent compiler warnings. * stack-alloc.c: Cast void* pointer to char* before doing arithmetic on it. * Makefile.in (mpbsd/libmpbsd.a): New rule. * configure.in (configdirs): Add mpbsd. * gmp.h: Add declarations for a few missing mpn functions. * Makefile.in (libmp.a): New rule. * mpbsd/mdiv.c: #include "dmincl.c", not "mpz_dmincl.c" * gmp.h: Move #define of __GNU_MP__ into the `#if __GNU_MP__' block. * mp.h: Likewise. Update typedefs from gmp.h. * mpbsd/configure.in: New file. * mpbsd/Makefile.in: New file. * mpbsd/configure: Link to master configure. * mpbsd/config.sub: Link to master config.sub. * Makefile.in: Set RANLIB_TEST. * (libgmp.a): Use it. * (libgmp.a): Do ranlib before moving the libgmp.a to the build directory. * mp?/Makefile.in: Don't use or set RANLIB. Thu Feb 15 16:38:41 1996 Torbjorn Granlund * mpz/add_ui.c: MP_INT => mpz_t. * mpz/cmp_ui.c: Likewise. * mpz/fac_ui.c: Likewise. * mpz/inp_binary.c: Likewise. * mpz/inp_raw.c: Likewise. * mpz/legendre.c: Likewise. * mpz/jacobi.c: Likewise. * mpz/out_binary.c: Likewise. * mpz/out_raw.c: Likewise. * mpz/random2.c: Likewise. * mpz/random.c: Likewise. * mpz/realloc.c: Likewise. * mpz/legendre.c: __mpz_2factor(X) => mpz_scan1(X,0), __mpz_odd_less1_2factor => mpz_scan1(X,1). * mpz/ntsup.c: File deleted. * mpz/Makefile.in: Corresponding changes. * mpz/pprime_p: Use mpz_scan1 to avoid looping. * mpz/fac_ui.c: Type of `k' and `p' is `unsigned long'. * mpz/pprime_p.c: Pass long to *_ui functions. * mpz/gcdext.c: Likewise. * mpz/fdiv_r_2exp.c: Likewise. * mpz/fac_ui.c: Likewise. * mpz/powm.c: Don't use mpn_rshift when mod_shift_cnt is 0. * mpz/tests/Makefile.in (st-sqrtrem): Fix typo. * mpz/cmp_ui.c: #undef mpz_cmp_ui. * mpz/cmp_si.c: #undef mpz_cmp_si. * gmp.h (mpz_cmp_ui): New #define. (mpz_cmp_si): New #define. Wed Feb 14 22:11:24 1996 Torbjorn Granlund * gmp.h: Test __cplusplus in addition to __STDC__. * gmp-impl.h: Likewise. * gmp.h: Surround declarations with extern "C" { ... }. Tue Feb 13 15:20:45 1996 Torbjorn Granlund * mpz/fdiv_r_2exp.c: Use MPN_NORMALIZE. * mpz/tdiv_r_2exp.c: Likewise. * mpz/fdiv_r_2exp.c: New file. * mpz/fdiv_q_2exp.c: New file. * mpz/tdiv_r_2exp.c: Renamed from mpz/mod_2exp.c. * mpz/tdiv_q_2exp.c: Renamed from mpz/div_2exp.c * mpz/Makefile.in: Corresponding changes. * mpz/scan0.c,scan1.c: New files. * mpz/Makefile.in: Compile them. * gmp.h (mpn_normal_size): Delete. * config.guess: Update from Cygnus version. * mpn/m68k/rshift.S: Use INSN2 macro for lea instructions. * mpn/m68k/lshift.S: Likewise. * mpn/configure.in: Fix configuration for plain 68000. Mon Feb 12 01:06:06 1996 Torbjorn Granlund * mpz/tests/t-powm.c: Generate negative BASE operand. * mpz/powm.c: Make result always positive. Sun Feb 11 01:44:56 1996 Torbjorn Granlund * mpz/tests/*.c: Add t- prefix. * mpz/tests/Makefile.in: Corresponding changes. * mpz/tests/configure.in: Update srctrigger. * mpz/tests/gcd.c: Generate negative operands. * mpz/tests/gcd2.c: Likewise. * mpz/gcdext.c: At end, if G is negative, negate all G, S, and T. Thu Feb 8 17:16:12 UTC 1996 Ken Weber * mp{z,n}/gcd.c: Change mpn_gcd interface. * gmp.h: Ditto. * gmp.texi: update documentation. Mon Feb 7 23:58:43 1996 Andreas Schwab * mpn/m68k/{lshift,rshift}.S: New files. * mpn/m68k/syntax.h: New ELF_SYNTAX macros. (MEM_INDX, R, PROLOG, EPILOG): New macros. * mpn/m68k/*.S: Use R macro with register name. Use PROLOG and EPILOG macros. Rename `size' to `s_size' or s1_size to avoid clash with ELF .size directive. * mpn/configure.in: New target m68k-*-linux*. Wed Feb 7 07:41:31 1996 Torbjorn Granlund * Makefile.in (cre-conv-tab): Workaround for SunOS make. * mpz/tests/reuse.c: New file. * mpz/tests/Makefile.in: Handle reuse.c. Tue Feb 6 11:56:24 UTC 1996 Ken Weber * mpz/gcd.c: Fix g->size when one op is 0 and g == other op. Tue Feb 6 01:36:39 1996 Torbjorn Granlund * gmp.h (mpz_divexact): Delete parameter names. (mpz_lcm): Delete spurious declaration. * mpz/dmincl.c: Fix typo. Mon Feb 5 01:11:56 1996 Torbjorn Granlund * mpn/generic/gcd.c (gcd_2): Declare consistently. * mpz/tdiv_q.c: Optimize division by a single-limb divisor. * mpz/dmincl.c: Likewise. * mpz/add.c: Use MPN_NORMALIZE instead of mpn_normal_size. * mpz/sub.c: Likewise. * mpn/generic/sqrt.c: Likewise. * mpn/tests/{add_n,sub_n,lshift,rshift}.c: Put garbage in the destination arrays. Fri Feb 2 02:21:27 1996 Torbjorn Granlund * mpz/{jacobi.c,legendre.c,ntsup.c,invert.c}: New files. * mpz/Makefile.in: Compile them. * mpn/Makefile.in (INCLUDES): Don't search in `generic'. Thu Feb 1 02:15:11 1996 Torbjorn Granlund Change from Ken Weber: * mpz/divexact.c: Make it work when quot is identical to either input. * mpf/ui_sub.c: New file. * mpf/Makefile.in: Compile it. * gmp-impl.h (MPZ_TMP_INIT): alloca -> TMP_ALLOC. * mpz/{c,f}div_{q,qr,r}.c: Use TMP_DECL/TMP_MARK/TMP_FREE since these use MPZ_TMP_INIT. * mpz/mod.c: Likewise. * mpq/{add,sub}.c: Likewise. * mpq/canonicalize: Likewise. * mpq/{add,sub,mul,div}.c: Use mpz_divexact. MP_INT -> mpz_t. * mpq/canonicalize.c: Likewise. Wed Jan 31 01:45:00 1996 Torbjorn Granlund * mpn/generic/gcd.c: Misc changes from Ken. * mpz/tests/gcd2.c: New file. * mpz/tests/Makefile.in: Handle gcd2.c. * mpn/generic/gcd.c (mpn_gcd): When GCD == ORIG_V, return vsize, not orig_vsize. Fix parameter declaration. * mpz/mod_ui.c: Delete file. * mpz/Makefile.in: Don't try to compile mod_ui. * mpz/cdiv_*_ui.c): Make them work right. * gmp.h: Declare cdiv*. Tue Jan 30 02:22:56 1996 Torbjorn Granlund * mpz/{cdiv_q.c,cdiv_q_ui.c,cdiv_qr.c,cdiv_qr_ui.c,cdiv_r.c, cdiv_r_ui.c,cdiv_ui.c}: New files. * mpz/Makefile.in: Compile them. * All files: Make file permissions right. Changes from Ken Weber: * mpn/generic/accelgcd.c: Delete. * mpn/generic/bingcd.c: Delete. * mpn/generic/numbits.c: Delete. * mpn/generic/gcd.c: New file. * mpn/configure.in (functions): Update accordingly. * mpz/divexact.c: New file. * mpz/Makefile.in: Compile divexact.c. * mpz/gcd.c: Rewrite to accommodate for gcd changes in mpn. * gmp.h: declare new functions, delete obsolete declarations. * mpz/tests/dive.c: New file. * mpz/tests/Makefile.in: Handle dive.c. Mon Jan 29 03:53:24 1996 Torbjorn Granlund * mpz/random.c: Handle negative SIZE parameter. * mpz/tests/tdiv(_ui).c: New name for tst-dm(_ui).c. * mpz/tests/tst-mdm(_ui).c: Delete. * mpz/tests/fdiv(_ui).c: New test based in tst-mdm(_ui). * mpz/tests/*.c: Get rid of tst- prefix for DOS 8+3 naming. * mpz/tests/Makefile.in: Corresponding changes. * mpz/tests/configure.in: Update srctrigger. * mpn/generic/divmod.c: Update from divrem. * mpn/generic/divrem.c: Misc cleanups. Sun Jan 28 03:25:08 1996 Torbjorn Granlund * All files: Use new TMP_ALLOC interface. * mpz/powm_ui.c: Make Jan 25 changes to powm.c also here. * mpz/tests/powm_ui.c: New file. * mpz/tests/Makefile.in: Add rules for tst-powm and tst-powm_ui. * Makefile.in: Update dependency list. * mpf/Makefile.in: Likewise. * mpz/Makefile.in: Likewise. * mpq/Makefile.in: Likewise. * Makefile.in: Set RANLIB simply to ranlib, and allow configure to override it. * mpz/Makefile.in (conf): Delete spurious target. (mp_bases.c): Delete. (cre-conv-tab rules): Delete. * Makefile.in (cre-conv-tab): Greatly simplify. Sat Jan 27 13:38:15 1996 Torbjorn Granlund * stack-alloc.c: New file. * stack-alloc.h: New file. * gmp.h (__gmp_inline): Define using __inline__. Thu Jan 25 00:28:37 1996 Torbjorn Granlund * mpn/generic/scan0.c: New file. * mpn/generic/scan1.c: Renamed from next_bit.c. * mpn/configure.in (functions): Include scan0 and scan1. * mpn/m68k/*: #include sysdep.h. Use C_GLOBAL_NAME. * configure: Update from Cygnus version. * config.guess: Likewise. * config.sub: Likewise. * configure: Pass --nfp to recursive configures. * mpz/tests/tst-*.c: Adjust SIZE and reps. * mpz/powm.c: Move esize==0 test earlier. In final reduction of rp,rsize, don't call mpn_divmod unless reduction is really needed. * mpz/tests/tst-powm.c: Fix thinko in checking code. * All files: Get rid of `__' prefix from mpn_* calls and declarations. * gmp.h: #define __MPN. * gmp.h: Use __MPN in #defines for mpn calls. * mpn/generic/mul_n.c: Prepend `i' to internal routines. * gmp-impl.h: Add #defines using __MPN for those internal routines. * mpn/generic/sqrt.c: Change call to mpn_mul to mpn_mul_n. Wed Jan 24 13:28:19 1996 Torbjorn Granlund * mpn/sparc32/udiv_fp.S: New name for udiv_qrnnd.S. * mpn/sparc32/udiv_nfp.S: New name for v8/udiv_qrnnd.S. * mpn/sparc32/v8/supersparc: New directory. * mpn/sparc32/v8/supersparc/udiv.S: New file. Tue Jan 23 01:10:11 1996 Torbjorn Granlund This major contribution is from Ken Weber: * mpn/generic/accelgcd.c: New file. * mpn/generic/bdivmod.c: New file. * mpn/generic/bingcd.c: New file. * mpn/generic/gcd_1.c: Rewrite. * mpn/generic/numbits.c: New file (to go away soon). * mpz/gcd.c: Rewrite. * mpz/tests/tst-gcd.c (SIZE): Now 128. * gmp.h: Declare new functions. * mpn/configure.in (functions): List new files. * gmp-impl.h (MPN_SWAP): Delete. (MPN_LESS_BITS_LIMB, MPN_LESS_BITS, MPN_MORE_BITS): Delete. (MPN_COMPL_INCR, MPN_COMPL): Delete. Mon Jan 22 02:04:59 1996 Torbjorn Granlund * gmp.h (mpn_name): New #define. * mpn/m88k/mc88110/addmul_1.s: New file. * mpn/m88k/mc88110/add_n.S: New file. * mpn/m88k/mc88110/sub_n.S: New file. * mpn/m88k/sub_n.s: Correctly initialize carry. * mpn/sparc32/{add_n.S,sub_n.S,lshift.S,rshift.S): `beq' => `be'. Sun Jan 21 00:04:35 1996 Torbjorn Granlund * mpn/sparc64/addmul_1.s: New file. * mpn/sparc64/submul_1.s: New file. * mpn/sparc64/rshift.s: New file. Sat Jan 20 00:32:54 1996 Torbjorn Granlund * mpz/iset.c: Fix typo introduced Dec 25. Wed Jan 17 13:16:44 1996 Torbjorn Granlund * config/mt-sprc8-gcc: New name for mt-sparc8-gcc. * config/mt-sparcv8-gcc: Delete. * configure.in: Corresponding changes. Tue Jan 16 16:31:01 1996 Torbjorn Granlund * gmp-impl.h: #include alloca.h when necessary. * longlong.h: Test __alpha instead of __alpha__, since the former is the standard symbol. Mon Jan 15 18:06:57 1996 Torbjorn Granlund * mpn/sparc64/mul_1.s: Swap operands of mulx instructions. * mpn/sparc64/lshift.s: New file. Fri Dec 29 17:34:03 1995 Torbjorn Granlund * mpn/x86/pentium/add_n.S: Get rid of #defines for register names. * mpn/x86/pentium/sub_n.S: Likewise. Thu Dec 28 03:16:57 1995 Torbjorn Granlund * mpn/x86/pentium/mul_1.S: Rework loop to avoid AGI between update of loop induction variable and load insn at beginning of loop. * mpn/x86/pentium/addmul_1.S: Likewise. * mpn/x86/pentium/submul_1.S: Likewise. Mon Dec 25 23:22:55 1995 Torbjorn Granlund * All files: Prefix user-visible structure fields with _mp_. Fri Dec 22 20:42:17 1995 Torbjorn Granlund * mpn/configure.in (m68k configs): Terminate path variable with plain "m68k". Fri Dec 22 03:29:33 1995 Torbjorn Granlund * mpn/sparc32/add_n.S: Update from sub_n.S to fix bugs, and to clean things up. * mpn/configure.in (m68k configs): Update #include path for new mpn directory organization. Tue Dec 12 02:53:02 1995 Torbjorn Granlund * gmp.h: Prefix all structure field with _mp_. * gmp-impl.h: Define access macros for these fields. Sun Dec 10 00:47:17 1995 Torbjorn Granlund * mpn/alpha/addmul_1.s: Prefix labels with `.'. * mpn/alpha/submul_1.s: Likewise. * mpn/alpha/[lr]shift.s: Likewise. * mpn/alpha/udiv_qrnnd.S: Likewise. * mpn/alpha/ev5/[lr]shift.s: Likewise. * mpn/alpha/ev5/lshift.s: Fix typos. Fri Dec 1 14:28:20 1995 Torbjorn Granlund * mpn/Makefile.in (.SUFFIXES): Define. Wed Nov 29 23:11:57 1995 Torbjorn Granlund * mpn/sparc64/{add_n.s, sub_n.s}: New files. Tue Nov 28 06:03:13 1995 Torbjorn Granlund * mpn/x86/syntax.h: Handle ELF_SYNTAX. Rename GAS_SYNTAX => BSD_SYNTAX. * mpn/configure.in: Handle linuxelf and SysV for x86 variants. Mon Nov 27 01:32:12 1995 Torbjorn Granlund * mpn/hppa/hppa1_1/pa7100/submul_1.S: New file. Sun Nov 26 04:30:47 1995 Torbjorn Granlund * mpn/hppa/hppa1_1/pa7100/addmul_1.S: New file. * mpn/sparc32/add_n.S: Rewrite to use 64 bit loads/stores. * mpn/sparc32/sub_n.S: Likewise. Fri Nov 17 00:18:46 1995 Torbjorn Granlund * mpn/configure.in: Handle m68k on NextStep. Thu Nov 16 02:30:26 1995 Torbjorn Granlund * mpn: Reorganize machine-specific directories. * mpn/configure.in: Corresponding changes. (sh, sh2): Handle these. (m68k targets): Create asm-syntax.h. Thu Nov 9 02:20:50 1995 Torbjorn Granlund * mpn/generic/mul_n.c (____mpn_sqr_n): Delete code that calls abort. (____mpn_mul_n): Likewise. Tue Nov 7 03:25:12 1995 Torbjorn Granlund * mpf/get_str.c: In exponentiation code (two places), don't swap input and output areas when calling mpn_mul_1. * mpf/set_str.c: Likewise. Fri Nov 3 02:35:58 1995 Torbjorn Granlund * mpf/Makefile.in: Make sure all objects are listed in dependency list; delete spurious entries. * mpf/mul.c: Handle U or V being 0. Allow prec+1 for result precision. * mpf/set_prec.c: New computation of limb precision. * mpf/set_dfl_prec.c: Likewise. * mpf/random2.c: Fix typo computing exp. * mpf/get_str.c: In (uexp > usize) case, set n_limbs as a function of the user-requested number of digits, n_digits. Thu Nov 2 16:25:07 1995 Torbjorn Granlund * mpn/generic/divrem.c (case 2): Don't move np vector back, it is never read. (default case): Put most significant limb from np in new variable n2; decrease size argument for MPN_COPY_DECR; use n2 instead of np[dsize]. Wed Nov 1 02:59:53 1995 Torbjorn Granlund * mpn/sparc/[lr]shift.S: New files. Tue Oct 31 00:08:12 1995 Torbjorn Granlund * mpz/gcd_ui.c: Set w->size unconditionally when v is zero. * gmp-impl.h (assert): Delete definition. * mpf/sub.c: Delete all assert calls. Delete variable `cy'. * mpf/neg.c: Use prec+1 as precision. Optimize for when arguments are the same. * mpf/abs.c: Likewise. * mpf/{set,neg,abs}.c: Make structure and variable names similar. Mon Oct 30 12:45:26 1995 Torbjorn Granlund * mpf/random2.c (random): Test __SVR4 in addition to __svr4__. * mpn/generic/random2.c (random): Likewise. Sun Oct 29 01:54:28 1995 Torbjorn Granlund * mpf/div.c: Special handle U or V being 0. * mpf/random2.c: New file. * longlong.h (i860 rshift_rhlc): Define. (i960 udiv_qrnnd): Define. (i960 count_leading_zeros): Define. (i960 add_ssaaaa): Define. (i960 sub_ddmmss): Define. (i960 rshift_rhlc): Define. Sat Oct 28 19:09:15 1995 Torbjorn Granlund * mpn/pentium/rshift.S: Fix and generalize condition for when to use special code for shift by 1. * mpn/pentium/lshift.S: Likewise. Thu Oct 26 00:02:56 1995 Torbjorn Granlund * gmp.h: #undef __need_size_t. * mp.h: Update from gmp.h. Wed Oct 25 00:17:27 1995 Torbjorn Granlund * mpf/Makefile.in: Compile set_prec.c. * mpf/realloc.c: Delete this file. * mpf/Makefile.in: Delete mentions of realloc.c. * gmp.h (__mpf_struct): Get rid of `alloc' field. * mpf/clear.c: Likewise. * mpf/init*.c: Likewise. * mpf/set_prec.c: Likewise. * mpf/iset*.c: Likewise. * mpf/iset_str.c: New file. * mpn/configure.in: Handle pyramid. * mpf/set.c: Use prec+1 as precision. * mpf/set_prec.c: New file. Tue Oct 24 00:56:41 1995 Torbjorn Granlund * mpn/generic/divrem.c: New file. Will replace mpn/generic/divmod.c when rest of source is converted. * mpn/configure.in (functions): Add `divrem' * mpn/generic/set_str.c: Never call __mpn_mul_1 with zero size. * mpf/get_str.c: Completely rewritten. * mpf/add.c: Fix several problems. * mpf/sub.c: Compare operands from most significant end until first difference, exclude skipped limbs from computation. Accordingly simplify normalization code. * mpf/set_str.c: Fix several problems. * mpf/dump.c: New file. * mpf/Makefile.in: Compile dump.c. * mpf/init2.c: Set prec field correctly. Sun Oct 22 03:02:09 1995 Torbjorn Granlund * cre-conv-tab.c: #include math.h; don't declare log and floor. Sat Oct 21 23:04:10 1995 Torbjorn Granlund * mpf/mul_ui.c: Handle U being 0. Wed Oct 18 19:39:27 1995 Torbjorn Granlund * mpn/generic/set_str.c: Correctly handle input like "000000000000". Misc cleanups. Tue Oct 17 15:14:13 1995 Torbjorn Granlund * longlong.h: Define COUNT_LEADING_ZEROS_0 for machines where appropriate. Mon Oct 16 19:14:43 1995 Torbjorn Granlund * mpf/add.c: Rewrite. * mpf/set_str.c: New file. Needs more work. Sat Oct 14 00:14:04 1995 Torbjorn Granlund * mpf/div_2exp.c: Vastly simplify. * mpf/mul_2exp.c: Likewise. * mpf/sub.c: Rewrite. * gmp-impl.h (udiv_qrnnd_preinv2gen): Terminate comment. * mpf/dump.c: Free allocated memory. * gmp-impl.h (assert): Define. Wed Oct 11 13:31:00 1995 Torbjorn Granlund * mpn/pentium/rshift.S: Install new code to optimize shift-by-1. Tue Oct 10 00:37:21 1995 Torbjorn Granlund * mpn/pentium/lshift.S: Install new code to optimize shift-by-1. * mpn/powerpc32/{lshift.s,rshift.s}: New files. * configure.in: Fix typo. Sat Oct 7 08:17:09 1995 Torbjorn Granlund * longlong.h (smul_ppmm): Correct type of __m0 and __m1. Wed Oct 4 16:31:28 1995 Torbjorn Granlund * mpn/configure.in: Handle alphaev5. * mpn/ev4: New name for alpha subdir. * mpn/ev5: New subdir. * mpn/ev5/lshift.s: New file. Tue Oct 3 15:06:45 1995 Torbjorn Granlund * mpn/alpha/mul_1.s: Avoid static increments of pointers; use corresponding offsets in ldq and stq instructions instead. (Loop): Swap cmpult and stq to save one cycle on EV5. * mpn/tests/{add_n.s,sub_n.s,lshift.s,rshift.s,mul_1.s,addmul_1.s, submul_1.s}: Don't check results if NOCHECK is defined. Mon Oct 2 11:40:18 1995 Torbjorn Granlund * longlong.h (mips umul_ppmm [32 and 64 bit versions]): Make new variants, based on GCC version number, that use `l' and `h' constraints instead of explicit mflo and mfhi instructions Sun Oct 1 00:17:47 1995 Torbjorn Granlund * mpn/mc88100/add_n.s: Decrease unrolling factor from 16 to 8. * mpn/mc88100/sub_n.s: Likewise. * config/mt-m88110: New file. * configure.in: Use it. * mpn/mc88110/mul_1.s: Fix thinko. Sat Sep 30 21:28:19 1995 Torbjorn Granlund * mpz/set_d.c: Declare `size' at function start. * experimental: New directory for mpx and mpz2. * mpz/tdiv_q.c: Clarify comments. * mpz/{mod.c,mod_ui.c}: New file, for math mod function. * mpn/sh2/{mul_1.s,addmul_1.s,submul_1.s}: New files. * mpn/sh/{add_n.s,sub_n.s}: New files. * mpn/pyr/{add_n.s,sub_n.s,mul_1.s,addmul_1.s}: New files. * mpn/i960/{add_n.s,sub_n.s}: New files. * mpn/alpha/addmul_1.s (Loop): Move decrement of r18 to before umulh, to save cycles on EV5. * mpn/alpha/submul_1.s: Ditto. * mpn/alpha/mul_1.s: Ditto. Thu Sep 28 02:48:59 1995 Torbjorn Granlund * gmp.h (mp_limb, mp_limb_signed): Define as `long long' if _LONG_LONG_LIMB is defined. * longlong.h (m88110): Test __m88110__, not __mc88110__ * mpn/mc88110/mul_1.s: Rewrite. Tue Sep 26 23:29:05 1995 Torbjorn Granlund * config.sub: Update from current Cygnus version. * mpn/configure.in: Recognize canonical m88*, not mc88*. Fri Sep 22 14:58:05 1995 Torbjorn Granlund * mpz/set_d.c: New file. * mpz/Makefile.in: Build new files. * mpq/get_d.c: Replace usage of scalbn with ldexp. * mpn/{vax,i386}/gmp-mparam.h: New files. * gmp-impl.h (ieee_double_extract): Define here. * mpf/set_d.c (ieee_double_extract): Not here. Thu Sep 21 00:56:36 1995 Torbjorn Granlund * longlong.h (C umul_ppmm): Use UWtype, not USItype for temps. (udiv_qrnnd): For cases implemented with call to __udiv_qrnnd, protect with new symbol LONGLONG_STANDALONE. (68000 umul_ppmm): Use %# prefix for immediate constants. Wed Sep 20 15:36:23 1995 Torbjorn Granlund * mpn/generic/divmod_1.c: Handle divisor_limb == 1 << (BITS_PER_MP_LIMB - 1) specifically also when normalization_steps != 0. Mon Sep 18 15:42:30 1995 Torbjorn Granlund * mpq/get_d.c: New file. Sun Sep 17 02:04:36 1995 Torbjorn Granlund * longlong.h (pyr): Botch up for now. Sat Sep 16 00:11:50 1995 Torbjorn Granlund * mpn/clipper/mul_1.s: New file. * mpn/clipper/add_n.s: New file. * mpn/clipper/sub_n.s: New file. * mpn/configure.in: Handle clipper*-*-*. * mpn/configure.in: Recognize rs6000-*-*. Fri Sep 15 00:41:34 1995 Torbjorn Granlund * mpn/alpha/add_n.s: New file. * mpn/alpha/sub_n.s: New file. * mpn/mips3: New name for mpn/r4000. * mpn/mips2: New name for mpn/r3000. * mpn/configure.in: Corresponding changes. * mpn/generic/perfsqr.c (primes): Delete. (residue_map): Delete. Thu Sep 14 00:07:58 1995 Torbjorn Granlund * mpn/r3000/sub_n.s: Fix typo. * dm_trunc.c: Delete spurious file. * mpz/out_binary.c: Fix typo. * mpn/configure.in (per-target): Make mips*-*-irix6* imply r4000. * gmp-impl.h: For sparc and sgi, include alloca.h. * mpn/z8000/mul_1.s: Replace `test r' with `and r,r'. Replace `ldk r,#0' with `xor r,r'. Wed Sep 6 00:58:38 1995 Torbjorn Granlund * mpz/inp_binary.c: New file. * mpz/out_binary.c: New file. * mpz/Makefile.in: Build new files. Tue Sep 5 22:53:51 1995 Torbjorn Granlund * gmp.h (__mpz_struct): Change `long int' => `mp_size_t' for alloc and size fields. Sat Sep 2 17:47:59 1995 Torbjorn Granlund * mpn/r4000/{add_n.s,sub_n.s}: Optimize away some pointer arithmetic. * mpn/r3000/{add_n.s,sub_n.s,lshift.s,rshift.s}: New files, derived from r4000 code. Fri Sep 1 05:35:52 1995 Torbjorn Granlund * mpn/r3000/mul_1.s: Fix typo. * mpn/powerpc32: Fix some old vs new mnemonic issues. * mpn/powerpc32/{add_n.s,sub_n.s}: New files. * mpn/r4000/{add_n.s,sub_n.s,lshift.s,rshift.s}: New files. Wed Aug 30 10:43:47 1995 Torbjorn Granlund * mpn/r3000/mul_1.s ($LC1): Use addiu for immediate add. * mpn/r4000/{mul_1.s,addmul_1.s,submul_1.s}: New files. * config.guess: Update to latest FSF revision. Mon Aug 28 02:18:13 1995 Torbjorn Granlund * mpz/out_str.c: Cast str to char * in fputs call. * gmp-impl.h: Define UQItype, SItype, and USItype also when not __GNUC__. Fri Aug 25 01:45:04 1995 Torbjorn Granlund * mpn/i386/syntax.h: Renamed from asm-syntax.h. * mpn/mc68020/syntax.h: Renamed from asm-syntax.h. * mpn/configure.in: Corresponding changes. Sun Aug 13 19:20:04 1995 Torbjorn Granlund * mpn/generic/random2.c: Test __hpux, not hpux. Sat Apr 15 20:50:33 1995 Torbjorn Granlund (tege@tiny.cygnus.com) * mpn/sparc/add_n.S: Make it work for PIC. * mpn/sparc/sub_n.s: Likewise. * mpn/sparc8/addmul_1.S: Likewise. * mpn/sparc8/mul_1.S: Likewise. * mpn/i386/add_n.S: Likewise. * mpn/i386/sub_n.S: Likewise. Thu Apr 13 23:15:03 1995 Torbjorn Granlund (tege@tiny.cygnus.com) * mpn/configure.in: Don't search power subdir for generic ppc configs. Add some ppc cpu-specific configs. Misc clean up. Mon Apr 10 00:16:35 1995 Torbjorn Granlund (tege@tiny.cygnus.com) * mpz/ui_pow_ui.c: Delete spurious code to handle negative results. Sun Apr 9 12:38:11 1995 Torbjorn Granlund (tege@tiny.cygnus.com) * longlong.h (SPARC v8 udiv_qrnnd): Generate remainder in C, not in asm. * mpn/generic/sqrt.c (SQRT): Test for __SOFT_FLOAT. Tue Mar 28 00:19:52 1995 Torbjorn Granlund (tege@tiny.cygnus.com) * mpn/generic/hamdist.c (popc_limb): Make Mar 16 change here too. Fri Mar 17 23:29:22 1995 Torbjorn Granlund (tege@tiny.cygnus.com) * longlong.h (SH umul_ppmm): Define. Thu Mar 16 16:40:44 1995 Torbjorn Granlund (tege@tiny.cygnus.com) * mpn/generic/popcount.c (popc_limb): Rearrange 32 bit case to help CSE. Fri Mar 10 20:03:49 1995 Torbjorn Granlund (tege@tiny.cygnus.com) * mpn/powerpc32/mul_1.s: Clear cy before entering loop. Rearrange loop to save a cycle. * mpn/powerpc32/addmul_1.s: New file. * mpn/powerpc32/submul_1.s: New file. Fri Feb 17 22:44:45 1995 Torbjorn Granlund (tege@tiny.cygnus.com) * mpn/configure.in: Set target_makefile_frag for freebsd in new case stmt. * mpn/config/t-freebsd: New file. * mpn/Makefile.in: Add #### for frag insertion. (XCFLAGS): Clear by default. (.c.o, .S.o rules): Pass XCFLAGS. Tue Feb 7 16:27:50 1995 Torbjorn Granlund (tege@tiny.cygnus.com) * longlong.h (68000 umul_ppmm): Merge improvements from henderson. Tue Jan 24 04:23:20 1995 Torbjorn Granlund (tege@tiny.cygnus.com) * longlong.h (default umul_ppmm): Store input parameters in temporaries to avoid reading them twice. (default smul_ppmm): New definition. Thu Dec 29 04:20:07 1994 Jim Meyering (meyering@comco.com) * generic/perfsqr.c (__mpn_perfect_square_p): Remove declaration of unused variable. * generic/pre_mod_1.c (__mpn_preinv_mod_1): Likewise. * mpz/powm.c (pow): Likewise. * mpz/and.c (mpz_and): Use {} instead of `;' for empty else clause to placate `gcc -Wall'. * mpz/ior.c (mpz_ior): Likewise. Wed Dec 28 13:31:40 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * mpn/m*68*/*.S: #include asm-syntax.h, not asm.h. Mon Dec 26 17:15:36 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * longlong.h: Test for more symbols, in __mc68000__ case. * mpn/mpn/config.sub: Recognize m68060. * mpn/configure.in: Change mc* to m* for 68k targets. * mpn/Makefile.in (.S.o): Delete spurious creation of temp .c file. Mon Dec 19 01:56:30 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * config.sub: Recognize pentium as a valid CPU. * mpn/configure.in: Handle pentium specifically, to use new assembly code. Mon Dec 19 00:13:01 1994 Jim Meyering (meyering@comco.com) * gmp.h: Define _GMP_H_HAVE_FILE if FILE, __STDIO_H__, or H_STDIO is defined. * gmp.h: test _GMP_H_HAVE_FILE instead of FILE everywhere else. Mon Dec 19 00:04:54 1994 Kent Boortz (boortz@sics.se) * Makefile.in (recursive makes): Pass CFLAGS. Sun Dec 18 22:34:49 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * mpn/pentium: New directory. * mpz/pprime.c: Make sure to mpz_clear all temporaries. * longlong.h: Don't use udiv instruction when SUPERSPARC is defined. * configure.in: Handle supersparc*-. * config/mt-supspc-gcc: New file. * config/mt-sparc8-gcc: New name for mt-sparcv8-gcc. Mon Dec 12 22:22:10 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * mpn/i386/*.S: #include "asm-syntax.h", not "asm.h". #include sysdep.h before asm-syntax.h. * mpn/mc68020/asm-syntax.h: #undef ALIGN before defining it. * mpn/i386/asm-syntax.h: Likewise. * mpn/mc68020/asm-syntax.h: New name for asm.h. * mpn/i386/asm-syntax.h: New name for asm.h. Tue Dec 6 21:55:25 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * mpz/array_init.c: Fix typo in declaration. Fri Nov 18 19:50:52 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * mpn/Makefile.in (.S.o): Pass CFLAGS and INCLUDES. Mon Nov 14 00:34:12 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * mpn/generic/random2.c (random): Test for __svr4__. Wed Oct 12 23:28:16 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * cre-conv-tab.c (main): Avoid upper-case X in printf format string. Tue Aug 23 17:16:35 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * mpz/perfsqr.c: Use mpn_perfect_square_p. * mpn/generic/perfsqr.c: New file. Wed Jul 6 13:46:51 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * mpz/array_init.c: New file. * mpz/Makefile.in: Compile array_init. * gmp.h: Declare mpz_array_init. Mon Jul 4 01:10:03 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * mpz/add.c: Fix bogus comment. * mpz/sub.c: Likewise. Sat Jul 2 02:14:56 1994 Torbjorn Granlund (tege@adder.cygnus.com) * mpn/generic/pre_mod_1.c: New file. * mpz/perfsqr.c: Use __mpn_preinv_mod_1 when faster. Fri Jul 01 22:10:19 1994 Richard Earnshaw (rwe11@cl.cam.ac.uk) * longlong.h (arm umul_ppmm): Fix typos in last change. Mark hard-coded registers with "%|" Thu Jun 30 03:59:33 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * mpz/perfsqr.c: Define PP, etc, for machines with 64 bit limbs. Use __mpn_mod_1. * mpz/perfsqr.c: Don't clobber REM in quadratic residue check loop. Wed Jun 29 18:45:41 1994 Torbjorn Granlund (tege@adder.cygnus.com) * mpn/generic/sqrt.c (SQRT): New asm for IBM POWER2. * mpz/gcd_ui.c: Return 0 if result does not fit an unsigned long. * gmp.h: Use "defined (__STDC__)" consistently. Tue Jun 28 18:44:58 1994 Torbjorn Granlund (tege@adder.cygnus.com) * gmp.h (mpz_get_si): Don't use "signed" keyword for return type. * mpz/tests/Makefile.in: Use CFLAGS for linking. * Makefile.in (CFLAGS): Use -O2 here. * mpn/Makefile (CFLAGS): Not here. * mpq/cmp_ui.c: Fix typo. * mpq/canonicalize.c: Fix typo. * mpz/gcd_ui.c: Handle gcd(0,v) and gcd(u,0) correctly. * mpn/generic/gcd_1.c: Fix braino in last change. Mon Jun 27 16:10:27 1994 Torbjorn Granlund (tege@rtl.cygnus.com) * mpz/gcd_ui.c: Change return type and return result. Allow destination param to be NULL. * gmp.h: Corresponding change. * mpn/generic/gcd_1.c: Handle zero return from mpn_mod_1. Tue Jun 14 02:17:43 1994 Torbjorn Granlund (tege@tiny.cygnus.com) * mpn/i386/asm.h (ALIGN): Make it take a parameter. * mpn/i386/*.S: Use ALIGN to align all loops. * mpn/i386/*.S: Move colon inside C_GLOBAL_NAME expression. (Makes old versions of GAS happy.) Sat May 28 01:43:54 1994 Torbjorn Granlund (tege@adder.cygnus.com) * Many files: Delete unused variables and labels. * mpn/generic/dump.c: cast printf width argument to int. Wed May 25 00:42:37 1994 Torbjorn Granlund (tege@thepub.cygnus.com) * mpz/gcd.c (mpz_gcd): Normalize after __mpn_sub calls. (xmod): Ignore return value of __mpn_divmod. (xmod): Improve normalization code. Sat May 21 01:30:09 1994 Torbjorn Granlund (tege@adder.cygnus.com) * mpz/gcdext.c: Cosmetic changes. * mpz/fdiv_ui.c: New file. Fri May 20 00:24:53 1994 Torbjorn Granlund (tege@adder.cygnus.com) * mpz/tests/Makefile.in: Use explicit rules for running tests, not a shell loop. (clean): Delete stmp-*. * mpz/Makefile.in: Update. * mpz/div_ui.c: Don't include longlong.h. * mpz/dm_ui.c: Likewise. * mpz/fdiv_q.c, mpz/fdiv_q_ui.c, mpz/fdiv_qr.c, mpz/fdiv_qr_ui.c, mpz/fdiv_r.c, mpz/fdiv_r_ui.c: New files. Code partly from deleted mdm.c, mdm_ui.c, etc, partly rewritten. * mpz/dm_floor_ui.c, mpz/dm_floor.c: Delete. * mpz/mdm.c, mpz/mdm_ui.c, mpz/mdiv.c, mpz/mdiv_ui.c, mpz/mmod.c, mpz/mmod_ui.c: Delete. * mpz/tdiv_q.c, mpz/tdiv_q_ui.c, mpz/tdiv_qr.c, mpz/tdiv_qr_ui.c, mpz/tdiv_r.c, mpz/tdiv_r_ui.c: New names for files implementing truncating division. * mpz/div_ui.c, mpz/dm_ui.c, mpz/mod_ui.c: Simplify. * mpn/Makefile.in (.S.o): Don't rely on CPP being defined, use CC instead. (clean): Delete tmp-*. Thu May 19 01:37:44 1994 Torbjorn Granlund (tege@adder.cygnus.com) * mpz/cmp.c: Call __mpn_cmp. * mpz/popcount.c: Fix typo. * mpz/powm_ui.c: Simplify main loop. Keep principal operand size smaller than MSIZE when possible. * mpz/powm.c: Likewise. * mpn/generic/sqrt.c: Move alloca calls into where the memory is needed. Simplify. * gmp.h: (_PROTO): New macro. Add many function declarations; use _PROTO macro in all declarations. * mpf/*.c: Prepend mpn calls with __. Wed May 18 20:57:06 1994 Torbjorn Granlund (tege@adder.cygnus.com) * mpf/*ui*.c: Make ui argument `long' for consistency with mpz functions. * mpf/div_ui.c: Simplify. Tue May 17 01:05:14 1994 Torbjorn Granlund (tege@adder.cygnus.com) * mpz/*.c: Prepend mpn calls with __. * mpz/mul_ui.c: Use mpn_mul_1. Mon May 16 17:19:41 1994 Torbjorn Granlund (tege@adder.cygnus.com) * mpn/i386/mul_1.S: Use C_GLOBAL_NAME. * mpn/i386/mul_1.S, mpn/i386/addmul_1.S, mpn/i386/submul_1.S: Nuke use of LAB. Sat May 14 14:21:02 1994 Torbjorn Granlund (tege@adder.cygnus.com) * gmp-impl.h: Don't define abort here. * mpz/pow_ui.c: Increase temporary allocation. * mpz/ui_pow_ui.c: Likewise. * gmp.h (mpz_add_1, mpz_sub_1): Don't call memcpy. * All Makefile.in: Delete spurious -I arguments. Update dependencies. * mpz/popcount.c: New file. * mpz/hamdist.c: New file. * All configure: Latest version from Cygnus. * mpq/Makefile.in: New file. * mpq/configure.in: New file. * Makefile.in, configure.in: Enable compilation of mpq. * mpq/set_z.c: Fix typos. * mpq/canonicalize.c: Fix typos. * mpq/cmp_ui.c: Fix typos. * mpf/add_ui.c: Read U->D into UP always. Delete spurious MPN_COPY. * mpf/sub_ui.c: Likewise. * gmp-impl.h: Don't redefine alloca. * COPYING.LIB: Renamed from COPYING. Wed May 11 01:45:44 1994 Torbjorn Granlund (tege@adder.cygnus.com) * mpz/powm_ui.c: When shifting E left by C+1, handle out-of-range shift counts. Fix typo when testing negative_result. * mpz/powm.c: Likewise. * mpz/ui_pow_ui.c: New file. * mpz/Makefile.in: Update. * mpz/pow_ui.c: Call __mpn_mul_n instead of __mpn_mul when possible. * mpz/div.c, mpz/div_ui.c, mpz/gcd.c: Prefix external mpn calls. * mpz/gcd.c: Declare mpn_xmod. * mpz/powm.c: Major changes to accommodate changed mpn semantics. * mpz/powm_ui.c: Update from mpz/powm.c. * mpz/tests/tst-io.c: New file. * mpz/tests/tst-logic: New file. * mpz/tests/Makefile.in: Update. * mpz/inp_str.c: Get base right when checking for first digit. * mpz/inp_str.c: Allocate more space for DEST when needed. * mpz/com.c: Use mpn_add_1 and mpn_sub_1. * mpz/and.c, mpz/ior.c: Likewise. Simplify somewhat. * mpz/add_ui.c: Use mpn_add_1 and mpn_sub_1. Rename parameters to be consistent with mpz/sub_ui. General simplifications. * mpz/sub_ui.x: Likewise. Tue Aug 10 19:41:16 1993 Torbjorn Granlund (tege@prudens.matematik.su.se) * mpf: New directory. * mpf/*.c: Merge basic set of mpf functions. * Many logs missing... Sun Apr 25 18:40:26 1993 Torbjorn Granlund (tege@pde.nada.kth.se) * memory.c: Use #if instead of #ifdef for __STDC__ for consistency. * bsd/xtom.c: Likewise. * mpz/div.c: Remove free_me and free_me_size and their usage. Use mpn_divmod for division; corresponding changes in return value convention. * mpz/powm.c: `carry_digit' => `carry_limb'. * bsd/sdiv.c: Clarify comment. Sun Apr 25 00:31:28 1993 Torbjorn Granlund (tege@pde.nada.kth.se) * longlong.h (__udiv_qrnnd_c): Make all variables `unsigned long int'. Sat Apr 24 16:23:33 1993 Torbjorn Granlund (tege@pde.nada.kth.se) * longlong.h (__udiv_qrnnd_c): Make all variables `unsigned long int'. * gmp-impl.h: #define ABS. * (Many files): Use ABS instead of abs. * mpn/generic/sqrt.c, mpz/clrbit.c, mpz/get_si.c, mpz/mod_2exp.c, mpz/pow_ui.c: Cast 1 to mp_limb before shifting. * mpz/perfsqr.c: Use #if, not plain if for exclusion of code for non-32-bit machines. Tue Apr 20 13:13:58 1993 Torbjorn Granlund (tege@du.nada.kth.se) * mpn/generic/sqrt.c: Handle overflow for intermediate quotients by rounding them down to fit. * mpz/perfsqr.c (PP): Define in hexadecimal to avoid GCC warnings. * mpz/inp_str.c (char_ok_for_base): New function. (mpz_inp_str): Use it. Sun Mar 28 21:54:06 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se) * mpz/inp_raw.c: Allocate x_index, not xsize limbs. Mon Mar 15 11:44:06 1993 Torbjorn Granlund (tege@pde.nada.kth.se) * mpz/pprime.c: Declare param `const'. * gmp.h: Add declarations for mpz_com. Thu Feb 18 14:10:34 1993 Torbjorn Granlund (tege@pde.nada.kth.se) * mpq/add.c, mpq/sub.c: Call mpz_clear for t. Fri Feb 12 20:27:34 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se) * mpz/inp_str.c: Recog minus sign as first character. Wed Feb 3 01:36:02 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se) * mpz/iset.c: Handle 0 size. Tue Feb 2 13:03:33 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se) * mpz/mod_ui.c: Initialize dividend_size before it's used. Mon Jan 4 09:11:15 1993 Torbjorn Granlund (tege@sics.se) * bsd/itom.c: Declare param explicitly 'signed'. * bsd/sdiv.c: Likewise. * mpq/cmp.c: Remove unused variable tmp_size. * mpz/powm_ui.c: Fix typo in esize==0 if stmt. * mpz/powm.c: Likewise. Sun Nov 29 01:16:11 1992 Torbjorn Granlund (tege@sics.se) * mpn/generic/divmod_1.c (mpn_divmod_1): Handle divisor_limb == 1 << (BITS_PER_MP_LIMB - 1) specifically. * Reorganize sources. New directories mpn, mpn/MACH, mpn/generic, mpz, mpq, bsd. Use full file name for change logs hereafter. Wed Oct 28 17:40:04 1992 Torbjorn Granlund (tege@jupiter.sics.se) * longlong.h (__hppa umul_ppmm): Fix typos. (__hppa sub_ddmmss): Swap input arguments. * mpz_perfsqr.c (mpz_perfect_square_p): Avoid , before } in initializator. Sun Oct 25 20:30:06 1992 Torbjorn Granlund (tege@jupiter.sics.se) * mpz_pprime.c (mpz_probab_prime_p): Handle numbers <= 3 specifically (used to consider all negative numbers prime). * mpz_powm_ui: `carry_digit' => `carry_limb'. * sdiv: Handle zero dividend specifically. Replace most code in this function with a call to mpn_divmod_1. Fri Sep 11 22:15:55 1992 Torbjorn Granlund (tege@tarrega.sics.se) * mpq_clear: Don't free the MP_RAT! * mpn_lshift, mpn_rshift, mpn_rshiftci: Remove `long' from 4:th arg. Thu Sep 3 01:47:07 1992 Torbjorn Granlund (tege@jupiter.sics.se) * All files: Remove leading _ from mpn function names. Wed Sep 2 22:21:16 1992 Torbjorn Granlund (tege@jupiter.sics.se) Fix from Jan-Hein Buhrman: * mpz_mdiv.c, mpz_mmod.c, mpz_mdm.c: Make them work as documented. * mpz_mmod.c, mpz_mdm.c: Move decl of TEMP_DIVISOR to reflect its life. Sun Aug 30 18:37:15 1992 Torbjorn Granlund (tege@jupiter.sics.se) * _mpz_get_str: Use mpz_sizeinbase for computing out_len. * _mpz_get_str: Don't remove leading zeros. Abort if there are some. Wed Mar 4 17:56:56 1992 Torbjorn Granlund (tege@zevs.sics.se) * gmp.h: Change definition of MP_INT to make the & before params optional. Use typedef to define it. * mp.h: Use typedef to define MINT. Tue Feb 18 14:38:39 1992 Torbjorn Granlund (tege@zevs.sics.se) longlong.h (hppa umul_ppmm): Add missing semicolon. Declare type of __w1 and __w0. Fri Feb 14 21:33:21 1992 Torbjorn Granlund (tege@zevs.sics.se) * longlong.h: Make default count_leading_zeros work for machines > 32 bits. Prepend `__' before local variables to avoid conflicts with users' variables. * mpn_dm_1.c: Remove udiv_qrnnd_preinv ... * gmp-impl.h: ... and put it here. * mpn_mod_1: Use udiv_qrnnd_preinv if it is faster than udiv_qrnnd. Tue Feb 11 17:20:12 1992 Torbjorn Granlund (tege@zevs.sics.se) * mpn_mul: Enhance base case by handling small multiplicands. * mpn_dm_1.c: Revert last change. Mon Feb 10 11:55:15 1992 Torbjorn Granlund (tege@zevs.sics.se) * mpn_dm_1.c: Don't define udiv_qrnnd_preinv unless needed. Fri Feb 7 16:26:16 1992 Torbjorn Granlund (tege@zevs.sics.se) * mpn_mul: Replace code for base case. Thu Feb 6 15:10:42 1992 Torbjorn Granlund (tege@zevs.sics.se) * mpn_dm_1.c (_mpn_divmod_1): Add code for avoiding division by pre-inverting divisor. Sun Feb 2 11:10:25 1992 Torbjorn Granlund (tege@zevs.sics.se) * longlong.h: Make __LLDEBUG__ work differently. (_IBMR2): Reinsert old code. Sat Feb 1 16:43:00 1992 Torbjorn Granlund (tege@zevs.sics.se) * longlong.h (#ifdef _IBMR2): Replace udiv_qrnnd with new code using floating point operations. Don't define UDIV_NEEDS_NORMALIZATION any longer. Fri Jan 31 15:09:13 1992 Torbjorn Granlund (tege@zevs.sics.se) * longlong.h: Define UMUL_TIME and UDIV_TIME for most machines. * longlong.h (#ifdef __hppa): Define umul_ppmm. Wed Jan 29 16:41:36 1992 Torbjorn Granlund (tege@zevs.sics.se) * mpn_cmp: Only one length parameter, assume operand lengths are the same. Don't require normalization. * mpq_cmp, mpz_add, mpz_sub, mpz_gcd, mpn_mul, mpn_sqrt: Change for new mpn_cmp definition. Tue Jan 28 11:18:55 1992 Torbjorn Granlund (tege@zevs.sics.se) * _mpz_get_str: Fix typo in comment. Mon Jan 27 09:44:16 1992 Torbjorn Granlund (tege@zevs.sics.se) * Makefile.in: Add new files. * mpn_dm_1.c: New file with function _mpn_divmod_1. * mpz_dm_ui.c (mpz_divmod_ui): Use _mpn_divmod_1. * mpz_div_ui: Likewise. * mpn_mod_1.c: New file with function _mpn_mod_1. * mpz_mod_ui: Use _mpn_mod_1. Thu Jan 23 18:54:09 1992 Torbjorn Granlund (tege@zevs.sics.se) Bug found by Paul Zimmermann (zimmermann@inria.inria.fr): * mpz_div_ui.c (mpz_div_ui), mpz_dm_ui.c (mpz_divmod_ui): Handle dividend == 0. Wed Jan 22 12:02:26 1992 Torbjorn Granlund (tege@zevs.sics.se) * mpz_pprime.c: Use "" for #include. Sun Jan 19 13:36:55 1992 Torbjorn Granlund (tege@zevs.sics.se) * mpn_rshiftci.c (header): Correct comment. Wed Jan 15 18:56:04 1992 Torbjorn Granlund (tege@zevs.sics.se) * mpz_powm, mpz_powm_ui (if (bsize > msize)): Do alloca (bsize + 1) to make space for ignored quotient at the end. (The quotient might always be an extra limb.) Tue Jan 14 21:28:48 1992 Torbjorn Granlund (tege@zevs.sics.se) * mpz_powm_ui: Fix comment. * mpz_powm: Likewise. Mon Jan 13 18:16:25 1992 Torbjorn Granlund (tege@zevs.sics.se) * tests/Makefile.in: Prepend $(TEST_PREFIX) to Makefile target. Sun Jan 12 13:54:28 1992 Torbjorn Granlund (tege@zevs.sics.se) Fixes from Kazumaro Aoki: * mpz_out_raw: Take abs of size to handle negative values. * mpz_inp_raw: Reallocate before reading ptr from X. * mpz_inp_raw: Store, don't read, size to x->size. Tue Jan 7 17:50:25 1992 Torbjorn Granlund (tege@zevs.sics.se) * gmp.h, mp.h: Remove parameter names from prototypes. Sun Dec 15 00:09:36 1991 Torbjorn Granlund (tege@zevs.sics.se) * tests/Makefile.in: Prepend "./" to file names when executing tests. * Makefile.in: Fix many problems. Sat Dec 14 01:00:02 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpn_sqrt.c: New file with _mpn_sqrt. * mpz_sqrt, mpz_sqrtrem, mpz_perfect_square_p: Use _mpn_sqrt. * msqrt.c: Delete. Create from mpz_sqrtrem.c in Makefile.in. * mpz_do_sqrt.c: Delete. * Makefile.in: Update to reflect these changes. * Makefile.in, configure, configure.subr: New files (from bothner@cygnus.com). * dist-Makefile: Delete. * mpz_fac_ui: Fix comment. * mpz_random2: Rewrite a bit to make it possible for the most significant limb to be == 1. * mpz_pprime.c (mpz_probab_prime_p): Remove \t\n. Fri Dec 13 23:10:02 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_do_sqrt: Simplify special case for U == 0. * m*sqrt*.c, mpz_perfsqr.c (mpz_perfect_square_p): Rename _mpz_impl_sqrt to _mpz_do_sqrt. Fri Dec 13 12:52:28 1991 Torbjorn Granlund (tege@zevs.sics.se) * gmp-impl.h (MPZ_TMP_INIT): Cast to the right type. Thu Dec 12 22:17:29 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpn_add, mpn_sub, mpn_mul, mpn_div: Change type of several variables to mp_size. Wed Dec 11 22:00:34 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpn_rshift.c: Fix header comments. Mon Dec 9 17:46:10 1991 Torbjorn Granlund (tege@zevs.sics.se) Released 1.2. * gmp-impl.h (MPZ_TMP_INIT): Cast alloca return value. * dist-Makefile: Add missing dependency for cre-mparam. * mpz_mdiv.c, mpz_mmod.c, mpz_mdm.c, mpz_mdiv_ui.c, mpz_mmod_ui.c, mpz_mdm_ui.c: Remove obsolete comment. * dist-Makefile (clean): clean in tests subdir too. * tests/Makefile: Define default values for ROOT and SUB. * longlong.h (__a29k__ udiv_qrnnd): Change "q" to "1" for operand 2 constraint. Mon Nov 11 00:06:05 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_sizeinb.c (mpz_sizeinbase): Special code for size == 0. Sat Nov 9 23:47:38 1991 Torbjorn Granlund (tege@zevs.sics.se) Released 1.1.94. * dist-Makefile, Makefile, tests/Makefile: Merge tests into distribution. Fri Nov 8 22:57:19 1991 Torbjorn Granlund (tege@zevs.sics.se) * gmp.h: Don't use keyword `signed' for non-ANSI compilers. Thu Nov 7 22:06:46 1991 Torbjorn Granlund (tege@zevs.sics.se) * longlong.h: Cosmetic changes to keep it identical to gcc2 version of longlong.h. * longlong.h (__ibm032__): Fix operand order for add_ssaaaa and sub_ddmmss. Mon Nov 4 00:36:46 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpn_mul: Fix indentation. * mpz_do_sqrt: Don't assume 32 bit limbs (had constant 4294967296.0). * mpz_do_sqrt: Handle overflow in conversion from double returned by SQRT to mp_limb. * gmp.h: Add missing function definitions. Sun Nov 3 18:25:25 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_pow_ui: Change type of `i' to int. * ChangeLog: Add change log entry. * ChangeLog: Add change log entry. * ChangeLog: Add change log entry. * ChangeLog: Add change log entry. * ChangeLog: Add change log entry. * ChangeLog: Add change log entry. * ChangeLog: Add change log entry. * ChangeLog: Add change log entry. Stack overflow. * mpz_pow_ui.c: Fix typo in comment. * dist-Makefile: Create rpow.c from mpz_powm_ui.c. * mpz_powm_ui.c: Add code for rpow. * rpow.c: Delete this file. The rpow function is now implemented in mpz_powm_ui.c. * mpz_fac_ui.c: New file. * gmp.h, dist-Makefile: Add stuff for mpz_fac_ui. Bug found by John Amanatides (amana@sasquatch.cs.yorku.ca): * mpz_powm_ui, mpz_powm: Call _mpn_mul in the right way, with the first argument not smaller than the second. Tue Oct 29 13:56:55 1991 Torbjorn Granlund (tege@zevs.sics.se) * cre-conv-tab.c (main), cre-mparam.c (main): Fix typo in output header text. Mon Oct 28 00:35:29 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_random2: Handle size == 0. * gmp-impl.h (struct __mp_bases): Rename chars_per_limb_exactly to chars_per_bit_exactly, and change its definition. * cre-conv-tab.c (main): Output field according to its new definition. * mpz_out_str, _mpz_get_str, mpz_sizeinb, mout: Use chars_per_bit_exactly. * mpz_random2: Change the loop termination condition in order to get a large most significant limb with higher probability. * gmp.h: Add declaration of new mpz_random2 and mpz_get_si. * mpz_get_si.c: New file. * dist-Makefile: Add mpz_random2 and mpz_get_si. * mpz_sizeinb.c (mpz_sizeinbase): Special code for base being a power of 2, giving exact result. * mpn_mul: Fix MPN_MUL_VERIFY in various ways. * mpn_mul: New macro KARATSUBA_THRESHOLD. * mpn_mul (karatsuba's algorithm): Don't write intermediate results to prodp, use temporary pp instead. (Intermediate results can be larger than the final result, possibly writing into hyperspace.) * mpn_mul: Make smarter choice between Karatsuba's algorithm and the shortcut algorithm. * mpn_mul: Fix typo, cy instead of xcy. Unify carry handling code. Sun Oct 27 19:57:32 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpn_mul: In non-classical case, choose Karatsuba's algorithm only when usize > 1.5 vsize. * mpn_mul: Break between classical and Karatsuba's algorithm at KARATSUBA_THRESHOLD, if defined. Default to 8. * mpn_div: Kludge to fix stray memory read. Sat Oct 26 20:06:14 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_gcdext: Handle a = b = 0. Remove memory leakage by calling mpz_clear for all temporary variables. * mpz_gcd: Reduce w_bcnt in _mpn_lshift call to hold that function's argument constraints. Compute wsize correctly. * mpz_gcd: Fix typo in comment. * memory.c (_mp_default_allocate, _mp_default_reallocate): Call abort if allocation fails, don't just exit. Fri Oct 25 22:17:20 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_random2.c: New file. Thu Oct 17 18:06:42 1991 Torbjorn Granlund (tege@zevs.sics.se) Bugs found by Pierre-Joseph Gailly (pjg@sunbim.be): * mpq_cmp: Take sign into account, don't just compare the magnitudes. * mpq_cmp: Call _mpn_mul in the right way, with the first argument not smaller than the second. Wed Oct 16 19:27:32 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_random: Ensure the result is normalized. Tue Oct 15 14:55:13 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_clrbit: Support non-ANSI compilers. Wed Oct 9 18:03:28 1991 Torbjorn Granlund (tege@zevs.sics.se) * longlong.h (68k add_ssaaaa, sub_ddmmss): Generalize constraints. Tue Oct 8 17:42:59 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_mdm_ui: Add comments. * mpz_mdiv: Use MPZ_TMP_INIT instead of mpz_init. * mpz_init_ui: Change spacing and header comment. Thu Oct 3 18:36:13 1991 Torbjorn Granlund (tege@zevs.sics.se) * dist-Makefile: Prepend `./' before some filenames. Sun Sep 29 14:02:11 1991 Torbjorn Granlund (tege@zevs.sics.se) Released 1.1 (public). * mpz_com: New name of mpz_not. * dist-Makefile: Change mpz_not to mpz_com. Tue Sep 24 12:44:11 1991 Torbjorn Granlund (tege@zevs.sics.se) * longlong.h: Fix header comment. Mon Sep 9 15:16:24 1991 Torbjorn Granlund (tege@zevs.sics.se) Released 1.0.92. * mpn_mul.c (_mpn_mul): Handle leading zero limbs in non-Karatsuba case. * longlong.h (m68000 umul_ppmm): Clobber one register less by slightly rearranging the code. Sun Sep 1 18:53:25 1991 Torbjorn Granlund (tege@zevs.sics.se) * dist-Makefile (stamp-stddefh): Fix typo. Sat Aug 31 20:41:31 1991 Torbjorn Granlund (tege@zevs.sics.se) Released 1.0.91. * mpz_mdiv.c, mpz_mmod.c, mpz_mdm.c, mpz_mdiv_ui.c, mpz_mmod_ui.c, mpz_mdm_ui.c: New files and functions. * gmp.h, gmp.texi: Define the new functions. Fri Aug 30 08:32:56 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_gcdext: Compute t argument from the other quantities at the end, of the function, not in the loop. New feature: Allow t to be NULL. * mpz_add.c, mpz_sub.c, mpz_mul.c, mpz_powm.c, mpz_gcd.c: Don't include "mp.h". Use type name `MP_INT' always. * dist-Makefile, mpz_cmp.c: Merge mcmp.c from mpz_cmp.c. Wed Aug 28 00:45:11 1991 Torbjorn Granlund (tege@zevs.sics.se) * dist-Makefile (documentation): Go via tmp.texi to avoid the creation of gmp.dvi if any errors occur. Make tex read input from /dev/null. Fri Aug 23 15:58:52 1991 Torbjorn Granlund (tege@zevs.sics.se) * longlong.h (68020, i386): Don't define machine-dependent __umulsidi3 (so the default definition is used). * longlong.h (all machines): Cast all operands, sources and destinations, to `unsigned long int'. * longlong.h: Add gmicro support. Thu Aug 22 00:28:29 1991 Torbjorn Granlund (tege@zevs.sics.se) * longlong.h: Rename BITS_PER_LONG to LONG_TYPE_SIZE. * longlong.h (__ibm032__): Define count_leading_zeros and umul_ppmm. * longlong.h: Define UMUL_TIME and UDIV_TIME for some CPUs. * _mpz_get_str.c: Add code to do division by big_base using only umul_qrnnd, if that is faster. Use UMUL_TIME and UDIV_TIME to decide which variant to use. Wed Aug 21 15:45:23 1991 Torbjorn Granlund (tege@zevs.sics.se) * longlong.h (__sparc__ umul_ppmm): Move two insn from end to the nops. (Saves two insn.) * longlong.h (__sparc__ umul_ppmm): Rewrite in order to avoid branch, and to permit input/output register overlap. * longlong.h (__29k__): Remove duplicated udiv_qrnnd definition. * longlong.h (__29k__ umul_ppmm): Split asm instructions into two asm statements (gives better code if either the upper or lower part of the product is unused. Tue Aug 20 17:57:59 1991 Torbjorn Granlund (tege@zevs.sics.se) * _mpz_get_str.c (outside of functions): Remove num_to_ascii_lower_case and num_to_ascii_upper_case. Use string constants in the function instead. Mon Aug 19 00:37:42 1991 Torbjorn Granlund (tege@zevs.sics.se) * cre-conv-tab.c (main): Output table in hex. Output 4 fields, not 3, for components 0 and 1. * gmp.h: Add declaration of mpq_neg. Released 1.0beta.13. * _mpz_set_str.c (mpz_set_str): Cast EOF and SPC to char before comparing to enum literals SPC and EOF. This makes the code work for compilers where `char' is unsigned. (Bug found by Brian Beuning). Released 1.0beta.12. * mpz_mod_ui: Remove references to quot. Remove quot_ptr, quot_size declarations and assignment code. Sun Aug 18 14:44:26 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_mod_ui: Handle dividend < 0. Released 1.0beta.11. * mpz_dm_ui, mpz_div_ui, mpz_mod_ui, sdiv: Make them share the same general structure, variable names, etc. * sdiv: Un-normalize the remainder in n1 before it is negated. * longlong.h: Mention UDIV_NEEDS_NORMALIZATION in description of udiv_qrnnd. * mpz_dm_ui.c (mpz_divmod_ui), mpz_div_ui.c (mpz_div_ui): Increment the quotient size if the dividend size is incremented. (Bug found by Brian Beuning.) * mpz_mod_ui: Shift back the remainder, if UDIV_NEEDS_NORMALIZATION. (Bug found by Brian Beuning.) * mpz_mod_ui: Replace "digit" by "limb". * mpz_perfsqr.c (mpz_perfect_square_p): Disable second test case for non-32-bit machines (PP is hardwired for such machines). * mpz_perfsqr.c (outside of functions): Define PP value with an L. * mpn_mul.c (_mpn_mul): Add verification code that is activated if DEBUG is defined. Replace "digit" by "limb". * mpn_mul.c (_mpn_mul: Karatsuba's algorithm: 4.): Normalize temp after the addition. * mpn_mul.c (_mpn_mul: Karatsuba's algorithm: 1.): Compare u0_size and v0_size, and according to the result, swap arguments in recursive call. (Don't violate mpn_mul's own argument constraints.) Fri Aug 16 13:47:12 1991 Torbjorn Granlund (tege@zevs.sics.se) Released 1.0beta.10. * longlong.h (IBMR2): Add udiv_qrnnd. * mpz_perfsqr: Remove unused variables. * mpz_and (case for different signs): Initialize loop variable i! * dist-Makefile: Update automatically generated dependencies. * dist-Makefile (madd.c, msub.c, pow.c, mult.c, gcd.c): Add mp.h, etc to dependency file lists. * longlong.h (add_ssaaaa, sub_ddmmss [C default versions]): Make __x `unsigned long int'. * longlong.h: Add `int' after `unsigned' and `long' everywhere. Wed Aug 14 18:06:48 1991 Torbjorn Granlund (tege@zevs.sics.se) * longlong.h: Add ARM, i860 support. * mpn_lshift, mpn_rshift, mpn_rshiftci: Rename *_word with *_limb. Tue Aug 13 21:57:43 1991 Torbjorn Granlund (tege@zevs.sics.se) * _mpz_get_str.c, _mpz_set_str.c, mpz_sizeinb.c (mpz_sizeinbase), mpz_out_str.c, mout.c: Remove declaration of __mp_bases. * gmp-impl.h: Put it here, and make it `const'. * cre-conv-tab.c (main): Make struct __mp_bases `const'. Mon Aug 12 17:11:46 1991 Torbjorn Granlund (tege@zevs.sics.se) * cre-conv-tab.c (main): Use %lu in printf for long ints. * dist-Makefile: Fix cre-* dependencies. * cre-conv-tab.c (main): Output field big_base_inverted. * gmp-impl.h (struct bases): New field big_base_inverted. * gmp-impl.h (struct bases): Change type of chars_per_limb_exactly to float (in order to keep the structure smaller). * mp.h, gmp.h: Change names of macros for avoiding multiple includes. Fri Aug 9 18:01:36 1991 Torbjorn Granlund (tege@zevs.sics.se) * _mpz_get_str: Only shift limb array if normalization_steps != 0 (optimization). * longlong.h (sparc umul_ppmm): Use __asm__, not asm. * longlong.h (IBMR2 umul_ppmm): Refer to __m0 and __m1, not to m0 and m1 (overlap between output and input operands did not work). * longlong.h: Add VAX, ROMP and HP-PA support. * longlong.h: Sort the machine dependent code in alphabetical order on the CPU name. * longlong.h: Hack comments. Thu Aug 8 14:13:36 1991 Torbjorn Granlund (tege@zevs.sics.se) Released 1.0beta.9. * longlong.h: Define BITS_PER_LONG to 32 if it's not already defined. * Define __BITS4 to BITS_PER_LONG / 4. * Don't assume 32 bit word size in "count_leading_zeros" C macro. Use __BITS4 and BITS_PER_LONG instead. * longlong.h: Don't #undef internal macros (reverse change of Aug 3). * longlong.h (68k): Define add_ssaaaa sub_ddmmss, and umul_ppmm even for plain mc68000. * mpq_div: Flip the sign of the numerator *and* denominator of the result if the intermediate denominator is negative. * mpz_and.c, mpz_ior.c: Use MPN_COPY for all copying operations. * mpz_and.c: Compute the result size more conservatively. * mpz_ior.c: Likewise. * mpz_realloc: Never allocate zero space even if NEW_SIZE == 0. * dist-Makefile: Remove madd.c, msub.c, pow.c, mult.c, gcd.c from BSDMP_SRCS. * dist-Makefile: Create mult.c from mpz_mul.c. * mult.c: Delete this file. * _mpz_set_str: Normalize the result (for bases 2, 4, 8... it was not done properly if the input string had many leading zeros). Sun Aug 4 16:54:14 1991 Torbjorn Granlund (tege@zevs.sics.se) * dist-Makefile (gcd.c, pow.c, madd.c, msub.c): Make these targets work with VPATH and GNU MP. * mpz_gcd: Don't call mpz_set; inline its functionality. * mpq_mul, mpq_div: Fix several serious typos. * mpz_dmincl, mpz_div: Don't normalize the quotient if it's already zero. * mpq_neg.c: New file. * dist-Makefile: Remove obsolete dependencies. * mpz_sub: Fix typo. Bugs found by Pierre-Joseph Gailly (pjg@sunbim.be): * mpq_mul, mpq_div: Initialize tmp[12] variables even when the gcd is just 1. * mpz_gcd: Handle gcd(0,v) and gcd(u,0) in special cases. Sat Aug 3 23:45:28 1991 Torbjorn Granlund (tege@zevs.sics.se) * longlong.h: Clean up comments. * longlong.h: #undef internal macros. Fri Aug 2 18:29:11 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpq_set_si, mpq_set_ui: Canonicalize 0/x to 0/1. * mpq_set_si, mpq_set_ui: Cosmetic formatting changes. * mpz_dmincl.c: Normalize the remainder before shifting it back. * mpz_dm_ui.c (mpz_divmod_ui): Handle rem == dividend. * mpn_div.c: Fix comment. * mpz_add.c, mpz_sub.c: Use __MP_INT (not MP_INT) for intermediate type, in order to work for both GNU and Berkeley functions. * dist-Makefile: Create gcd.c from mpz_gcd.c, pow.c from mpz_powm, madd.c from mpz_add.c, msub.c from mpz_sub.c. respectively. * pow.c, gcd.c, mpz_powmincl.c, madd.c, msub.c: Remove these. * mpz_powm.c, mpz_gcd.c, mpz_add.c, mpz_sub.c: #ifdef for GNU and Berkeley function name variants. * dist-Makefile: Add created files to "clean" target. Tue Jul 16 15:19:46 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpq_get_den: No need for absolute value of the size, the denominator is always positive. * mpz_get_ui: If the operand is zero, return zero. Don't read the limb array! * mpz_dmincl.c: Don't ignore the return value from _mpn_rshift, it is the size of the remainder. Mon Jul 15 11:08:05 1991 Torbjorn Granlund (tege@zevs.sics.se) * Several files: Remove unused variables and functions. * gmp-impl.h: Declare _mpz_impl_sqrt. * mpz_dm_ui (mpz_divmod_ui), sdiv: Shift back the remainder if UDIV_NEEDS_NORMALIZATION. (Fix from Brian Beuning.) * mpz_dm_ui.c, sdiv: Replace *digit with *limb. * mpz_ior: Add missing else statement in -OP1 | -OP2 case. * mpz_ior: Add missing else statement in OP1 | -OP2 case. * mpz_ior: Swap also OP1 and OP2 pointers in -OP1 & OP2 case. * mpz_ior: Duplicate _mpz_realloc code. * mpz_and: Add missing else statement in -OP1 & -OP2 case. * mpz_and: Rewrite OP1 & -OP2 case. * mpz_and: Swap also OP1 and OP2 pointers in -OP1 & OP2 case. * mpz_gcdext: Loop in d1.size (not b->size). (Fix from Brian Beuning.) * mpz_perfsqr: Fix argument order in _mpz_impl_sqrt call. (Fix from Brian Beuning.) Fri Jul 12 17:10:33 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpq_set.c, mpq_set_ui.c, mpq_set_si.c, mpq_inv.c, mpq_get_num.c, mpq_get_den.c, mpq_set_num.c, mpq_set_den.c: New files. * mpz_dmincl.c: Remove second re-allocation of rem->d. It was never executed. * dist-Makefile: Use `-r' instead of `-x' for test for ranlib (as some unixes' test doesn't have the -r option). * *.*: Cast allocated pointers to the appropriate type (makes old C compilers happier). * cre-conv-tab.c (main): Divide max_uli by 2 and multiply again after conversion to double. (Kludge for broken C compilers.) * dist-Makefile (stamp-stddefh): New target. Test if "stddef.h" exists in the system and creates a minimal one if it does not exist. * cre-stddefh.c: New file. * dist-Makefile: Make libgmp.a and libmp.a depend on stamp-stddefh. * dist-Makefile (clean): Add some more. * gmp.h, mp.h: Unconditionally include "stddef.h". Thu Jul 11 10:08:21 1991 Torbjorn Granlund (tege@zevs.sics.se) * min: Do ungetc of last read character. * min.c: include stdio.h. * dist-Makefile: Go via tmp- files for cre* redirection. * dist-Makefile: Add tmp* to "clean" target. * dist-Makefile: Use LOCAL_CC for cre*, to simplify cross compilation. * gmp.h, mp.h: Don't define NULL here. * gmp-impl.h: Define it here. Wed Jul 10 14:13:33 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_mod_2exp: Don't copy too much, overwriting most significant limb. * mpz_and, mpz_ior: Don't read op[12]_ptr from op[12] when reallocating res, if op[12]_ptr got their value from alloca. * mpz_and, mpz_ior: Clear up comments. * cre-mparam.c: Output parameters for `short int' and `int'. * mpz_and, mpz_ior: Negate negative op[12]_size in several places. Tue Jul 9 18:40:30 1991 Torbjorn Granlund (tege@zevs.sics.se) * gmp.h, mp.h: Test for _SIZE_T defined before typedef'ing size_t. (Fix for Sun lossage.) * gmp.h: Add declaration of mpq_clear. * dist-Makefile: Check if "ranlib" exists, before using it. * dist-Makefile: Add mpz_sqrtrem.c and mpz_size.c. * mpz_powm: Fix typo, "pow" instead of "mpz_powm". Fri Jul 5 19:08:09 1991 Torbjorn Granlund (tege@zevs.sics.se) * move: Remove incorrect comment. * mpz_free, mpq_free: Rename to *_clear. * dist-Makefile: Likewise. * mpq_add, mpq_sub, mpq_mul, mpq_div: Likewise. * mpz_dmincl.c: Don't call "move", inline its functionality. Thu Jul 4 00:06:39 1991 Torbjorn Granlund (tege@zevs.sics.se) * Makefile: Include dist-Makefile. Fix dist target to include dist-Makefile (with the name "Makefile" in the archive). * dist-Makefile: New file made from Makefile. Add new mpz_... functions. * mpz_powincl.c New file for mpz_powm (Berkeley MP pow) functionality. Avoids code duplication. * pow.c, mpz_powm.c: Include mpz_powincl.c * mpz_dmincl.c: New file containing general division code. Avoids code duplication. * mpz_dm.c (mpz_divmod), mpz_mod.c (mpz_mod), mdiv.c (mdiv): Include mpz_dmincl.c. * _mpz_get_str: Don't call memmove, unless HAS_MEMMOVE is defined. Instead, write the overlapping memory copying inline. * mpz_dm_ui.c: New name for mpz_divmod_ui.c (SysV file name limit). * longlong.h: Don't use #elif. * mpz_do_sqrt.c: Likewise. * longlong.h: Use __asm__ instead of asm. * longlong.h (sparc udiv_qrnnd): Make it to one string over several lines. * longlong.h: Preend __ll_ to B, highpart, and lowpart. * longlong.h: Move array t in count_leading_zeros to the new file mp_clz_tab.c. Rename the array __clz_tab. * All files: #ifdef for traditional C compatibility. Wed Jul 3 11:42:14 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_and: Initialize res_ptr always (used to be initialized only when reallocating). * longlong.h (umul_ppmm [C variant]): Make __ul...__vh `unsigned int', and cast the multiplications. This way compilers more easily can choose cheaper multiplication instructions. * mpz_mod_2exp: Handle input argument < modulo argument. * mpz_many: Make sure mp_size is the type for sizes, not int. * mpz_init, mpz_init_set*, mpq_init, mpq_add, mpq_sub, mpq_mul, mpq_div: Change mpz_init* interface. Structure pointer as first arg to initialization function, no longer *return* struct. Sun Jun 30 19:21:44 1991 Torbjorn Granlund (tege@zevs.sics.se) * Rename mpz_impl_sqrt.c to mpz_do_sqrt.c to satisfy SysV 14 character file name length limit. * Most files: Rename MINT to MP_INT. Rename MRAT to MP_RAT. * mpz_sizeinb.c: New file with function mpz_sizeinbase. * mp_bases.c: New file, with array __mp_bases. * _mpz_get_str, _mpz_set_str: Remove struct bases, use extern __mp_bases instead. * mout, mpz_out_str: Use array __mp_bases instead of function _mpz_get_cvtlen. * mpz_get_cvtlen.c: Remove. * Makefile: Update. Sat Jun 29 21:57:28 1991 Torbjorn Granlund (tege@zevs.sics.se) * longlong.h (__sparc8__ umul_ppmm): Insert 3 nop:s for wr delay. * longlong.h (___IBMR2__): Define umul_ppmm, add_ssaaaa, sub_ddmmss. * longlong.h (__sparc__): Don't call .umul; expand asm instead. Don't define __umulsidi3 (i.e. use default definition). Mon Jun 24 17:37:23 1991 Torbjorn Granlund (tege@amon.sics.se) * _mpz_get_str.c (num_to_ascii_lower_case, num_to_ascii_upper_case): Swap 't' and 's'. Sat Jun 22 13:54:01 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_gcdext.c: New file. * mpn_mul: Handle carry and unexpected operand sizes in last additions/subtractions. (Bug trigged when v1_size == 1.) * mp*_alloc*: Rename functions to mp*_init* (files to mp*_iset*.c). * mpq_*: Call mpz_init*. * mpz_pow_ui, rpow: Use _mpn_mul instead of mult. Restructure. Wed May 29 20:32:33 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_get_cvtlen: multiply by size. Sun May 26 15:01:15 1991 Torbjorn Granlund (tege@bella.nada.kth.se) Alpha-release 0.95. Fixes from Doug Lea (dl@g.oswego.edu): * mpz_mul_ui: Loop to MULT_SIZE (not PROD_SIZE). Adjust PROD_SIZE correctly. * mpz_div: Prepend _ to mpz_realloc. * mpz_set_xs, mpz_set_ds: Fix typos in function name. Sat May 25 22:51:16 1991 Torbjorn Granlund (tege@bella.nada.kth.se) * mpz_divmod_ui: New function. * sdiv: Make the sign of the remainder correct. Thu May 23 15:28:24 1991 Torbjorn Granlund (tege@zevs.sics.se) * Alpha-release 0.94. * mpz_mul_ui: Include longlong.h. * mpz_perfsqr.c (mpz_perfect_square_p): Call _mpz_impl_sqrt instead of msqrt. * mpz_impl_sqrt: Don't call "move", inline its functionality. * mdiv: Use MPN_COPY instead of memcpy. * rpow, mpz_mul, mpz_mod_2exp: Likewise. * pow.c: Likewise, and fix bug in the size arg. * xtom: Don't use mpz_alloc, inline needed code instead. Call _mpz_set_str instead of mpz_set_str. * Makefile: Make two libraries, libmp.a and libgmp.a. Thu May 22 20:25:29 1991 Torbjorn Granlund (tege@zevs.sics.se) * Add manual to distribution. * Fold in many missing routines described in the manual. * Update Makefile. Wed May 22 13:48:46 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_set_str: Make it handle 0x prefix OK. Sat May 18 18:31:02 1991 Torbjorn Granlund (tege@zevs.sics.se) * memory.c (_mp_default_reallocate): Swap OLD_SIZE and NEW_SIZE arguments. * mpz_realloc (_mpz_realloc): Swap in call to _mp_reallocate_func. * min: Likewise. Thu May 16 20:43:05 1991 Torbjorn Granlund (tege@zevs.sics.se) * memory.c: Make the default allocations functions global. * mp_set_fns (mp_set_memory_functions): Make a NULL pointer mean the default memory function. Wed May 8 20:02:42 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_div: Handle DEN the same as QUOT correctly by copying DEN->D even if no normalization is needed. * mpz_div: Rework reallocation scheme, to avoid excess copying. * mpz_sub_ui.c, mpz_add_ui.c: New files. * mpz_cmp.c, mpz_cmp_ui.c: New files. * mpz_mul_2exp: Handle zero input MINT correctly. * mpn_rshiftci: Don't handle shift counts > BITS_PER_MP_DIGIT. * mpz_out_raw.c, mpz_inp_raw.c: New files for raw I/O. Tue May 7 15:44:58 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpn_rshift: Don't handle shift counts > BITS_PER_MP_DIGIT. * mpz_div_2exp: Don't call _mpn_rshift with cnt > BITS_PER_MP_DIGIT. * gcd, mpz_gcd: Likewise. * gcd, mpz_gcd: Handle common 2 factors correctly. Mon May 6 20:22:59 1991 Torbjorn Granlund (tege@zevs.sics.se) * gmp-impl.h (MPN_COPY): Inline a loop instead of calling memcpy. * gmp-impl.h, mpz_get_str, rpow: Swap DST and SRC in TMPCOPY* macros. Sun May 5 15:16:23 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpz_div: Remove test for QUOT == 0. Sun Apr 28 20:21:04 1991 Torbjorn Granlund (tege@zevs.sics.se) * pow: Don't make MOD normalization in place, as it's a bad idea to write on an input parameter. * pow: Reduce BASE if it's > MOD. * pow, mult, mpz_mul: Simplify realloc code. Sat Apr 27 21:03:11 1991 Torbjorn Granlund (tege@zevs.sics.se) * Install multiplication using Karatsuba's algorithm as default. Fri Apr 26 01:03:57 1991 Torbjorn Granlund (tege@zevs.sics.se) * msqrt: Store in ROOT even for U==0, to make msqrt(0) defined. * mpz_div_2exp.c, mpz_mul_2exp.c: New files for shifting right and left, respectively. * gmp.h: Add definitions for mpz_div_2exp and mpz_mul_2exp. * mlshift.c, mrshift.c: Remove. Wed Apr 24 21:39:22 1991 Torbjorn Granlund (tege@zevs.sics.se) * mpn_mul: Check only for m2_size == 0 in function header. Mon Apr 22 01:31:57 1991 Torbjorn Granlund (tege@zevs.sics.se) * karatsuba.c: New file for Karatsuba's multiplication algorithm. * mpz_random, mpz_init, mpz_mod_2exp: New files and functions. * mpn_cmp: Fix header comment. Sun Apr 21 00:10:44 1991 Torbjorn Granlund (tege@zevs.sics.se) * pow: Switch off initial base reduction. Sat Apr 20 22:06:05 1991 Torbjorn Granlund (tege@echnaton.sics.se) * mpz_get_str: Don't generate initial zeros for initial word. Used to write outside of allocated storage. Mon Apr 15 15:48:08 1991 Torbjorn Granlund (tege@zevs.sics.se) * _mpz_realloc: Make it accept size in number of mp_digits. * Most functions: Use new _mpz_realloc definition. * mpz_set_str: Remove calls _mp_free_func. * Most functions: Rename mpn_* to _mpn_*. Rename mpz_realloc to _mpz_realloc. * mpn_lshift: Redefine _mpn_lshift to only handle small shifts. * mdiv, mpz_div, ...: Changes for new definition of _mpn_lshift. * msqrt, mp*_*shift*: Define cnt as unsigned (for speed). Sat Apr 6 14:05:16 1991 Torbjorn Granlund (tege@musta.nada.kth.se) * mpn_mul: Multiply by the first digit in M2 in a special loop instead of zeroing the product area. * mpz_abs.c: New file. * sdiv: Implement as mpz_div_si for speed. * mpn_add: Make it work for second source operand == 0. * msub: Negate the correct operand, i.e. V before swapping, not the smaller of U and V! * madd, msub: Update abs_* when swapping operands, and not after (optimization). Fri Apr 5 00:19:36 1991 Torbjorn Granlund (tege@black.nada.kth.se) * mpn_sub: Make it work for subtrahend == 0. * madd, msub: Rewrite to minimize mpn_cmp calls. Ensure mpn_cmp is called with positive sizes (used to be called incorrectly with negative sizes sometimes). * msqrt: Make it divide by zero if fed with a negative number. * Remove if statement at end of precision calculation that was never true. * itom, mp.h: The argument is of type short, not int. * mpz_realloc, gmp.h: Make mpz_realloc return the new digit pointer. * mpz_get_str.c, mpz_set_str.c, mpz_new_str.c: Don't include mp.h. * Add COPYING to distribution. * mpz_div_ui.c, mpz_div_si.c, mpz_new_ui.c, mpz_new_si.c: New files. Fri Mar 15 00:26:29 1991 Torbjorn Granlund (tege@musta.nada.kth.se) * Add Copyleft headers to all files. * mpn_mul.c, mpn_div.c: Add header comments. * mult.c, mdiv.c: Update header comments. * mpq_add.c, mpq_sub.c, mpq_div.c, mpq_new.c, mpq_new_ui.c, mpq_free.c: New files for rational arithmetics. * mpn_lshift.c: Avoid writing the most significant word if it is 0. * mdiv.c: Call mpn_lshift for the normalization. * mdiv.c: Remove #ifdefs. * Makefile: Add ChangeLog to DISTFILES. * mpn_div.c: Make the add_back code work (by removing abort()). * mpn_div.c: Make it return if the quotient is size as compared with the difference NSIZE - DSIZE. If the stored quotient is larger than that, return 1, otherwise 0. * gmp.h: Fix mpn_div declaration. * mdiv.c: Adopt call to mpn_div. * mpz_div.c: New file (developed from mdiv.c). * README: Update routine names. Thu Mar 14 18:45:28 1991 Torbjorn Granlund (tege@musta.nada.kth.se) * mpq_mul.c: New file for rational multiplication. * gmp.h: Add definitions for rational arithmetics. * mpn_div: Kludge the case where the high numerator digit > the high denominator digit. (This code is going to be optimized later.) * New files: gmp.h for GNU specific functions, gmp-common.h for definitions common for mp.h and gmp.h. * Ensure mp.h just defines what BSD mp.h defines. * pow.c: Fix typo for bp allocation. * Rename natural number functions to mpn_*, integer functions to mpz_*. Tue Mar 5 18:47:04 1991 Torbjorn Granlund (tege@musta.nada.kth.se) * mdiv.c (_mp_divide, case 2): Change test for estimate of Q from "n0 >= r" to "n0 > r". * msqrt: Tune the increasing precision scheme, to do fewer steps. Tue Mar 3 18:50:10 1991 Torbjorn Granlund (tege@musta.nada.kth.se) * msqrt: Use the low level routines. Use low precision in the beginning, and increase the precision as the result converges. (This optimization gave a 6-fold speedup.) gcl/gmp4/INSTALL000066400000000000000000000366101242227143400135320ustar00rootroot00000000000000Installation Instructions ************************* Copyright (C) 1994-1996, 1999-2002, 2004-2013 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without warranty of any kind. Basic Installation ================== Briefly, the shell command `./configure && make && make install' should configure, build, and install this package. The following more-detailed instructions are generic; see the `README' file for instructions specific to this package. Some packages provide this `INSTALL' file but do not implement all of the features documented below. The lack of an optional feature in a given package is not necessarily a bug. More recommendations for GNU packages can be found in *note Makefile Conventions: (standards)Makefile Conventions. The `configure' shell script attempts to guess correct values for various system-dependent variables used during compilation. It uses those values to create a `Makefile' in each directory of the package. It may also create one or more `.h' files containing system-dependent definitions. Finally, it creates a shell script `config.status' that you can run in the future to recreate the current configuration, and a file `config.log' containing compiler output (useful mainly for debugging `configure'). It can also use an optional file (typically called `config.cache' and enabled with `--cache-file=config.cache' or simply `-C') that saves the results of its tests to speed up reconfiguring. Caching is disabled by default to prevent problems with accidental use of stale cache files. If you need to do unusual things to compile the package, please try to figure out how `configure' could check whether to do them, and mail diffs or instructions to the address given in the `README' so they can be considered for the next release. If you are using the cache, and at some point `config.cache' contains results you don't want to keep, you may remove or edit it. The file `configure.ac' (or `configure.in') is used to create `configure' by a program called `autoconf'. You need `configure.ac' if you want to change it or regenerate `configure' using a newer version of `autoconf'. The simplest way to compile this package is: 1. `cd' to the directory containing the package's source code and type `./configure' to configure the package for your system. Running `configure' might take a while. While running, it prints some messages telling which features it is checking for. 2. Type `make' to compile the package. 3. Optionally, type `make check' to run any self-tests that come with the package, generally using the just-built uninstalled binaries. 4. Type `make install' to install the programs and any data files and documentation. When installing into a prefix owned by root, it is recommended that the package be configured and built as a regular user, and only the `make install' phase executed with root privileges. 5. Optionally, type `make installcheck' to repeat any self-tests, but this time using the binaries in their final installed location. This target does not install anything. Running this target as a regular user, particularly if the prior `make install' required root privileges, verifies that the installation completed correctly. 6. You can remove the program binaries and object files from the source code directory by typing `make clean'. To also remove the files that `configure' created (so you can compile the package for a different kind of computer), type `make distclean'. There is also a `make maintainer-clean' target, but that is intended mainly for the package's developers. If you use it, you may have to get all sorts of other programs in order to regenerate files that came with the distribution. 7. Often, you can also type `make uninstall' to remove the installed files again. In practice, not all packages have tested that uninstallation works correctly, even though it is required by the GNU Coding Standards. 8. Some packages, particularly those that use Automake, provide `make distcheck', which can by used by developers to test that all other targets like `make install' and `make uninstall' work correctly. This target is generally not run by end users. Compilers and Options ===================== Some systems require unusual options for compilation or linking that the `configure' script does not know about. Run `./configure --help' for details on some of the pertinent environment variables. You can give `configure' initial values for configuration parameters by setting variables in the command line or in the environment. Here is an example: ./configure CC=c99 CFLAGS=-g LIBS=-lposix *Note Defining Variables::, for more details. Compiling For Multiple Architectures ==================================== You can compile the package for more than one kind of computer at the same time, by placing the object files for each architecture in their own directory. To do this, you can use GNU `make'. `cd' to the directory where you want the object files and executables to go and run the `configure' script. `configure' automatically checks for the source code in the directory that `configure' is in and in `..'. This is known as a "VPATH" build. With a non-GNU `make', it is safer to compile the package for one architecture at a time in the source code directory. After you have installed the package for one architecture, use `make distclean' before reconfiguring for another architecture. On MacOS X 10.5 and later systems, you can create libraries and executables that work on multiple system types--known as "fat" or "universal" binaries--by specifying multiple `-arch' options to the compiler but only a single `-arch' option to the preprocessor. Like this: ./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ CPP="gcc -E" CXXCPP="g++ -E" This is not guaranteed to produce working output in all cases, you may have to build one architecture at a time and combine the results using the `lipo' tool if you have problems. Installation Names ================== By default, `make install' installs the package's commands under `/usr/local/bin', include files under `/usr/local/include', etc. You can specify an installation prefix other than `/usr/local' by giving `configure' the option `--prefix=PREFIX', where PREFIX must be an absolute file name. You can specify separate installation prefixes for architecture-specific files and architecture-independent files. If you pass the option `--exec-prefix=PREFIX' to `configure', the package uses PREFIX as the prefix for installing programs and libraries. Documentation and other data files still use the regular prefix. In addition, if you use an unusual directory layout you can give options like `--bindir=DIR' to specify different values for particular kinds of files. Run `configure --help' for a list of the directories you can set and what kinds of files go in them. In general, the default for these options is expressed in terms of `${prefix}', so that specifying just `--prefix' will affect all of the other directory specifications that were not explicitly provided. The most portable way to affect installation locations is to pass the correct locations to `configure'; however, many packages provide one or both of the following shortcuts of passing variable assignments to the `make install' command line to change installation locations without having to reconfigure or recompile. The first method involves providing an override variable for each affected directory. For example, `make install prefix=/alternate/directory' will choose an alternate location for all directory configuration variables that were expressed in terms of `${prefix}'. Any directories that were specified during `configure', but not in terms of `${prefix}', must each be overridden at install time for the entire installation to be relocated. The approach of makefile variable overrides for each directory variable is required by the GNU Coding Standards, and ideally causes no recompilation. However, some platforms have known limitations with the semantics of shared libraries that end up requiring recompilation when using this method, particularly noticeable in packages that use GNU Libtool. The second method involves providing the `DESTDIR' variable. For example, `make install DESTDIR=/alternate/directory' will prepend `/alternate/directory' before all installation names. The approach of `DESTDIR' overrides is not required by the GNU Coding Standards, and does not work on platforms that have drive letters. On the other hand, it does better at avoiding recompilation issues, and works well even when some directory options were not specified in terms of `${prefix}' at `configure' time. Optional Features ================= If the package supports it, you can cause programs to be installed with an extra prefix or suffix on their names by giving `configure' the option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. Some packages pay attention to `--enable-FEATURE' options to `configure', where FEATURE indicates an optional part of the package. They may also pay attention to `--with-PACKAGE' options, where PACKAGE is something like `gnu-as' or `x' (for the X Window System). The `README' should mention any `--enable-' and `--with-' options that the package recognizes. For packages that use the X Window System, `configure' can usually find the X include and library files automatically, but if it doesn't, you can use the `configure' options `--x-includes=DIR' and `--x-libraries=DIR' to specify their locations. Some packages offer the ability to configure how verbose the execution of `make' will be. For these packages, running `./configure --enable-silent-rules' sets the default to minimal output, which can be overridden with `make V=1'; while running `./configure --disable-silent-rules' sets the default to verbose, which can be overridden with `make V=0'. Particular systems ================== On HP-UX, the default C compiler is not ANSI C compatible. If GNU CC is not installed, it is recommended to use the following options in order to use an ANSI C compiler: ./configure CC="cc -Ae -D_XOPEN_SOURCE=500" and if that doesn't work, install pre-built binaries of GCC for HP-UX. HP-UX `make' updates targets which have the same time stamps as their prerequisites, which makes it generally unusable when shipped generated files such as `configure' are involved. Use GNU `make' instead. On OSF/1 a.k.a. Tru64, some versions of the default C compiler cannot parse its `' header file. The option `-nodtk' can be used as a workaround. If GNU CC is not installed, it is therefore recommended to try ./configure CC="cc" and if that doesn't work, try ./configure CC="cc -nodtk" On Solaris, don't put `/usr/ucb' early in your `PATH'. This directory contains several dysfunctional programs; working variants of these programs are available in `/usr/bin'. So, if you need `/usr/ucb' in your `PATH', put it _after_ `/usr/bin'. On Haiku, software installed for all users goes in `/boot/common', not `/usr/local'. It is recommended to use the following options: ./configure --prefix=/boot/common Specifying the System Type ========================== There may be some features `configure' cannot figure out automatically, but needs to determine by the type of machine the package will run on. Usually, assuming the package is built to be run on the _same_ architectures, `configure' can figure that out, but if it prints a message saying it cannot guess the machine type, give it the `--build=TYPE' option. TYPE can either be a short name for the system type, such as `sun4', or a canonical name which has the form: CPU-COMPANY-SYSTEM where SYSTEM can have one of these forms: OS KERNEL-OS See the file `config.sub' for the possible values of each field. If `config.sub' isn't included in this package, then this package doesn't need to know the machine type. If you are _building_ compiler tools for cross-compiling, you should use the option `--target=TYPE' to select the type of system they will produce code for. If you want to _use_ a cross compiler, that generates code for a platform different from the build platform, you should specify the "host" platform (i.e., that on which the generated programs will eventually be run) with `--host=TYPE'. Sharing Defaults ================ If you want to set default values for `configure' scripts to share, you can create a site shell script called `config.site' that gives default values for variables like `CC', `cache_file', and `prefix'. `configure' looks for `PREFIX/share/config.site' if it exists, then `PREFIX/etc/config.site' if it exists. Or, you can set the `CONFIG_SITE' environment variable to the location of the site script. A warning: not all `configure' scripts look for a site script. Defining Variables ================== Variables not defined in a site shell script can be set in the environment passed to `configure'. However, some packages may run configure again during the build, and the customized values of these variables may be lost. In order to avoid this problem, you should set them in the `configure' command line, using `VAR=value'. For example: ./configure CC=/usr/local2/bin/gcc causes the specified `gcc' to be used as the C compiler (unless it is overridden in the site shell script). Unfortunately, this technique does not work for `CONFIG_SHELL' due to an Autoconf limitation. Until the limitation is lifted, you can use this workaround: CONFIG_SHELL=/bin/bash ./configure CONFIG_SHELL=/bin/bash `configure' Invocation ====================== `configure' recognizes the following options to control how it operates. `--help' `-h' Print a summary of all of the options to `configure', and exit. `--help=short' `--help=recursive' Print a summary of the options unique to this package's `configure', and exit. The `short' variant lists options used only in the top level, while the `recursive' variant lists options also present in any nested packages. `--version' `-V' Print the version of Autoconf used to generate the `configure' script, and exit. `--cache-file=FILE' Enable the cache: use and save the results of the tests in FILE, traditionally `config.cache'. FILE defaults to `/dev/null' to disable caching. `--config-cache' `-C' Alias for `--cache-file=config.cache'. `--quiet' `--silent' `-q' Do not print messages saying which checks are being made. To suppress all normal output, redirect it to `/dev/null' (any error messages will still be shown). `--srcdir=DIR' Look for the package's source code in directory DIR. Usually `configure' can determine that directory automatically. `--prefix=DIR' Use DIR as the installation prefix. *note Installation Names:: for more details, including other options available for fine-tuning the installation locations. `--no-create' `-n' Run the configure checks, but stop before creating any output files. `configure' also accepts some other, not widely useful, options. Run `configure --help' for more details. gcl/gmp4/INSTALL.autoconf000066400000000000000000000220041242227143400153370ustar00rootroot00000000000000Copyright (C) 1994-1996, 1999-2002 Free Software Foundation, Inc. This file is free documentation; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. Basic Installation ================== These are generic installation instructions. The `configure' shell script attempts to guess correct values for various system-dependent variables used during compilation. It uses those values to create a `Makefile' in each directory of the package. It may also create one or more `.h' files containing system-dependent definitions. Finally, it creates a shell script `config.status' that you can run in the future to recreate the current configuration, and a file `config.log' containing compiler output (useful mainly for debugging `configure'). It can also use an optional file (typically called `config.cache' and enabled with `--cache-file=config.cache' or simply `-C') that saves the results of its tests to speed up reconfiguring. (Caching is disabled by default to prevent problems with accidental use of stale cache files.) If you need to do unusual things to compile the package, please try to figure out how `configure' could check whether to do them, and mail diffs or instructions to the address given in the `README' so they can be considered for the next release. If you are using the cache, and at some point `config.cache' contains results you don't want to keep, you may remove or edit it. The file `configure.ac' (or `configure.in') is used to create `configure' by a program called `autoconf'. You only need `configure.ac' if you want to change it or regenerate `configure' using a newer version of `autoconf'. The simplest way to compile this package is: 1. `cd' to the directory containing the package's source code and type `./configure' to configure the package for your system. If you're using `csh' on an old version of System V, you might need to type `sh ./configure' instead to prevent `csh' from trying to execute `configure' itself. Running `configure' takes awhile. While running, it prints some messages telling which features it is checking for. 2. Type `make' to compile the package. 3. Optionally, type `make check' to run any self-tests that come with the package. 4. Type `make install' to install the programs and any data files and documentation. 5. You can remove the program binaries and object files from the source code directory by typing `make clean'. To also remove the files that `configure' created (so you can compile the package for a different kind of computer), type `make distclean'. There is also a `make maintainer-clean' target, but that is intended mainly for the package's developers. If you use it, you may have to get all sorts of other programs in order to regenerate files that came with the distribution. Compilers and Options ===================== Some systems require unusual options for compilation or linking that the `configure' script does not know about. Run `./configure --help' for details on some of the pertinent environment variables. You can give `configure' initial values for configuration parameters by setting variables in the command line or in the environment. Here is an example: ./configure CC=c89 CFLAGS=-O2 LIBS=-lposix *Note Defining Variables::, for more details. Compiling For Multiple Architectures ==================================== You can compile the package for more than one kind of computer at the same time, by placing the object files for each architecture in their own directory. To do this, you must use a version of `make' that supports the `VPATH' variable, such as GNU `make'. `cd' to the directory where you want the object files and executables to go and run the `configure' script. `configure' automatically checks for the source code in the directory that `configure' is in and in `..'. If you have to use a `make' that does not support the `VPATH' variable, you have to compile the package for one architecture at a time in the source code directory. After you have installed the package for one architecture, use `make distclean' before reconfiguring for another architecture. Installation Names ================== By default, `make install' will install the package's files in `/usr/local/bin', `/usr/local/man', etc. You can specify an installation prefix other than `/usr/local' by giving `configure' the option `--prefix=PATH'. You can specify separate installation prefixes for architecture-specific files and architecture-independent files. If you give `configure' the option `--exec-prefix=PATH', the package will use PATH as the prefix for installing programs and libraries. Documentation and other data files will still use the regular prefix. In addition, if you use an unusual directory layout you can give options like `--bindir=PATH' to specify different values for particular kinds of files. Run `configure --help' for a list of the directories you can set and what kinds of files go in them. If the package supports it, you can cause programs to be installed with an extra prefix or suffix on their names by giving `configure' the option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. Optional Features ================= Some packages pay attention to `--enable-FEATURE' options to `configure', where FEATURE indicates an optional part of the package. They may also pay attention to `--with-PACKAGE' options, where PACKAGE is something like `gnu-as' or `x' (for the X Window System). The `README' should mention any `--enable-' and `--with-' options that the package recognizes. For packages that use the X Window System, `configure' can usually find the X include and library files automatically, but if it doesn't, you can use the `configure' options `--x-includes=DIR' and `--x-libraries=DIR' to specify their locations. Specifying the System Type ========================== There may be some features `configure' cannot figure out automatically, but needs to determine by the type of machine the package will run on. Usually, assuming the package is built to be run on the _same_ architectures, `configure' can figure that out, but if it prints a message saying it cannot guess the machine type, give it the `--build=TYPE' option. TYPE can either be a short name for the system type, such as `sun4', or a canonical name which has the form: CPU-COMPANY-SYSTEM where SYSTEM can have one of these forms: OS KERNEL-OS See the file `config.sub' for the possible values of each field. If `config.sub' isn't included in this package, then this package doesn't need to know the machine type. If you are _building_ compiler tools for cross-compiling, you should use the `--target=TYPE' option to select the type of system they will produce code for. If you want to _use_ a cross compiler, that generates code for a platform different from the build platform, you should specify the "host" platform (i.e., that on which the generated programs will eventually be run) with `--host=TYPE'. Sharing Defaults ================ If you want to set default values for `configure' scripts to share, you can create a site shell script called `config.site' that gives default values for variables like `CC', `cache_file', and `prefix'. `configure' looks for `PREFIX/share/config.site' if it exists, then `PREFIX/etc/config.site' if it exists. Or, you can set the `CONFIG_SITE' environment variable to the location of the site script. A warning: not all `configure' scripts look for a site script. Defining Variables ================== Variables not defined in a site shell script can be set in the environment passed to `configure'. However, some packages may run configure again during the build, and the customized values of these variables may be lost. In order to avoid this problem, you should set them in the `configure' command line, using `VAR=value'. For example: ./configure CC=/usr/local2/bin/gcc will cause the specified gcc to be used as the C compiler (unless it is overridden in the site shell script). `configure' Invocation ====================== `configure' recognizes the following options to control how it operates. `--help' `-h' Print a summary of the options to `configure', and exit. `--version' `-V' Print the version of Autoconf used to generate the `configure' script, and exit. `--cache-file=FILE' Enable the cache: use and save the results of the tests in FILE, traditionally `config.cache'. FILE defaults to `/dev/null' to disable caching. `--config-cache' `-C' Alias for `--cache-file=config.cache'. `--quiet' `--silent' `-q' Do not print messages saying which checks are being made. To suppress all normal output, redirect it to `/dev/null' (any error messages will still be shown). `--srcdir=DIR' Look for the package's source code in directory DIR. Usually `configure' can determine that directory automatically. `configure' also accepts some other, not widely useful, options. Run `configure --help' for more details. gcl/gmp4/Makefile.am000066400000000000000000000464631242227143400145440ustar00rootroot00000000000000## Process this file with automake to generate Makefile.in # Copyright 1991, 1993, 1994, 1996, 1997, 1999-2004, 2006-2009, 2011-2014 Free # Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library 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 copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. # The following options are the same as AM_INIT_AUTOMAKE in configure.in, # except no $(top_builddir) on ansi2knr. That directory is wanted for the # Makefiles in subdirectories, but here we must omit it so automake gives # the actual ansi2knr build rule, not "cd $(top_builddir) && make ansi2knr". # # AUTOMAKE_OPTIONS = 1.8 gnu no-dependencies # Libtool -version-info for libgmp.la and libmp.la. See "Versioning" in the # libtool manual. # # CURRENT:REVISION:AGE # # 1. No interfaces changed, only implementations (good): Increment REVISION. # # 2. Interfaces added, none removed (good): Increment CURRENT, increment # AGE, set REVISION to 0. # # 3. Interfaces removed (BAD, breaks upward compatibility): Increment # CURRENT, set AGE and REVISION to 0. # # Do this separately for libgmp, libgmpxx and libmp, and only for releases. # # GMP -version-info # release libgmp libgmpxx libmp # 2.0.x - - - # 3.0 3:0:0 - 3:0:0 # 3.0.1 3:1:0 - 3:0:0 # 3.1 4:0:1 - 4:0:1 # 3.1.1 4:1:1 - 4:1:1 # 4.0 5:0:2 3:0:0 4:2:1 # 4.0.1 5:1:2 3:1:0 4:3:1 # 4.1 6:0:3 3:2:0 4:4:1 # 4.1.1 6:1:3 3:3:0 4:5:1 # 4.1.2 6:2:3 3:4:0 4:6:1 # 4.1.3 6:3:3 3:5:0 4:7:1 # 4.1.4 6:3:3 3:5:0 4:7:1 WRONG, same as 4.1.3! # 4.2 6:0:3 3:2:0 4:4:1 REALLY WRONG, same as 4.1! # 4.2.1 7:1:4 4:1:1 4:10:1 WRONG for libgmpxx # 4.2.2 7:2:4 4:2:0 4:11:1 # 4.2.3 7:3:4 4:3:0 4:12:1 # 4.2.4 7:4:4 4:4:0 4:13:1 # 4.3.0 8:0:5 5:0:1 4:14:1 # 4.3.1 8:1:5 5:1:1 4:15:1 WRONG Really used same as 4.3.0 # 4.3.2 8:2:5 5:2:1 4:16:1 # 5.0.0 9:0:6 6:0:2 4:20:1 Should have been 10:0:0 # 5.0.1 10:1:0 6:1:2 4:21:1 # 5.0.2 10:2:0 6:2:2 4:22:1 # 5.0.3 10:3:0 6:3:2 4:23:1 # 5.0.4 10:4:0 6:4:2 4:24:1 # 5.0.5 10:5:0 6:5:2 4:25:1 # 5.1.0 11:0:1 7:0:3 - # 5.1.1 11:1:1 7:1:3 - # 5.1.2 11:2:1 7:2:3 - # 6.0.0 12:0:2 8:0:4 - # # Starting at 3:0:0 is a slight abuse of the versioning system, but it # ensures we're past soname libgmp.so.2, which was used on Debian GNU/Linux # packages of gmp 2. Pretend gmp 2 was 2:0:0, so the interface changes for # gmp 3 mean 3:0:0 is right. # # We interpret "implementation changed" in item "1." above as meaning any # release, ie. the REVISION is incremented every time (if nothing else). # Even if we thought the code generated will be identical on all systems, # it's still good to get the shared library filename (like # libgmpxx.so.3.0.4) incrementing, to make it clear which GMP it's from. LIBGMP_LT_CURRENT = 12 LIBGMP_LT_REVISION = 0 LIBGMP_LT_AGE = 2 LIBGMPXX_LT_CURRENT = 8 LIBGMPXX_LT_REVISION = 0 LIBGMPXX_LT_AGE = 4 SUBDIRS = tests mpn mpz mpq mpf printf scanf rand cxx demos tune doc EXTRA_DIST = configfsf.guess configfsf.sub .gdbinit INSTALL.autoconf \ COPYING.LESSERv3 COPYINGv2 COPYINGv3 if WANT_CXX GMPXX_HEADERS_OPTION = gmpxx.h endif EXTRA_DIST += gmpxx.h # gmp.h and mp.h are architecture dependent, mainly since they encode the # limb size used in libgmp. For that reason they belong under $exec_prefix # not $prefix, strictly speaking. # # $exec_prefix/include is not in the default include path for gcc built to # the same $prefix and $exec_prefix, which might mean gmp.h is not found, # but anyone knowledgeable enough to be playing with exec_prefix will be able # to address that. # includeexecdir = $(exec_prefix)/include include_HEADERS = $(GMPXX_HEADERS_OPTION) nodist_includeexec_HEADERS = gmp.h lib_LTLIBRARIES = libgmp.la $(GMPXX_LTLIBRARIES_OPTION) BUILT_SOURCES = gmp.h DISTCLEANFILES = $(BUILT_SOURCES) config.m4 @gmp_srclinks@ # Tell gmp.h it's building gmp, not an application, used by windows DLL stuff. INCLUDES=-D__GMP_WITHIN_GMP MPF_OBJECTS = mpf/init$U.lo mpf/init2$U.lo mpf/inits$U.lo mpf/set$U.lo \ mpf/set_ui$U.lo mpf/set_si$U.lo mpf/set_str$U.lo mpf/set_d$U.lo \ mpf/set_z$U.lo mpf/iset$U.lo mpf/iset_ui$U.lo mpf/iset_si$U.lo \ mpf/iset_str$U.lo mpf/iset_d$U.lo mpf/clear$U.lo mpf/clears$U.lo \ mpf/get_str$U.lo mpf/dump$U.lo mpf/size$U.lo mpf/eq$U.lo mpf/reldiff$U.lo \ mpf/sqrt$U.lo mpf/random2$U.lo mpf/inp_str$U.lo mpf/out_str$U.lo \ mpf/add$U.lo mpf/add_ui$U.lo mpf/sub$U.lo mpf/sub_ui$U.lo mpf/ui_sub$U.lo \ mpf/mul$U.lo mpf/mul_ui$U.lo mpf/div$U.lo mpf/div_ui$U.lo \ mpf/cmp$U.lo mpf/cmp_d$U.lo mpf/cmp_ui$U.lo mpf/cmp_si$U.lo \ mpf/mul_2exp$U.lo mpf/div_2exp$U.lo mpf/abs$U.lo mpf/neg$U.lo \ mpf/set_q$U.lo mpf/get_d$U.lo mpf/get_d_2exp$U.lo mpf/set_dfl_prec$U.lo \ mpf/set_prc$U.lo mpf/set_prc_raw$U.lo mpf/get_dfl_prec$U.lo \ mpf/get_prc$U.lo mpf/ui_div$U.lo mpf/sqrt_ui$U.lo \ mpf/ceilfloor$U.lo mpf/trunc$U.lo mpf/pow_ui$U.lo \ mpf/urandomb$U.lo mpf/swap$U.lo \ mpf/fits_sint$U.lo mpf/fits_slong$U.lo mpf/fits_sshort$U.lo \ mpf/fits_uint$U.lo mpf/fits_ulong$U.lo mpf/fits_ushort$U.lo \ mpf/get_si$U.lo mpf/get_ui$U.lo \ mpf/int_p$U.lo MPZ_OBJECTS = mpz/abs$U.lo mpz/add$U.lo mpz/add_ui$U.lo \ mpz/aorsmul$U.lo mpz/aorsmul_i$U.lo mpz/and$U.lo mpz/array_init$U.lo \ mpz/bin_ui$U.lo mpz/bin_uiui$U.lo \ mpz/cdiv_q$U.lo mpz/cdiv_q_ui$U.lo \ mpz/cdiv_qr$U.lo mpz/cdiv_qr_ui$U.lo \ mpz/cdiv_r$U.lo mpz/cdiv_r_ui$U.lo mpz/cdiv_ui$U.lo \ mpz/cfdiv_q_2exp$U.lo mpz/cfdiv_r_2exp$U.lo \ mpz/clear$U.lo mpz/clears$U.lo mpz/clrbit$U.lo \ mpz/cmp$U.lo mpz/cmp_d$U.lo mpz/cmp_si$U.lo mpz/cmp_ui$U.lo \ mpz/cmpabs$U.lo mpz/cmpabs_d$U.lo mpz/cmpabs_ui$U.lo \ mpz/com$U.lo mpz/combit$U.lo \ mpz/cong$U.lo mpz/cong_2exp$U.lo mpz/cong_ui$U.lo \ mpz/divexact$U.lo mpz/divegcd$U.lo mpz/dive_ui$U.lo \ mpz/divis$U.lo mpz/divis_ui$U.lo mpz/divis_2exp$U.lo mpz/dump$U.lo \ mpz/export$U.lo mpz/mfac_uiui$U.lo \ mpz/2fac_ui$U.lo mpz/fac_ui$U.lo mpz/oddfac_1$U.lo mpz/prodlimbs$U.lo \ mpz/fdiv_q_ui$U.lo mpz/fdiv_qr$U.lo mpz/fdiv_qr_ui$U.lo \ mpz/fdiv_r$U.lo mpz/fdiv_r_ui$U.lo mpz/fdiv_q$U.lo \ mpz/fdiv_ui$U.lo mpz/fib_ui$U.lo mpz/fib2_ui$U.lo mpz/fits_sint$U.lo \ mpz/fits_slong$U.lo mpz/fits_sshort$U.lo mpz/fits_uint$U.lo \ mpz/fits_ulong$U.lo mpz/fits_ushort$U.lo mpz/gcd$U.lo \ mpz/gcd_ui$U.lo mpz/gcdext$U.lo mpz/get_d$U.lo mpz/get_d_2exp$U.lo \ mpz/get_si$U.lo mpz/get_str$U.lo mpz/get_ui$U.lo mpz/getlimbn$U.lo \ mpz/hamdist$U.lo \ mpz/import$U.lo mpz/init$U.lo mpz/init2$U.lo mpz/inits$U.lo \ mpz/inp_raw$U.lo mpz/inp_str$U.lo mpz/invert$U.lo \ mpz/ior$U.lo mpz/iset$U.lo mpz/iset_d$U.lo mpz/iset_si$U.lo \ mpz/iset_str$U.lo mpz/iset_ui$U.lo mpz/jacobi$U.lo mpz/kronsz$U.lo \ mpz/kronuz$U.lo mpz/kronzs$U.lo mpz/kronzu$U.lo \ mpz/lcm$U.lo mpz/lcm_ui$U.lo mpz/limbs_finish$U.lo \ mpz/limbs_modify$U.lo mpz/limbs_read$U.lo mpz/limbs_write$U.lo \ mpz/lucnum_ui$U.lo mpz/lucnum2_ui$U.lo \ mpz/millerrabin$U.lo mpz/mod$U.lo mpz/mul$U.lo mpz/mul_2exp$U.lo \ mpz/mul_si$U.lo mpz/mul_ui$U.lo \ mpz/n_pow_ui$U.lo mpz/neg$U.lo mpz/nextprime$U.lo \ mpz/out_raw$U.lo mpz/out_str$U.lo mpz/perfpow$U.lo mpz/perfsqr$U.lo \ mpz/popcount$U.lo mpz/pow_ui$U.lo mpz/powm$U.lo mpz/powm_sec$U.lo \ mpz/powm_ui$U.lo mpz/primorial_ui$U.lo \ mpz/pprime_p$U.lo mpz/random$U.lo mpz/random2$U.lo \ mpz/realloc$U.lo mpz/realloc2$U.lo mpz/remove$U.lo mpz/roinit_n$U.lo \ mpz/root$U.lo mpz/rootrem$U.lo mpz/rrandomb$U.lo mpz/scan0$U.lo \ mpz/scan1$U.lo mpz/set$U.lo mpz/set_d$U.lo mpz/set_f$U.lo \ mpz/set_q$U.lo mpz/set_si$U.lo mpz/set_str$U.lo mpz/set_ui$U.lo \ mpz/setbit$U.lo \ mpz/size$U.lo mpz/sizeinbase$U.lo mpz/sqrt$U.lo \ mpz/sqrtrem$U.lo mpz/sub$U.lo mpz/sub_ui$U.lo mpz/swap$U.lo \ mpz/tdiv_ui$U.lo mpz/tdiv_q$U.lo mpz/tdiv_q_2exp$U.lo \ mpz/tdiv_q_ui$U.lo mpz/tdiv_qr$U.lo mpz/tdiv_qr_ui$U.lo \ mpz/tdiv_r$U.lo mpz/tdiv_r_2exp$U.lo mpz/tdiv_r_ui$U.lo \ mpz/tstbit$U.lo mpz/ui_pow_ui$U.lo mpz/ui_sub$U.lo mpz/urandomb$U.lo \ mpz/urandomm$U.lo mpz/xor$U.lo MPQ_OBJECTS = mpq/abs$U.lo mpq/aors$U.lo \ mpq/canonicalize$U.lo mpq/clear$U.lo mpq/clears$U.lo \ mpq/cmp$U.lo mpq/cmp_si$U.lo mpq/cmp_ui$U.lo mpq/div$U.lo \ mpq/get_d$U.lo mpq/get_den$U.lo mpq/get_num$U.lo mpq/get_str$U.lo \ mpq/init$U.lo mpq/inits$U.lo mpq/inp_str$U.lo mpq/inv$U.lo \ mpq/md_2exp$U.lo mpq/mul$U.lo mpq/neg$U.lo mpq/out_str$U.lo \ mpq/set$U.lo mpq/set_den$U.lo mpq/set_num$U.lo \ mpq/set_si$U.lo mpq/set_str$U.lo mpq/set_ui$U.lo \ mpq/equal$U.lo mpq/set_z$U.lo mpq/set_d$U.lo \ mpq/set_f$U.lo mpq/swap$U.lo MPN_OBJECTS = mpn/fib_table$U.lo mpn/mp_bases$U.lo PRINTF_OBJECTS = \ printf/asprintf$U.lo printf/asprntffuns$U.lo \ printf/doprnt$U.lo printf/doprntf$U.lo printf/doprnti$U.lo \ printf/fprintf$U.lo \ printf/obprintf$U.lo printf/obvprintf$U.lo printf/obprntffuns$U.lo \ printf/printf$U.lo printf/printffuns$U.lo \ printf/snprintf$U.lo printf/snprntffuns$U.lo \ printf/sprintf$U.lo printf/sprintffuns$U.lo \ printf/vasprintf$U.lo printf/vfprintf$U.lo printf/vprintf$U.lo \ printf/vsnprintf$U.lo printf/vsprintf$U.lo \ printf/repl-vsnprintf$U.lo SCANF_OBJECTS = \ scanf/doscan$U.lo scanf/fscanf$U.lo scanf/fscanffuns$U.lo \ scanf/scanf$U.lo scanf/sscanf$U.lo scanf/sscanffuns$U.lo \ scanf/vfscanf$U.lo scanf/vscanf$U.lo scanf/vsscanf$U.lo RANDOM_OBJECTS = \ rand/rand$U.lo rand/randclr$U.lo rand/randdef$U.lo rand/randiset$U.lo \ rand/randlc2s$U.lo rand/randlc2x$U.lo rand/randmt$U.lo \ rand/randmts$U.lo rand/rands$U.lo rand/randsd$U.lo rand/randsdui$U.lo \ rand/randbui$U.lo rand/randmui$U.lo # no $U for C++ files CXX_OBJECTS = \ cxx/isfuns.lo cxx/ismpf.lo cxx/ismpq.lo cxx/ismpz.lo cxx/ismpznw.lo \ cxx/limits.lo cxx/osdoprnti.lo cxx/osfuns.lo \ cxx/osmpf.lo cxx/osmpq.lo cxx/osmpz.lo # In libtool 1.5 it doesn't work to build libgmp.la from the convenience # libraries like mpz/libmpz.la. Or rather it works, but it ends up putting # PIC objects into libgmp.a if shared and static are both built. (The PIC # objects go into mpz/.libs/libmpz.a, and thence into .libs/libgmp.a.) # # For now the big lists of objects above are used. Something like mpz/*.lo # would probably work, but might risk missing something out or getting # something extra. The source files for each .lo are listed in the # Makefile.am's in the subdirectories. # # Currently, for libgmp, unlike libmp below, we're not using # -export-symbols, since the tune and speed programs, and perhaps some of # the test programs, want to access undocumented symbols. libgmp_la_SOURCES = gmp-impl.h longlong.h \ assert.c compat.c errno.c extract-dbl.c invalid.c memory.c \ mp_bpl.c mp_clz_tab.c mp_dv_tab.c mp_minv_tab.c mp_get_fns.c mp_set_fns.c \ version.c nextprime.c primesieve.c EXTRA_libgmp_la_SOURCES = tal-debug.c tal-notreent.c tal-reent.c libgmp_la_DEPENDENCIES = @TAL_OBJECT@ \ $(MPF_OBJECTS) $(MPZ_OBJECTS) $(MPQ_OBJECTS) \ $(MPN_OBJECTS) @mpn_objs_in_libgmp@ \ $(PRINTF_OBJECTS) $(SCANF_OBJECTS) $(RANDOM_OBJECTS) libgmp_la_LIBADD = $(libgmp_la_DEPENDENCIES) libgmp_la_LDFLAGS = $(GMP_LDFLAGS) $(LIBGMP_LDFLAGS) \ -version-info $(LIBGMP_LT_CURRENT):$(LIBGMP_LT_REVISION):$(LIBGMP_LT_AGE) # We need at least one .cc file in $(libgmpxx_la_SOURCES) so automake will # use $(CXXLINK) rather than the plain C $(LINK). cxx/dummy.cc is that # file. if WANT_CXX GMPXX_LTLIBRARIES_OPTION = libgmpxx.la endif libgmpxx_la_SOURCES = cxx/dummy.cc libgmpxx_la_DEPENDENCIES = $(CXX_OBJECTS) libgmp.la libgmpxx_la_LIBADD = $(libgmpxx_la_DEPENDENCIES) libgmpxx_la_LDFLAGS = $(GMP_LDFLAGS) $(LIBGMPXX_LDFLAGS) \ -version-info $(LIBGMPXX_LT_CURRENT):$(LIBGMPXX_LT_REVISION):$(LIBGMPXX_LT_AGE) install-data-hook: @echo '' @echo '+-------------------------------------------------------------+' @echo '| CAUTION: |' @echo '| |' @echo '| If you have not already run "make check", then we strongly |' @echo '| recommend you do so. |' @echo '| |' @echo '| GMP has been carefully tested by its authors, but compilers |' @echo '| are all too often released with serious bugs. GMP tends to |' @echo '| explore interesting corners in compilers and has hit bugs |' @echo '| on quite a few occasions. |' @echo '| |' @echo '+-------------------------------------------------------------+' @echo '' # The "test -f" support for srcdir!=builddir is similar to the automake .c.o # etc rules, but with each foo.c explicitly, since $< is not portable # outside an inference rule. # # A quoted 'foo.c' is used with the "test -f"'s to avoid Sun make rewriting # it as part of its VPATH support. See the autoconf manual "Limitations of # Make". # # Generated .h files which are used by gmp-impl.h are BUILT_SOURCES since # they must exist before anything can be compiled. # # Other generated .h files are also BUILT_SOURCES so as to get all the # build-system stuff over and done with at the start. Also, dependencies on # the .h files are not properly expressed for the various objects that use # them. EXTRA_DIST += bootstrap.c fac_table.h: gen-fac$(EXEEXT_FOR_BUILD) ./gen-fac $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >fac_table.h || (rm -f fac_table.h; exit 1) BUILT_SOURCES += fac_table.h gen-fac$(EXEEXT_FOR_BUILD): gen-fac$(U_FOR_BUILD).c bootstrap.c $(CC_FOR_BUILD) `test -f 'gen-fac$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-fac$(U_FOR_BUILD).c -o gen-fac$(EXEEXT_FOR_BUILD) DISTCLEANFILES += gen-fac$(EXEEXT_FOR_BUILD) EXTRA_DIST += gen-fac.c fib_table.h: gen-fib$(EXEEXT_FOR_BUILD) ./gen-fib header $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >fib_table.h || (rm -f fib_table.h; exit 1) BUILT_SOURCES += fib_table.h mpn/fib_table.c: gen-fib$(EXEEXT_FOR_BUILD) ./gen-fib table $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mpn/fib_table.c || (rm -f mpn/fib_table.c; exit 1) BUILT_SOURCES += mpn/fib_table.c gen-fib$(EXEEXT_FOR_BUILD): gen-fib$(U_FOR_BUILD).c bootstrap.c $(CC_FOR_BUILD) `test -f 'gen-fib$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-fib$(U_FOR_BUILD).c -o gen-fib$(EXEEXT_FOR_BUILD) DISTCLEANFILES += gen-fib$(EXEEXT_FOR_BUILD) EXTRA_DIST += gen-fib.c mp_bases.h: gen-bases$(EXEEXT_FOR_BUILD) ./gen-bases header $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mp_bases.h || (rm -f mp_bases.h; exit 1) BUILT_SOURCES += mp_bases.h mpn/mp_bases.c: gen-bases$(EXEEXT_FOR_BUILD) ./gen-bases table $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mpn/mp_bases.c || (rm -f mpn/mp_bases.c; exit 1) BUILT_SOURCES += mpn/mp_bases.c gen-bases$(EXEEXT_FOR_BUILD): gen-bases$(U_FOR_BUILD).c bootstrap.c $(CC_FOR_BUILD) `test -f 'gen-bases$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-bases$(U_FOR_BUILD).c -o gen-bases$(EXEEXT_FOR_BUILD) $(LIBM_FOR_BUILD) DISTCLEANFILES += gen-bases$(EXEEXT_FOR_BUILD) EXTRA_DIST += gen-bases.c trialdivtab.h: gen-trialdivtab$(EXEEXT_FOR_BUILD) ./gen-trialdivtab $(GMP_LIMB_BITS) 8000 >trialdivtab.h || (rm -f trialdivtab.h; exit 1) BUILT_SOURCES += trialdivtab.h gen-trialdivtab$(EXEEXT_FOR_BUILD): gen-trialdivtab$(U_FOR_BUILD).c bootstrap.c $(CC_FOR_BUILD) `test -f 'gen-trialdivtab$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-trialdivtab$(U_FOR_BUILD).c -o gen-trialdivtab$(EXEEXT_FOR_BUILD) $(LIBM_FOR_BUILD) DISTCLEANFILES += gen-trialdivtab$(EXEEXT_FOR_BUILD) EXTRA_DIST += gen-trialdivtab.c mpn/jacobitab.h: gen-jacobitab$(EXEEXT_FOR_BUILD) ./gen-jacobitab >mpn/jacobitab.h || (rm -f mpn/jacobitab.h; exit 1) BUILT_SOURCES += mpn/jacobitab.h gen-jacobitab$(EXEEXT_FOR_BUILD): gen-jacobitab$(U_FOR_BUILD).c $(CC_FOR_BUILD) `test -f 'gen-jacobitab$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-jacobitab$(U_FOR_BUILD).c -o gen-jacobitab$(EXEEXT_FOR_BUILD) DISTCLEANFILES += gen-jacobitab$(EXEEXT_FOR_BUILD) EXTRA_DIST += gen-jacobitab.c mpn/perfsqr.h: gen-psqr$(EXEEXT_FOR_BUILD) ./gen-psqr $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mpn/perfsqr.h || (rm -f mpn/perfsqr.h; exit 1) BUILT_SOURCES += mpn/perfsqr.h gen-psqr$(EXEEXT_FOR_BUILD): gen-psqr$(U_FOR_BUILD).c bootstrap.c $(CC_FOR_BUILD) `test -f 'gen-psqr$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-psqr$(U_FOR_BUILD).c -o gen-psqr$(EXEEXT_FOR_BUILD) $(LIBM_FOR_BUILD) DISTCLEANFILES += gen-psqr$(EXEEXT_FOR_BUILD) EXTRA_DIST += gen-psqr.c # Distribute mini-gmp. Test sources copied by dist-hook. EXTRA_DIST += mini-gmp/README mini-gmp/mini-gmp.c mini-gmp/mini-gmp.h \ mini-gmp/tests/Makefile mini-gmp/tests/run-tests # Avoid: CVS - cvs directories # *~ - emacs backups # .#* - cvs merge originals # # *~ and .#* only occur when a whole directory without it's own Makefile.am # is distributed, like "doc" or the mpn cpu subdirectories. # dist-hook: -find $(distdir) \( -name CVS -type d \) -o -name "*~" -o -name ".#*" \ | xargs rm -rf cp "$(srcdir)"/mini-gmp/tests/*.[ch] "$(distdir)/mini-gmp/tests" # grep -F $(VERSION) $(srcdir)/Makefile.am \ # | grep -q "^# *$(VERSION) *$(LIBGMP_LT_CURRENT):$(LIBGMP_LT_REVISION):$(LIBGMP_LT_AGE) *$(LIBGMPXX_LT_CURRENT):$(LIBGMPXX_LT_REVISION):$(LIBGMPXX_LT_AGE)" # test -z "`sed -n 's/^# *[0-9]*\.[0-9]*\.[0-9]* *\([0-9]*:[0-9]*:[0-9]*\) *\([0-9]*:[0-9]*:[0-9]*\) *\([0-9]*:[0-9]*:[0-9]*\).*/A\1\nB\2\nC\3/p' $(srcdir)/Makefile.am | grep -v 'A6:3:3\|B3:5:0\|C4:7:1' | sort | uniq -d`" .PHONY: check-mini-gmp clean-mini-gmp check-mini-gmp: abs_srcdir="`cd $(srcdir) && pwd`" ; \ $(MKDIR_P) mini-gmp/tests \ && cd mini-gmp/tests \ && LD_LIBRARY_PATH="../../.libs:$$LD_LIBRARY_PATH" \ DYLD_LIBRARY_PATH="../../.libs:$$DYLD_LIBRARY_PATH" \ $(MAKE) -f "$$abs_srcdir/mini-gmp/tests/Makefile" \ VPATH="$$abs_srcdir/mini-gmp/tests" \ srcdir="$$abs_srcdir/mini-gmp/tests" \ MINI_GMP_DIR="$$abs_srcdir/mini-gmp" \ LDFLAGS="-L../../.libs" \ LIBS="-lgmp -lm" \ CC="$(CC_FOR_BUILD)" EXTRA_CFLAGS="-g -I../.." check clean-mini-gmp: if [ -d mini-gmp/tests ] ; then \ abs_srcdir="`cd $(srcdir) && pwd`" ; \ cd mini-gmp/tests \ && $(MAKE) -f "$$abs_srcdir/mini-gmp/tests/Makefile" clean ; \ fi clean-local: clean-mini-gmp distclean-local: clean-mini-gmp gcl/gmp4/Makefile.in000066400000000000000000001537011242227143400145470ustar00rootroot00000000000000# Makefile.in generated by automake 1.14.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2013 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ # Copyright 1991, 1993, 1994, 1996, 1997, 1999-2004, 2006-2009, 2011-2014 Free # Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library 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 copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. # The following options are the same as AM_INIT_AUTOMAKE in configure.in, # except no $(top_builddir) on ansi2knr. That directory is wanted for the # Makefiles in subdirectories, but here we must omit it so automake gives # the actual ansi2knr build rule, not "cd $(top_builddir) && make ansi2knr". # # AUTOMAKE_OPTIONS = 1.8 gnu no-dependencies # Libtool -version-info for libgmp.la and libmp.la. See "Versioning" in the # libtool manual. # # CURRENT:REVISION:AGE # # 1. No interfaces changed, only implementations (good): Increment REVISION. # # 2. Interfaces added, none removed (good): Increment CURRENT, increment # AGE, set REVISION to 0. # # 3. Interfaces removed (BAD, breaks upward compatibility): Increment # CURRENT, set AGE and REVISION to 0. # # Do this separately for libgmp, libgmpxx and libmp, and only for releases. # # GMP -version-info # release libgmp libgmpxx libmp # 2.0.x - - - # 3.0 3:0:0 - 3:0:0 # 3.0.1 3:1:0 - 3:0:0 # 3.1 4:0:1 - 4:0:1 # 3.1.1 4:1:1 - 4:1:1 # 4.0 5:0:2 3:0:0 4:2:1 # 4.0.1 5:1:2 3:1:0 4:3:1 # 4.1 6:0:3 3:2:0 4:4:1 # 4.1.1 6:1:3 3:3:0 4:5:1 # 4.1.2 6:2:3 3:4:0 4:6:1 # 4.1.3 6:3:3 3:5:0 4:7:1 # 4.1.4 6:3:3 3:5:0 4:7:1 WRONG, same as 4.1.3! # 4.2 6:0:3 3:2:0 4:4:1 REALLY WRONG, same as 4.1! # 4.2.1 7:1:4 4:1:1 4:10:1 WRONG for libgmpxx # 4.2.2 7:2:4 4:2:0 4:11:1 # 4.2.3 7:3:4 4:3:0 4:12:1 # 4.2.4 7:4:4 4:4:0 4:13:1 # 4.3.0 8:0:5 5:0:1 4:14:1 # 4.3.1 8:1:5 5:1:1 4:15:1 WRONG Really used same as 4.3.0 # 4.3.2 8:2:5 5:2:1 4:16:1 # 5.0.0 9:0:6 6:0:2 4:20:1 Should have been 10:0:0 # 5.0.1 10:1:0 6:1:2 4:21:1 # 5.0.2 10:2:0 6:2:2 4:22:1 # 5.0.3 10:3:0 6:3:2 4:23:1 # 5.0.4 10:4:0 6:4:2 4:24:1 # 5.0.5 10:5:0 6:5:2 4:25:1 # 5.1.0 11:0:1 7:0:3 - # 5.1.1 11:1:1 7:1:3 - # 5.1.2 11:2:1 7:2:3 - # 6.0.0 12:0:2 8:0:4 - # # Starting at 3:0:0 is a slight abuse of the versioning system, but it # ensures we're past soname libgmp.so.2, which was used on Debian GNU/Linux # packages of gmp 2. Pretend gmp 2 was 2:0:0, so the interface changes for # gmp 3 mean 3:0:0 is right. # # We interpret "implementation changed" in item "1." above as meaning any # release, ie. the REVISION is incremented every time (if nothing else). # Even if we thought the code generated will be identical on all systems, # it's still good to get the shared library filename (like # libgmpxx.so.3.0.4) incrementing, to make it clear which GMP it's from. VPATH = @srcdir@ am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = . DIST_COMMON = INSTALL NEWS README AUTHORS ChangeLog \ $(srcdir)/Makefile.in $(srcdir)/Makefile.am \ $(top_srcdir)/configure $(am__configure_deps) \ $(srcdir)/config.in $(srcdir)/gmp-h.in \ $(am__include_HEADERS_DIST) COPYING compile config.guess \ config.sub install-sh missing ylwrap ltmain.sh ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/acinclude.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ configure.lineno config.status.lineno mkinstalldirs = $(install_sh) -d CONFIG_HEADER = config.h CONFIG_CLEAN_FILES = gmp.h gmp-mparam.h CONFIG_CLEAN_VPATH_FILES = am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; am__vpath_adj = case $$p in \ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ *) f=$$p;; \ esac; am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; am__install_max = 40 am__nobase_strip_setup = \ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` am__nobase_strip = \ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" am__nobase_list = $(am__nobase_strip_setup); \ for p in $$list; do echo "$$p $$p"; done | \ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ if (++n[$$2] == $(am__install_max)) \ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ END { for (dir in files) print dir, files[dir] }' am__base_list = \ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' am__uninstall_files_from_dir = { \ test -z "$$files" \ || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ $(am__cd) "$$dir" && rm -f $$files; }; \ } am__installdirs = "$(DESTDIR)$(libdir)" "$(DESTDIR)$(includedir)" \ "$(DESTDIR)$(includeexecdir)" LTLIBRARIES = $(lib_LTLIBRARIES) am__DEPENDENCIES_1 = $(MPF_OBJECTS) $(MPZ_OBJECTS) $(MPQ_OBJECTS) \ $(MPN_OBJECTS) $(PRINTF_OBJECTS) $(SCANF_OBJECTS) \ $(RANDOM_OBJECTS) am_libgmp_la_OBJECTS = assert.lo compat.lo errno.lo extract-dbl.lo \ invalid.lo memory.lo mp_bpl.lo mp_clz_tab.lo mp_dv_tab.lo \ mp_minv_tab.lo mp_get_fns.lo mp_set_fns.lo version.lo \ nextprime.lo primesieve.lo libgmp_la_OBJECTS = $(am_libgmp_la_OBJECTS) AM_V_lt = $(am__v_lt_@AM_V@) am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) am__v_lt_0 = --silent am__v_lt_1 = libgmp_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ $(libgmp_la_LDFLAGS) $(LDFLAGS) -o $@ am_libgmpxx_la_OBJECTS = dummy.lo libgmpxx_la_OBJECTS = $(am_libgmpxx_la_OBJECTS) libgmpxx_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CXXLD) $(AM_CXXFLAGS) \ $(CXXFLAGS) $(libgmpxx_la_LDFLAGS) $(LDFLAGS) -o $@ @WANT_CXX_TRUE@am_libgmpxx_la_rpath = -rpath $(libdir) AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = DEFAULT_INCLUDES = -I.@am__isrc@ depcomp = am__depfiles_maybe = COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_CFLAGS) $(CFLAGS) AM_V_CC = $(am__v_CC_@AM_V@) am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) am__v_CC_0 = @echo " CC " $@; am__v_CC_1 = CCLD = $(CC) LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ $(AM_LDFLAGS) $(LDFLAGS) -o $@ AM_V_CCLD = $(am__v_CCLD_@AM_V@) am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) am__v_CCLD_0 = @echo " CCLD " $@; am__v_CCLD_1 = CXXCOMPILE = $(CXX) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \ $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CXXFLAGS) $(CXXFLAGS) LTCXXCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(CXX) $(DEFS) \ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_CXXFLAGS) $(CXXFLAGS) AM_V_CXX = $(am__v_CXX_@AM_V@) am__v_CXX_ = $(am__v_CXX_@AM_DEFAULT_V@) am__v_CXX_0 = @echo " CXX " $@; am__v_CXX_1 = CXXLD = $(CXX) CXXLINK = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CXXLD) $(AM_CXXFLAGS) \ $(CXXFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@ AM_V_CXXLD = $(am__v_CXXLD_@AM_V@) am__v_CXXLD_ = $(am__v_CXXLD_@AM_DEFAULT_V@) am__v_CXXLD_0 = @echo " CXXLD " $@; am__v_CXXLD_1 = SOURCES = $(libgmp_la_SOURCES) $(EXTRA_libgmp_la_SOURCES) \ $(libgmpxx_la_SOURCES) DIST_SOURCES = $(libgmp_la_SOURCES) $(EXTRA_libgmp_la_SOURCES) \ $(libgmpxx_la_SOURCES) RECURSIVE_TARGETS = all-recursive check-recursive cscopelist-recursive \ ctags-recursive dvi-recursive html-recursive info-recursive \ install-data-recursive install-dvi-recursive \ install-exec-recursive install-html-recursive \ install-info-recursive install-pdf-recursive \ install-ps-recursive install-recursive installcheck-recursive \ installdirs-recursive pdf-recursive ps-recursive \ tags-recursive uninstall-recursive am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac am__include_HEADERS_DIST = gmpxx.h HEADERS = $(include_HEADERS) $(nodist_includeexec_HEADERS) RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \ distclean-recursive maintainer-clean-recursive am__recursive_targets = \ $(RECURSIVE_TARGETS) \ $(RECURSIVE_CLEAN_TARGETS) \ $(am__extra_recursive_targets) AM_RECURSIVE_TARGETS = $(am__recursive_targets:-recursive=) TAGS CTAGS \ cscope distdir dist dist-all distcheck am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) \ $(LISP)config.in # Read a list of newline-separated strings from the standard input, # and print each of them once, without duplicates. Input order is # *not* preserved. am__uniquify_input = $(AWK) '\ BEGIN { nonempty = 0; } \ { items[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in items) print i; }; } \ ' # Make sure the list of sources is unique. This is necessary because, # e.g., the same source file might be shared among _SOURCES variables # for different programs/libraries. am__define_uniq_tagged_files = \ list='$(am__tagged_files)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags CSCOPE = cscope DIST_SUBDIRS = $(SUBDIRS) DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) distdir = $(PACKAGE)-$(VERSION) top_distdir = $(distdir) am__remove_distdir = \ if test -d "$(distdir)"; then \ find "$(distdir)" -type d ! -perm -200 -exec chmod u+w {} ';' \ && rm -rf "$(distdir)" \ || { sleep 5 && rm -rf "$(distdir)"; }; \ else :; fi am__post_remove_distdir = $(am__remove_distdir) am__relativize = \ dir0=`pwd`; \ sed_first='s,^\([^/]*\)/.*$$,\1,'; \ sed_rest='s,^[^/]*/*,,'; \ sed_last='s,^.*/\([^/]*\)$$,\1,'; \ sed_butlast='s,/*[^/]*$$,,'; \ while test -n "$$dir1"; do \ first=`echo "$$dir1" | sed -e "$$sed_first"`; \ if test "$$first" != "."; then \ if test "$$first" = ".."; then \ dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \ dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \ else \ first2=`echo "$$dir2" | sed -e "$$sed_first"`; \ if test "$$first2" = "$$first"; then \ dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \ else \ dir2="../$$dir2"; \ fi; \ dir0="$$dir0"/"$$first"; \ fi; \ fi; \ dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \ done; \ reldir="$$dir2" DIST_ARCHIVES = $(distdir).tar.gz GZIP_ENV = --best DIST_TARGETS = dist-gzip distuninstallcheck_listfiles = find . -type f -print am__distuninstallcheck_listfiles = $(distuninstallcheck_listfiles) \ | sed 's|^\./|$(prefix)/|' | grep -v '$(infodir)/dir$$' distcleancheck_listfiles = find . -type f -print ABI = @ABI@ ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AR = @AR@ AS = @AS@ ASMFLAGS = @ASMFLAGS@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CALLING_CONVENTIONS_OBJS = @CALLING_CONVENTIONS_OBJS@ CC = @CC@ CCAS = @CCAS@ CC_FOR_BUILD = @CC_FOR_BUILD@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CPP_FOR_BUILD = @CPP_FOR_BUILD@ CXX = @CXX@ CXXCPP = @CXXCPP@ CXXFLAGS = @CXXFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFN_LONG_LONG_LIMB = @DEFN_LONG_LONG_LIMB@ DEFS = @DEFS@ DLLTOOL = @DLLTOOL@ DSYMUTIL = @DSYMUTIL@ DUMPBIN = @DUMPBIN@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ EXEEXT_FOR_BUILD = @EXEEXT_FOR_BUILD@ FGREP = @FGREP@ GMP_LDFLAGS = @GMP_LDFLAGS@ GMP_LIMB_BITS = @GMP_LIMB_BITS@ GMP_NAIL_BITS = @GMP_NAIL_BITS@ GREP = @GREP@ HAVE_CLOCK_01 = @HAVE_CLOCK_01@ HAVE_CPUTIME_01 = @HAVE_CPUTIME_01@ HAVE_GETRUSAGE_01 = @HAVE_GETRUSAGE_01@ HAVE_GETTIMEOFDAY_01 = @HAVE_GETTIMEOFDAY_01@ HAVE_HOST_CPU_FAMILY_power = @HAVE_HOST_CPU_FAMILY_power@ HAVE_HOST_CPU_FAMILY_powerpc = @HAVE_HOST_CPU_FAMILY_powerpc@ HAVE_SIGACTION_01 = @HAVE_SIGACTION_01@ HAVE_SIGALTSTACK_01 = @HAVE_SIGALTSTACK_01@ HAVE_SIGSTACK_01 = @HAVE_SIGSTACK_01@ HAVE_STACK_T_01 = @HAVE_STACK_T_01@ HAVE_SYS_RESOURCE_H_01 = @HAVE_SYS_RESOURCE_H_01@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LD = @LD@ LDFLAGS = @LDFLAGS@ LEX = @LEX@ LEXLIB = @LEXLIB@ LEX_OUTPUT_ROOT = @LEX_OUTPUT_ROOT@ LIBCURSES = @LIBCURSES@ LIBGMPXX_LDFLAGS = @LIBGMPXX_LDFLAGS@ LIBGMP_DLL = @LIBGMP_DLL@ LIBGMP_LDFLAGS = @LIBGMP_LDFLAGS@ LIBM = @LIBM@ LIBM_FOR_BUILD = @LIBM_FOR_BUILD@ LIBOBJS = @LIBOBJS@ LIBREADLINE = @LIBREADLINE@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ LIPO = @LIPO@ LN_S = @LN_S@ LTLIBOBJS = @LTLIBOBJS@ M4 = @M4@ MAINT = @MAINT@ MAKEINFO = @MAKEINFO@ MANIFEST_TOOL = @MANIFEST_TOOL@ MKDIR_P = @MKDIR_P@ NM = @NM@ NMEDIT = @NMEDIT@ OBJDUMP = @OBJDUMP@ OBJEXT = @OBJEXT@ OTOOL = @OTOOL@ OTOOL64 = @OTOOL64@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ RANLIB = @RANLIB@ SED = @SED@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ SPEED_CYCLECOUNTER_OBJ = @SPEED_CYCLECOUNTER_OBJ@ STRIP = @STRIP@ TAL_OBJECT = @TAL_OBJECT@ TUNE_LIBS = @TUNE_LIBS@ TUNE_SQR_OBJ = @TUNE_SQR_OBJ@ U_FOR_BUILD = @U_FOR_BUILD@ VERSION = @VERSION@ WITH_READLINE_01 = @WITH_READLINE_01@ YACC = @YACC@ YFLAGS = @YFLAGS@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_AR = @ac_ct_AR@ ac_ct_CC = @ac_ct_CC@ ac_ct_CXX = @ac_ct_CXX@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ am__leading_dot = @am__leading_dot@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ gmp_srclinks = @gmp_srclinks@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ mpn_objects = @mpn_objects@ mpn_objs_in_libgmp = @mpn_objs_in_libgmp@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ LIBGMP_LT_CURRENT = 12 LIBGMP_LT_REVISION = 0 LIBGMP_LT_AGE = 2 LIBGMPXX_LT_CURRENT = 8 LIBGMPXX_LT_REVISION = 0 LIBGMPXX_LT_AGE = 4 SUBDIRS = tests mpn mpz mpq mpf printf scanf rand cxx demos tune doc # The "test -f" support for srcdir!=builddir is similar to the automake .c.o # etc rules, but with each foo.c explicitly, since $< is not portable # outside an inference rule. # # A quoted 'foo.c' is used with the "test -f"'s to avoid Sun make rewriting # it as part of its VPATH support. See the autoconf manual "Limitations of # Make". # # Generated .h files which are used by gmp-impl.h are BUILT_SOURCES since # they must exist before anything can be compiled. # # Other generated .h files are also BUILT_SOURCES so as to get all the # build-system stuff over and done with at the start. Also, dependencies on # the .h files are not properly expressed for the various objects that use # them. # Distribute mini-gmp. Test sources copied by dist-hook. EXTRA_DIST = configfsf.guess configfsf.sub .gdbinit INSTALL.autoconf \ COPYING.LESSERv3 COPYINGv2 COPYINGv3 gmpxx.h bootstrap.c \ gen-fac.c gen-fib.c gen-bases.c gen-trialdivtab.c \ gen-jacobitab.c gen-psqr.c mini-gmp/README mini-gmp/mini-gmp.c \ mini-gmp/mini-gmp.h mini-gmp/tests/Makefile \ mini-gmp/tests/run-tests @WANT_CXX_TRUE@GMPXX_HEADERS_OPTION = gmpxx.h # gmp.h and mp.h are architecture dependent, mainly since they encode the # limb size used in libgmp. For that reason they belong under $exec_prefix # not $prefix, strictly speaking. # # $exec_prefix/include is not in the default include path for gcc built to # the same $prefix and $exec_prefix, which might mean gmp.h is not found, # but anyone knowledgeable enough to be playing with exec_prefix will be able # to address that. # includeexecdir = $(exec_prefix)/include include_HEADERS = $(GMPXX_HEADERS_OPTION) nodist_includeexec_HEADERS = gmp.h lib_LTLIBRARIES = libgmp.la $(GMPXX_LTLIBRARIES_OPTION) BUILT_SOURCES = gmp.h fac_table.h fib_table.h mpn/fib_table.c \ mp_bases.h mpn/mp_bases.c trialdivtab.h mpn/jacobitab.h \ mpn/perfsqr.h DISTCLEANFILES = $(BUILT_SOURCES) config.m4 @gmp_srclinks@ \ gen-fac$(EXEEXT_FOR_BUILD) gen-fib$(EXEEXT_FOR_BUILD) \ gen-bases$(EXEEXT_FOR_BUILD) \ gen-trialdivtab$(EXEEXT_FOR_BUILD) \ gen-jacobitab$(EXEEXT_FOR_BUILD) gen-psqr$(EXEEXT_FOR_BUILD) # Tell gmp.h it's building gmp, not an application, used by windows DLL stuff. INCLUDES = -D__GMP_WITHIN_GMP MPF_OBJECTS = mpf/init$U.lo mpf/init2$U.lo mpf/inits$U.lo mpf/set$U.lo \ mpf/set_ui$U.lo mpf/set_si$U.lo mpf/set_str$U.lo mpf/set_d$U.lo \ mpf/set_z$U.lo mpf/iset$U.lo mpf/iset_ui$U.lo mpf/iset_si$U.lo \ mpf/iset_str$U.lo mpf/iset_d$U.lo mpf/clear$U.lo mpf/clears$U.lo \ mpf/get_str$U.lo mpf/dump$U.lo mpf/size$U.lo mpf/eq$U.lo mpf/reldiff$U.lo \ mpf/sqrt$U.lo mpf/random2$U.lo mpf/inp_str$U.lo mpf/out_str$U.lo \ mpf/add$U.lo mpf/add_ui$U.lo mpf/sub$U.lo mpf/sub_ui$U.lo mpf/ui_sub$U.lo \ mpf/mul$U.lo mpf/mul_ui$U.lo mpf/div$U.lo mpf/div_ui$U.lo \ mpf/cmp$U.lo mpf/cmp_d$U.lo mpf/cmp_ui$U.lo mpf/cmp_si$U.lo \ mpf/mul_2exp$U.lo mpf/div_2exp$U.lo mpf/abs$U.lo mpf/neg$U.lo \ mpf/set_q$U.lo mpf/get_d$U.lo mpf/get_d_2exp$U.lo mpf/set_dfl_prec$U.lo \ mpf/set_prc$U.lo mpf/set_prc_raw$U.lo mpf/get_dfl_prec$U.lo \ mpf/get_prc$U.lo mpf/ui_div$U.lo mpf/sqrt_ui$U.lo \ mpf/ceilfloor$U.lo mpf/trunc$U.lo mpf/pow_ui$U.lo \ mpf/urandomb$U.lo mpf/swap$U.lo \ mpf/fits_sint$U.lo mpf/fits_slong$U.lo mpf/fits_sshort$U.lo \ mpf/fits_uint$U.lo mpf/fits_ulong$U.lo mpf/fits_ushort$U.lo \ mpf/get_si$U.lo mpf/get_ui$U.lo \ mpf/int_p$U.lo MPZ_OBJECTS = mpz/abs$U.lo mpz/add$U.lo mpz/add_ui$U.lo \ mpz/aorsmul$U.lo mpz/aorsmul_i$U.lo mpz/and$U.lo mpz/array_init$U.lo \ mpz/bin_ui$U.lo mpz/bin_uiui$U.lo \ mpz/cdiv_q$U.lo mpz/cdiv_q_ui$U.lo \ mpz/cdiv_qr$U.lo mpz/cdiv_qr_ui$U.lo \ mpz/cdiv_r$U.lo mpz/cdiv_r_ui$U.lo mpz/cdiv_ui$U.lo \ mpz/cfdiv_q_2exp$U.lo mpz/cfdiv_r_2exp$U.lo \ mpz/clear$U.lo mpz/clears$U.lo mpz/clrbit$U.lo \ mpz/cmp$U.lo mpz/cmp_d$U.lo mpz/cmp_si$U.lo mpz/cmp_ui$U.lo \ mpz/cmpabs$U.lo mpz/cmpabs_d$U.lo mpz/cmpabs_ui$U.lo \ mpz/com$U.lo mpz/combit$U.lo \ mpz/cong$U.lo mpz/cong_2exp$U.lo mpz/cong_ui$U.lo \ mpz/divexact$U.lo mpz/divegcd$U.lo mpz/dive_ui$U.lo \ mpz/divis$U.lo mpz/divis_ui$U.lo mpz/divis_2exp$U.lo mpz/dump$U.lo \ mpz/export$U.lo mpz/mfac_uiui$U.lo \ mpz/2fac_ui$U.lo mpz/fac_ui$U.lo mpz/oddfac_1$U.lo mpz/prodlimbs$U.lo \ mpz/fdiv_q_ui$U.lo mpz/fdiv_qr$U.lo mpz/fdiv_qr_ui$U.lo \ mpz/fdiv_r$U.lo mpz/fdiv_r_ui$U.lo mpz/fdiv_q$U.lo \ mpz/fdiv_ui$U.lo mpz/fib_ui$U.lo mpz/fib2_ui$U.lo mpz/fits_sint$U.lo \ mpz/fits_slong$U.lo mpz/fits_sshort$U.lo mpz/fits_uint$U.lo \ mpz/fits_ulong$U.lo mpz/fits_ushort$U.lo mpz/gcd$U.lo \ mpz/gcd_ui$U.lo mpz/gcdext$U.lo mpz/get_d$U.lo mpz/get_d_2exp$U.lo \ mpz/get_si$U.lo mpz/get_str$U.lo mpz/get_ui$U.lo mpz/getlimbn$U.lo \ mpz/hamdist$U.lo \ mpz/import$U.lo mpz/init$U.lo mpz/init2$U.lo mpz/inits$U.lo \ mpz/inp_raw$U.lo mpz/inp_str$U.lo mpz/invert$U.lo \ mpz/ior$U.lo mpz/iset$U.lo mpz/iset_d$U.lo mpz/iset_si$U.lo \ mpz/iset_str$U.lo mpz/iset_ui$U.lo mpz/jacobi$U.lo mpz/kronsz$U.lo \ mpz/kronuz$U.lo mpz/kronzs$U.lo mpz/kronzu$U.lo \ mpz/lcm$U.lo mpz/lcm_ui$U.lo mpz/limbs_finish$U.lo \ mpz/limbs_modify$U.lo mpz/limbs_read$U.lo mpz/limbs_write$U.lo \ mpz/lucnum_ui$U.lo mpz/lucnum2_ui$U.lo \ mpz/millerrabin$U.lo mpz/mod$U.lo mpz/mul$U.lo mpz/mul_2exp$U.lo \ mpz/mul_si$U.lo mpz/mul_ui$U.lo \ mpz/n_pow_ui$U.lo mpz/neg$U.lo mpz/nextprime$U.lo \ mpz/out_raw$U.lo mpz/out_str$U.lo mpz/perfpow$U.lo mpz/perfsqr$U.lo \ mpz/popcount$U.lo mpz/pow_ui$U.lo mpz/powm$U.lo mpz/powm_sec$U.lo \ mpz/powm_ui$U.lo mpz/primorial_ui$U.lo \ mpz/pprime_p$U.lo mpz/random$U.lo mpz/random2$U.lo \ mpz/realloc$U.lo mpz/realloc2$U.lo mpz/remove$U.lo mpz/roinit_n$U.lo \ mpz/root$U.lo mpz/rootrem$U.lo mpz/rrandomb$U.lo mpz/scan0$U.lo \ mpz/scan1$U.lo mpz/set$U.lo mpz/set_d$U.lo mpz/set_f$U.lo \ mpz/set_q$U.lo mpz/set_si$U.lo mpz/set_str$U.lo mpz/set_ui$U.lo \ mpz/setbit$U.lo \ mpz/size$U.lo mpz/sizeinbase$U.lo mpz/sqrt$U.lo \ mpz/sqrtrem$U.lo mpz/sub$U.lo mpz/sub_ui$U.lo mpz/swap$U.lo \ mpz/tdiv_ui$U.lo mpz/tdiv_q$U.lo mpz/tdiv_q_2exp$U.lo \ mpz/tdiv_q_ui$U.lo mpz/tdiv_qr$U.lo mpz/tdiv_qr_ui$U.lo \ mpz/tdiv_r$U.lo mpz/tdiv_r_2exp$U.lo mpz/tdiv_r_ui$U.lo \ mpz/tstbit$U.lo mpz/ui_pow_ui$U.lo mpz/ui_sub$U.lo mpz/urandomb$U.lo \ mpz/urandomm$U.lo mpz/xor$U.lo MPQ_OBJECTS = mpq/abs$U.lo mpq/aors$U.lo \ mpq/canonicalize$U.lo mpq/clear$U.lo mpq/clears$U.lo \ mpq/cmp$U.lo mpq/cmp_si$U.lo mpq/cmp_ui$U.lo mpq/div$U.lo \ mpq/get_d$U.lo mpq/get_den$U.lo mpq/get_num$U.lo mpq/get_str$U.lo \ mpq/init$U.lo mpq/inits$U.lo mpq/inp_str$U.lo mpq/inv$U.lo \ mpq/md_2exp$U.lo mpq/mul$U.lo mpq/neg$U.lo mpq/out_str$U.lo \ mpq/set$U.lo mpq/set_den$U.lo mpq/set_num$U.lo \ mpq/set_si$U.lo mpq/set_str$U.lo mpq/set_ui$U.lo \ mpq/equal$U.lo mpq/set_z$U.lo mpq/set_d$U.lo \ mpq/set_f$U.lo mpq/swap$U.lo MPN_OBJECTS = mpn/fib_table$U.lo mpn/mp_bases$U.lo PRINTF_OBJECTS = \ printf/asprintf$U.lo printf/asprntffuns$U.lo \ printf/doprnt$U.lo printf/doprntf$U.lo printf/doprnti$U.lo \ printf/fprintf$U.lo \ printf/obprintf$U.lo printf/obvprintf$U.lo printf/obprntffuns$U.lo \ printf/printf$U.lo printf/printffuns$U.lo \ printf/snprintf$U.lo printf/snprntffuns$U.lo \ printf/sprintf$U.lo printf/sprintffuns$U.lo \ printf/vasprintf$U.lo printf/vfprintf$U.lo printf/vprintf$U.lo \ printf/vsnprintf$U.lo printf/vsprintf$U.lo \ printf/repl-vsnprintf$U.lo SCANF_OBJECTS = \ scanf/doscan$U.lo scanf/fscanf$U.lo scanf/fscanffuns$U.lo \ scanf/scanf$U.lo scanf/sscanf$U.lo scanf/sscanffuns$U.lo \ scanf/vfscanf$U.lo scanf/vscanf$U.lo scanf/vsscanf$U.lo RANDOM_OBJECTS = \ rand/rand$U.lo rand/randclr$U.lo rand/randdef$U.lo rand/randiset$U.lo \ rand/randlc2s$U.lo rand/randlc2x$U.lo rand/randmt$U.lo \ rand/randmts$U.lo rand/rands$U.lo rand/randsd$U.lo rand/randsdui$U.lo \ rand/randbui$U.lo rand/randmui$U.lo # no $U for C++ files CXX_OBJECTS = \ cxx/isfuns.lo cxx/ismpf.lo cxx/ismpq.lo cxx/ismpz.lo cxx/ismpznw.lo \ cxx/limits.lo cxx/osdoprnti.lo cxx/osfuns.lo \ cxx/osmpf.lo cxx/osmpq.lo cxx/osmpz.lo # In libtool 1.5 it doesn't work to build libgmp.la from the convenience # libraries like mpz/libmpz.la. Or rather it works, but it ends up putting # PIC objects into libgmp.a if shared and static are both built. (The PIC # objects go into mpz/.libs/libmpz.a, and thence into .libs/libgmp.a.) # # For now the big lists of objects above are used. Something like mpz/*.lo # would probably work, but might risk missing something out or getting # something extra. The source files for each .lo are listed in the # Makefile.am's in the subdirectories. # # Currently, for libgmp, unlike libmp below, we're not using # -export-symbols, since the tune and speed programs, and perhaps some of # the test programs, want to access undocumented symbols. libgmp_la_SOURCES = gmp-impl.h longlong.h \ assert.c compat.c errno.c extract-dbl.c invalid.c memory.c \ mp_bpl.c mp_clz_tab.c mp_dv_tab.c mp_minv_tab.c mp_get_fns.c mp_set_fns.c \ version.c nextprime.c primesieve.c EXTRA_libgmp_la_SOURCES = tal-debug.c tal-notreent.c tal-reent.c libgmp_la_DEPENDENCIES = @TAL_OBJECT@ \ $(MPF_OBJECTS) $(MPZ_OBJECTS) $(MPQ_OBJECTS) \ $(MPN_OBJECTS) @mpn_objs_in_libgmp@ \ $(PRINTF_OBJECTS) $(SCANF_OBJECTS) $(RANDOM_OBJECTS) libgmp_la_LIBADD = $(libgmp_la_DEPENDENCIES) libgmp_la_LDFLAGS = $(GMP_LDFLAGS) $(LIBGMP_LDFLAGS) \ -version-info $(LIBGMP_LT_CURRENT):$(LIBGMP_LT_REVISION):$(LIBGMP_LT_AGE) # We need at least one .cc file in $(libgmpxx_la_SOURCES) so automake will # use $(CXXLINK) rather than the plain C $(LINK). cxx/dummy.cc is that # file. @WANT_CXX_TRUE@GMPXX_LTLIBRARIES_OPTION = libgmpxx.la libgmpxx_la_SOURCES = cxx/dummy.cc libgmpxx_la_DEPENDENCIES = $(CXX_OBJECTS) libgmp.la libgmpxx_la_LIBADD = $(libgmpxx_la_DEPENDENCIES) libgmpxx_la_LDFLAGS = $(GMP_LDFLAGS) $(LIBGMPXX_LDFLAGS) \ -version-info $(LIBGMPXX_LT_CURRENT):$(LIBGMPXX_LT_REVISION):$(LIBGMPXX_LT_AGE) all: $(BUILT_SOURCES) config.h $(MAKE) $(AM_MAKEFLAGS) all-recursive .SUFFIXES: .SUFFIXES: .c .cc .lo .o .obj am--refresh: Makefile @: $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ echo ' cd $(srcdir) && $(AUTOMAKE) --gnu --ignore-deps'; \ $(am__cd) $(srcdir) && $(AUTOMAKE) --gnu --ignore-deps \ && exit 0; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu --ignore-deps Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu --ignore-deps Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ echo ' $(SHELL) ./config.status'; \ $(SHELL) ./config.status;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) $(SHELL) ./config.status --recheck $(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) $(am__cd) $(srcdir) && $(AUTOCONF) $(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) $(am__cd) $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS) $(am__aclocal_m4_deps): config.h: stamp-h1 @test -f $@ || rm -f stamp-h1 @test -f $@ || $(MAKE) $(AM_MAKEFLAGS) stamp-h1 stamp-h1: $(srcdir)/config.in $(top_builddir)/config.status @rm -f stamp-h1 cd $(top_builddir) && $(SHELL) ./config.status config.h $(srcdir)/config.in: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) ($(am__cd) $(top_srcdir) && $(AUTOHEADER)) rm -f stamp-h1 touch $@ distclean-hdr: -rm -f config.h stamp-h1 gmp.h: $(top_builddir)/config.status $(srcdir)/gmp-h.in cd $(top_builddir) && $(SHELL) ./config.status $@ install-libLTLIBRARIES: $(lib_LTLIBRARIES) @$(NORMAL_INSTALL) @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \ list2=; for p in $$list; do \ if test -f $$p; then \ list2="$$list2 $$p"; \ else :; fi; \ done; \ test -z "$$list2" || { \ echo " $(MKDIR_P) '$(DESTDIR)$(libdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(libdir)" || exit 1; \ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 '$(DESTDIR)$(libdir)'"; \ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 "$(DESTDIR)$(libdir)"; \ } uninstall-libLTLIBRARIES: @$(NORMAL_UNINSTALL) @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \ for p in $$list; do \ $(am__strip_dir) \ echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$f'"; \ $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$f"; \ done clean-libLTLIBRARIES: -test -z "$(lib_LTLIBRARIES)" || rm -f $(lib_LTLIBRARIES) @list='$(lib_LTLIBRARIES)'; \ locs=`for p in $$list; do echo $$p; done | \ sed 's|^[^/]*$$|.|; s|/[^/]*$$||; s|$$|/so_locations|' | \ sort -u`; \ test -z "$$locs" || { \ echo rm -f $${locs}; \ rm -f $${locs}; \ } libgmp.la: $(libgmp_la_OBJECTS) $(libgmp_la_DEPENDENCIES) $(EXTRA_libgmp_la_DEPENDENCIES) $(AM_V_CCLD)$(libgmp_la_LINK) -rpath $(libdir) $(libgmp_la_OBJECTS) $(libgmp_la_LIBADD) $(LIBS) libgmpxx.la: $(libgmpxx_la_OBJECTS) $(libgmpxx_la_DEPENDENCIES) $(EXTRA_libgmpxx_la_DEPENDENCIES) $(AM_V_CXXLD)$(libgmpxx_la_LINK) $(am_libgmpxx_la_rpath) $(libgmpxx_la_OBJECTS) $(libgmpxx_la_LIBADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) distclean-compile: -rm -f *.tab.c .c.o: $(AM_V_CC)$(COMPILE) -c -o $@ $< .c.obj: $(AM_V_CC)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` .c.lo: $(AM_V_CC)$(LTCOMPILE) -c -o $@ $< .cc.o: $(AM_V_CXX)$(CXXCOMPILE) -c -o $@ $< .cc.obj: $(AM_V_CXX)$(CXXCOMPILE) -c -o $@ `$(CYGPATH_W) '$<'` .cc.lo: $(AM_V_CXX)$(LTCXXCOMPILE) -c -o $@ $< dummy.lo: cxx/dummy.cc $(AM_V_CXX)$(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CXX) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CXXFLAGS) $(CXXFLAGS) -c -o dummy.lo `test -f 'cxx/dummy.cc' || echo '$(srcdir)/'`cxx/dummy.cc mostlyclean-libtool: -rm -f *.lo clean-libtool: -rm -rf .libs _libs distclean-libtool: -rm -f libtool config.lt install-includeHEADERS: $(include_HEADERS) @$(NORMAL_INSTALL) @list='$(include_HEADERS)'; test -n "$(includedir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(includedir)'"; \ $(MKDIR_P) "$(DESTDIR)$(includedir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(includedir)'"; \ $(INSTALL_HEADER) $$files "$(DESTDIR)$(includedir)" || exit $$?; \ done uninstall-includeHEADERS: @$(NORMAL_UNINSTALL) @list='$(include_HEADERS)'; test -n "$(includedir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(includedir)'; $(am__uninstall_files_from_dir) install-nodist_includeexecHEADERS: $(nodist_includeexec_HEADERS) @$(NORMAL_INSTALL) @list='$(nodist_includeexec_HEADERS)'; test -n "$(includeexecdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(includeexecdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(includeexecdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(includeexecdir)'"; \ $(INSTALL_HEADER) $$files "$(DESTDIR)$(includeexecdir)" || exit $$?; \ done uninstall-nodist_includeexecHEADERS: @$(NORMAL_UNINSTALL) @list='$(nodist_includeexec_HEADERS)'; test -n "$(includeexecdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(includeexecdir)'; $(am__uninstall_files_from_dir) # This directory's subdirectories are mostly independent; you can cd # into them and run 'make' without going through this Makefile. # To change the values of 'make' variables: instead of editing Makefiles, # (1) if the variable is set in 'config.status', edit 'config.status' # (which will cause the Makefiles to be regenerated when you run 'make'); # (2) otherwise, pass the desired values on the 'make' command line. $(am__recursive_targets): @fail=; \ if $(am__make_keepgoing); then \ failcom='fail=yes'; \ else \ failcom='exit 1'; \ fi; \ dot_seen=no; \ target=`echo $@ | sed s/-recursive//`; \ case "$@" in \ distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ *) list='$(SUBDIRS)' ;; \ esac; \ for subdir in $$list; do \ echo "Making $$target in $$subdir"; \ if test "$$subdir" = "."; then \ dot_seen=yes; \ local_target="$$target-am"; \ else \ local_target="$$target"; \ fi; \ ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ || eval $$failcom; \ done; \ if test "$$dot_seen" = "no"; then \ $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ fi; test -z "$$fail" ID: $(am__tagged_files) $(am__define_uniq_tagged_files); mkid -fID $$unique tags: tags-recursive TAGS: tags tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) set x; \ here=`pwd`; \ if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ include_option=--etags-include; \ empty_fix=.; \ else \ include_option=--include; \ empty_fix=; \ fi; \ list='$(SUBDIRS)'; for subdir in $$list; do \ if test "$$subdir" = .; then :; else \ test ! -f $$subdir/TAGS || \ set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \ fi; \ done; \ $(am__define_uniq_tagged_files); \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: ctags-recursive CTAGS: ctags ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) $(am__define_uniq_tagged_files); \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" cscope: cscope.files test ! -s cscope.files \ || $(CSCOPE) -b -q $(AM_CSCOPEFLAGS) $(CSCOPEFLAGS) -i cscope.files $(CSCOPE_ARGS) clean-cscope: -rm -f cscope.files cscope.files: clean-cscope cscopelist cscopelist: cscopelist-recursive cscopelist-am: $(am__tagged_files) list='$(am__tagged_files)'; \ case "$(srcdir)" in \ [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ *) sdir=$(subdir)/$(srcdir) ;; \ esac; \ for i in $$list; do \ if test -f "$$i"; then \ echo "$(subdir)/$$i"; \ else \ echo "$$sdir/$$i"; \ fi; \ done >> $(top_builddir)/cscope.files distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags -rm -f cscope.out cscope.in.out cscope.po.out cscope.files distdir: $(DISTFILES) $(am__remove_distdir) test -d "$(distdir)" || mkdir "$(distdir)" @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ if test "$$subdir" = .; then :; else \ $(am__make_dryrun) \ || test -d "$(distdir)/$$subdir" \ || $(MKDIR_P) "$(distdir)/$$subdir" \ || exit 1; \ dir1=$$subdir; dir2="$(distdir)/$$subdir"; \ $(am__relativize); \ new_distdir=$$reldir; \ dir1=$$subdir; dir2="$(top_distdir)"; \ $(am__relativize); \ new_top_distdir=$$reldir; \ echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \ echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \ ($(am__cd) $$subdir && \ $(MAKE) $(AM_MAKEFLAGS) \ top_distdir="$$new_top_distdir" \ distdir="$$new_distdir" \ am__remove_distdir=: \ am__skip_length_check=: \ am__skip_mode_fix=: \ distdir) \ || exit 1; \ fi; \ done $(MAKE) $(AM_MAKEFLAGS) \ top_distdir="$(top_distdir)" distdir="$(distdir)" \ dist-hook -test -n "$(am__skip_mode_fix)" \ || find "$(distdir)" -type d ! -perm -755 \ -exec chmod u+rwx,go+rx {} \; -o \ ! -type d ! -perm -444 -links 1 -exec chmod a+r {} \; -o \ ! -type d ! -perm -400 -exec chmod a+r {} \; -o \ ! -type d ! -perm -444 -exec $(install_sh) -c -m a+r {} {} \; \ || chmod -R a+r "$(distdir)" dist-gzip: distdir tardir=$(distdir) && $(am__tar) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).tar.gz $(am__post_remove_distdir) dist-bzip2: distdir tardir=$(distdir) && $(am__tar) | BZIP2=$${BZIP2--9} bzip2 -c >$(distdir).tar.bz2 $(am__post_remove_distdir) dist-lzip: distdir tardir=$(distdir) && $(am__tar) | lzip -c $${LZIP_OPT--9} >$(distdir).tar.lz $(am__post_remove_distdir) dist-xz: distdir tardir=$(distdir) && $(am__tar) | XZ_OPT=$${XZ_OPT--e} xz -c >$(distdir).tar.xz $(am__post_remove_distdir) dist-tarZ: distdir @echo WARNING: "Support for shar distribution archives is" \ "deprecated." >&2 @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z $(am__post_remove_distdir) dist-shar: distdir @echo WARNING: "Support for distribution archives compressed with" \ "legacy program 'compress' is deprecated." >&2 @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 shar $(distdir) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).shar.gz $(am__post_remove_distdir) dist-zip: distdir -rm -f $(distdir).zip zip -rq $(distdir).zip $(distdir) $(am__post_remove_distdir) dist dist-all: $(MAKE) $(AM_MAKEFLAGS) $(DIST_TARGETS) am__post_remove_distdir='@:' $(am__post_remove_distdir) # This target untars the dist file and tries a VPATH configuration. Then # it guarantees that the distribution is self-contained by making another # tarfile. distcheck: dist case '$(DIST_ARCHIVES)' in \ *.tar.gz*) \ GZIP=$(GZIP_ENV) gzip -dc $(distdir).tar.gz | $(am__untar) ;;\ *.tar.bz2*) \ bzip2 -dc $(distdir).tar.bz2 | $(am__untar) ;;\ *.tar.lz*) \ lzip -dc $(distdir).tar.lz | $(am__untar) ;;\ *.tar.xz*) \ xz -dc $(distdir).tar.xz | $(am__untar) ;;\ *.tar.Z*) \ uncompress -c $(distdir).tar.Z | $(am__untar) ;;\ *.shar.gz*) \ GZIP=$(GZIP_ENV) gzip -dc $(distdir).shar.gz | unshar ;;\ *.zip*) \ unzip $(distdir).zip ;;\ esac chmod -R a-w $(distdir) chmod u+w $(distdir) mkdir $(distdir)/_build $(distdir)/_inst chmod a-w $(distdir) test -d $(distdir)/_build || exit 0; \ dc_install_base=`$(am__cd) $(distdir)/_inst && pwd | sed -e 's,^[^:\\/]:[\\/],/,'` \ && dc_destdir="$${TMPDIR-/tmp}/am-dc-$$$$/" \ && am__cwd=`pwd` \ && $(am__cd) $(distdir)/_build \ && ../configure \ $(AM_DISTCHECK_CONFIGURE_FLAGS) \ $(DISTCHECK_CONFIGURE_FLAGS) \ --srcdir=.. --prefix="$$dc_install_base" \ && $(MAKE) $(AM_MAKEFLAGS) \ && $(MAKE) $(AM_MAKEFLAGS) dvi \ && $(MAKE) $(AM_MAKEFLAGS) check \ && $(MAKE) $(AM_MAKEFLAGS) install \ && $(MAKE) $(AM_MAKEFLAGS) installcheck \ && $(MAKE) $(AM_MAKEFLAGS) uninstall \ && $(MAKE) $(AM_MAKEFLAGS) distuninstallcheck_dir="$$dc_install_base" \ distuninstallcheck \ && chmod -R a-w "$$dc_install_base" \ && ({ \ (cd ../.. && umask 077 && mkdir "$$dc_destdir") \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" install \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" uninstall \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" \ distuninstallcheck_dir="$$dc_destdir" distuninstallcheck; \ } || { rm -rf "$$dc_destdir"; exit 1; }) \ && rm -rf "$$dc_destdir" \ && $(MAKE) $(AM_MAKEFLAGS) dist \ && rm -rf $(DIST_ARCHIVES) \ && $(MAKE) $(AM_MAKEFLAGS) distcleancheck \ && cd "$$am__cwd" \ || exit 1 $(am__post_remove_distdir) @(echo "$(distdir) archives ready for distribution: "; \ list='$(DIST_ARCHIVES)'; for i in $$list; do echo $$i; done) | \ sed -e 1h -e 1s/./=/g -e 1p -e 1x -e '$$p' -e '$$x' distuninstallcheck: @test -n '$(distuninstallcheck_dir)' || { \ echo 'ERROR: trying to run $@ with an empty' \ '$$(distuninstallcheck_dir)' >&2; \ exit 1; \ }; \ $(am__cd) '$(distuninstallcheck_dir)' || { \ echo 'ERROR: cannot chdir into $(distuninstallcheck_dir)' >&2; \ exit 1; \ }; \ test `$(am__distuninstallcheck_listfiles) | wc -l` -eq 0 \ || { echo "ERROR: files left after uninstall:" ; \ if test -n "$(DESTDIR)"; then \ echo " (check DESTDIR support)"; \ fi ; \ $(distuninstallcheck_listfiles) ; \ exit 1; } >&2 distcleancheck: distclean @if test '$(srcdir)' = . ; then \ echo "ERROR: distcleancheck can only run from a VPATH build" ; \ exit 1 ; \ fi @test `$(distcleancheck_listfiles) | wc -l` -eq 0 \ || { echo "ERROR: files left in build directory after distclean:" ; \ $(distcleancheck_listfiles) ; \ exit 1; } >&2 check-am: all-am check: $(BUILT_SOURCES) $(MAKE) $(AM_MAKEFLAGS) check-recursive all-am: Makefile $(LTLIBRARIES) $(HEADERS) config.h installdirs: installdirs-recursive installdirs-am: for dir in "$(DESTDIR)$(libdir)" "$(DESTDIR)$(includedir)" "$(DESTDIR)$(includeexecdir)"; do \ test -z "$$dir" || $(MKDIR_P) "$$dir"; \ done install: $(BUILT_SOURCES) $(MAKE) $(AM_MAKEFLAGS) install-recursive install-exec: install-exec-recursive install-data: install-data-recursive uninstall: uninstall-recursive install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-recursive install-strip: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) -test -z "$(DISTCLEANFILES)" || rm -f $(DISTCLEANFILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." -test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) clean: clean-recursive clean-am: clean-generic clean-libLTLIBRARIES clean-libtool clean-local \ mostlyclean-am distclean: distclean-recursive -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-hdr distclean-libtool distclean-local distclean-tags dvi: dvi-recursive dvi-am: html: html-recursive html-am: info: info-recursive info-am: install-data-am: install-includeHEADERS @$(NORMAL_INSTALL) $(MAKE) $(AM_MAKEFLAGS) install-data-hook install-dvi: install-dvi-recursive install-dvi-am: install-exec-am: install-libLTLIBRARIES \ install-nodist_includeexecHEADERS install-html: install-html-recursive install-html-am: install-info: install-info-recursive install-info-am: install-man: install-pdf: install-pdf-recursive install-pdf-am: install-ps: install-ps-recursive install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-recursive -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -rf $(top_srcdir)/autom4te.cache -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-recursive mostlyclean-am: mostlyclean-compile mostlyclean-generic \ mostlyclean-libtool pdf: pdf-recursive pdf-am: ps: ps-recursive ps-am: uninstall-am: uninstall-includeHEADERS uninstall-libLTLIBRARIES \ uninstall-nodist_includeexecHEADERS .MAKE: $(am__recursive_targets) all check install install-am \ install-data-am install-strip .PHONY: $(am__recursive_targets) CTAGS GTAGS TAGS all all-am \ am--refresh check check-am clean clean-cscope clean-generic \ clean-libLTLIBRARIES clean-libtool clean-local cscope \ cscopelist-am ctags ctags-am dist dist-all dist-bzip2 \ dist-gzip dist-hook dist-lzip dist-shar dist-tarZ dist-xz \ dist-zip distcheck distclean distclean-compile \ distclean-generic distclean-hdr distclean-libtool \ distclean-local distclean-tags distcleancheck distdir \ distuninstallcheck dvi dvi-am html html-am info info-am \ install install-am install-data install-data-am \ install-data-hook install-dvi install-dvi-am install-exec \ install-exec-am install-html install-html-am \ install-includeHEADERS install-info install-info-am \ install-libLTLIBRARIES install-man \ install-nodist_includeexecHEADERS install-pdf install-pdf-am \ install-ps install-ps-am install-strip installcheck \ installcheck-am installdirs installdirs-am maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-compile \ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am uninstall-includeHEADERS \ uninstall-libLTLIBRARIES uninstall-nodist_includeexecHEADERS install-data-hook: @echo '' @echo '+-------------------------------------------------------------+' @echo '| CAUTION: |' @echo '| |' @echo '| If you have not already run "make check", then we strongly |' @echo '| recommend you do so. |' @echo '| |' @echo '| GMP has been carefully tested by its authors, but compilers |' @echo '| are all too often released with serious bugs. GMP tends to |' @echo '| explore interesting corners in compilers and has hit bugs |' @echo '| on quite a few occasions. |' @echo '| |' @echo '+-------------------------------------------------------------+' @echo '' fac_table.h: gen-fac$(EXEEXT_FOR_BUILD) ./gen-fac $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >fac_table.h || (rm -f fac_table.h; exit 1) gen-fac$(EXEEXT_FOR_BUILD): gen-fac$(U_FOR_BUILD).c bootstrap.c $(CC_FOR_BUILD) `test -f 'gen-fac$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-fac$(U_FOR_BUILD).c -o gen-fac$(EXEEXT_FOR_BUILD) fib_table.h: gen-fib$(EXEEXT_FOR_BUILD) ./gen-fib header $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >fib_table.h || (rm -f fib_table.h; exit 1) mpn/fib_table.c: gen-fib$(EXEEXT_FOR_BUILD) ./gen-fib table $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mpn/fib_table.c || (rm -f mpn/fib_table.c; exit 1) gen-fib$(EXEEXT_FOR_BUILD): gen-fib$(U_FOR_BUILD).c bootstrap.c $(CC_FOR_BUILD) `test -f 'gen-fib$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-fib$(U_FOR_BUILD).c -o gen-fib$(EXEEXT_FOR_BUILD) mp_bases.h: gen-bases$(EXEEXT_FOR_BUILD) ./gen-bases header $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mp_bases.h || (rm -f mp_bases.h; exit 1) mpn/mp_bases.c: gen-bases$(EXEEXT_FOR_BUILD) ./gen-bases table $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mpn/mp_bases.c || (rm -f mpn/mp_bases.c; exit 1) gen-bases$(EXEEXT_FOR_BUILD): gen-bases$(U_FOR_BUILD).c bootstrap.c $(CC_FOR_BUILD) `test -f 'gen-bases$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-bases$(U_FOR_BUILD).c -o gen-bases$(EXEEXT_FOR_BUILD) $(LIBM_FOR_BUILD) trialdivtab.h: gen-trialdivtab$(EXEEXT_FOR_BUILD) ./gen-trialdivtab $(GMP_LIMB_BITS) 8000 >trialdivtab.h || (rm -f trialdivtab.h; exit 1) gen-trialdivtab$(EXEEXT_FOR_BUILD): gen-trialdivtab$(U_FOR_BUILD).c bootstrap.c $(CC_FOR_BUILD) `test -f 'gen-trialdivtab$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-trialdivtab$(U_FOR_BUILD).c -o gen-trialdivtab$(EXEEXT_FOR_BUILD) $(LIBM_FOR_BUILD) mpn/jacobitab.h: gen-jacobitab$(EXEEXT_FOR_BUILD) ./gen-jacobitab >mpn/jacobitab.h || (rm -f mpn/jacobitab.h; exit 1) gen-jacobitab$(EXEEXT_FOR_BUILD): gen-jacobitab$(U_FOR_BUILD).c $(CC_FOR_BUILD) `test -f 'gen-jacobitab$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-jacobitab$(U_FOR_BUILD).c -o gen-jacobitab$(EXEEXT_FOR_BUILD) mpn/perfsqr.h: gen-psqr$(EXEEXT_FOR_BUILD) ./gen-psqr $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mpn/perfsqr.h || (rm -f mpn/perfsqr.h; exit 1) gen-psqr$(EXEEXT_FOR_BUILD): gen-psqr$(U_FOR_BUILD).c bootstrap.c $(CC_FOR_BUILD) `test -f 'gen-psqr$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-psqr$(U_FOR_BUILD).c -o gen-psqr$(EXEEXT_FOR_BUILD) $(LIBM_FOR_BUILD) # Avoid: CVS - cvs directories # *~ - emacs backups # .#* - cvs merge originals # # *~ and .#* only occur when a whole directory without it's own Makefile.am # is distributed, like "doc" or the mpn cpu subdirectories. # dist-hook: -find $(distdir) \( -name CVS -type d \) -o -name "*~" -o -name ".#*" \ | xargs rm -rf cp "$(srcdir)"/mini-gmp/tests/*.[ch] "$(distdir)/mini-gmp/tests" # grep -F $(VERSION) $(srcdir)/Makefile.am \ # | grep -q "^# *$(VERSION) *$(LIBGMP_LT_CURRENT):$(LIBGMP_LT_REVISION):$(LIBGMP_LT_AGE) *$(LIBGMPXX_LT_CURRENT):$(LIBGMPXX_LT_REVISION):$(LIBGMPXX_LT_AGE)" # test -z "`sed -n 's/^# *[0-9]*\.[0-9]*\.[0-9]* *\([0-9]*:[0-9]*:[0-9]*\) *\([0-9]*:[0-9]*:[0-9]*\) *\([0-9]*:[0-9]*:[0-9]*\).*/A\1\nB\2\nC\3/p' $(srcdir)/Makefile.am | grep -v 'A6:3:3\|B3:5:0\|C4:7:1' | sort | uniq -d`" .PHONY: check-mini-gmp clean-mini-gmp check-mini-gmp: abs_srcdir="`cd $(srcdir) && pwd`" ; \ $(MKDIR_P) mini-gmp/tests \ && cd mini-gmp/tests \ && LD_LIBRARY_PATH="../../.libs:$$LD_LIBRARY_PATH" \ DYLD_LIBRARY_PATH="../../.libs:$$DYLD_LIBRARY_PATH" \ $(MAKE) -f "$$abs_srcdir/mini-gmp/tests/Makefile" \ VPATH="$$abs_srcdir/mini-gmp/tests" \ srcdir="$$abs_srcdir/mini-gmp/tests" \ MINI_GMP_DIR="$$abs_srcdir/mini-gmp" \ LDFLAGS="-L../../.libs" \ LIBS="-lgmp -lm" \ CC="$(CC_FOR_BUILD)" EXTRA_CFLAGS="-g -I../.." check clean-mini-gmp: if [ -d mini-gmp/tests ] ; then \ abs_srcdir="`cd $(srcdir) && pwd`" ; \ cd mini-gmp/tests \ && $(MAKE) -f "$$abs_srcdir/mini-gmp/tests/Makefile" clean ; \ fi clean-local: clean-mini-gmp distclean-local: clean-mini-gmp # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: gcl/gmp4/NEWS000066400000000000000000001012261242227143400131740ustar00rootroot00000000000000Copyright 1996, 1999-2014 Free Software Foundation, Inc. Verbatim copying and distribution of this entire article is permitted in any medium, provided this notice is preserved. Changes between GMP version 5.1.* and 5.2.0 BUGS FIXED * The function mpz_invert now considers any number invertible in Z/1Z. * The mpn multiply code now handles operands of more than 2^31 limbs correctly. (Note however that the mpz code is limited to 2^32 bits on 32-bit hosts and 2^37 bits on 64-bit hosts.) * Contains all fixes from release 5.1.3. SPEEDUPS * Plain division of large operands is faster and more monotonous in operand size. * Major speedup for ARM, in particular ARM Cortex-A15, thanks to improved assembly. * Major speedup for SPARC T4/T5 and speedup also for T3, thanks to a lot of new assembly. * Speedup for Intel Sandy Bridge, Ivy Bridge, Haswell, thanks to rewritten and vastly expanded assembly support. Speedup also for the older Core 2 and Nehalem. * Faster mixed arithmetic between mpq_class and double. * With g++, optimise more operations when one argument is a simple constant. FEATURES * Support for new Intel and AMD CPUs. * Support for ARM64 alias Aarch64 alias ARMv8. * New public functions mpn_sec_mul and mpn_sec_sqr, implementing side-channel silent multiplication and squaring. * New public functions mpn_sec_div_qr and mpn_sec_div_r, implementing side-channel silent division. * New public functions mpn_cnd_add_n and mpn_cnd_sub_n. Side-channel silent conditional addition and subtraction. * New public function mpn_sec_powm, implementing side-channel silent modexp. * New public function mpn_sec_invert, implementing side-channel silent modular inversion. * Better support for applications which use the mpz_t type, but nevertheless need to call some of the lower-level mpn functions. See the documentation for mpz_limbs_read and related functions. MISC * This release will not work on NetBSD 5.x, FreeBSD 7.x, 8.x or 9 series before 9.3. The reason is that the m4 command is not correctly implemented. (Workaround: Use an older GMP release, or install GNU m4 from /usr/ports and tell GMP to use it.) * This release will not build properly on FreeBSD/amd64 before version 10 using the 32-bit ABI (once a working m4 is installed). The reason is broken limits.h. (Workaround: Use an older GMP release if using the 32-bit ABI on these FreeBSD releases is important.) * This release will not work reliably on FreeBSD 10.0 for i386 or amd64 using the 32-bit ABI. The reason is bugs in the compiler 'clang'. Depending on CPU-dependent compiler flags, GMP may or may not be miscompiled in a particular build. (Workaround: Compiling gcc from /usr/ports should work, except that gcc circularly depends on GMP; we have not been able to test that workaround due to FreeBSD 10.0 bugs affecting its ability to run under KVM and Xen.) * This release will not compile on FreeBSD before version 10 for i386, targeting any modern AMD processor. The reason is bugs in the old gcc bundled with FreeBSD. (Workaround: install a less obsolete gcc from /usr/ports and tell GMP to use it, or override the -march=amdfam10 GMP configure command line argument.) Changes between GMP version 5.1.2 and 5.1.3 BUGS FIXED * The internal functions mpn_sbpi1_div_qr_sec mpn_sbpi1_div_r_sec could compute garbage with a low probability. They are now rewritten, and the test code has been improved. * A bug in the ia64 implementation of mpn_divrem_2, clobbering some callee-save registers, has been fixed. This is an internal function, with the bug manifesting itself as miscomputation in, e.g., mpn_sqrtrem. * The documentation now correctly says 'const' for input arguments. SPEEDUPS * None. FEATURES * None. MISC * None. Changes between GMP version 5.1.1 and 5.1.2 BUGS FIXED * A bug in mpz_powm_ui triggered by base arguments of at least 15000 decimal digits or mod arguments of at least 7500 decimal digits has been fixed. * An AMD Bulldozer specific bug affecting the 64-bit Windows ABI has been fixed. This bug was in a key function (mpn_mul_1) and made both Bulldozer specific builds and fat builds run on Bulldozer completely non-functional. SPEEDUPS * None. FEATURES * None. MISC * Fixes and generalisations to the test suite. * Minor portability enhancements. Changes between GMP version 5.1.0 and 5.1.1 BUGS FIXED * On Windows 64-bit, an error causing link errors about __gmp_binvert_limb_table has been fixed. * Aarch64 alias ARM64 support now works. * A possible buffer overrun in mpz_ior has been fixed. * A rare sign flip in mpz_remove has been fixed. * A bug causing problems with mpf numbers with absolute value >= 2^31 has been fixed. * Several bugs in mini-gmp have been fixed. * A bug caused by automake, related to the 'distcheck' target, has been fixed by upgrading the automake used for GMP release engineering. SPEEDUPS * None. FEATURES * Preliminary support for the x32 ABI under x86-64. MISC * The mini-gmp testsuite now tests the entire set of functions. * Various improvements of the GMP testsuite. Changes between GMP version 5.0.* and 5.1.0 BUGS FIXED * When reading a C++ number (like mpz_class) in an istream reaches the end of the stream, the eofbit is now set. * The result sign of mpz_rootrem's remainder is now always correct. * The mpz_remove function now handles negative divisors. * Contains all fixes from release 5.0.5. SPEEDUPS * The n-factorial and n-over-k functions have been reimplemented for great speedups for small and large operands. * New subquadratic algorithm for the Kronecker/Jacobi/Legendre symbol. * Major speedup for ARM, in particular ARM Cortex-A9 and A15, thanks to broad assembly support. * Significant speedup for POWER6 and POWER7 thanks to improved assembly. * The performance under M$ Windows' 64-bit ABI has been greatly improved thanks to complete assembly support. * Minor speed improvements of many functions and for many platforms. FEATURES * Many new CPUs recognised. * New functions for multi-factorials, and primorial: mpz_2fac_ui, mpz_mfac_uiui and mpz_primorial_ui. * The mpz_powm_sec function now uses side-channel silent division for converting into Montgomery residues. * The fat binary mechanism is now more robust in its CPU recognition. MISC * Inclusion of assembly code is now controlled by the configure options --enable-assembly and --disable-assembly. The "none" CPU target is gone. * In C++, the conversions mpq_class->mpz_class, mpf_class->mpz_class and mpf_class->mpq_class are now explicit. * Includes "mini-gmp", a small, portable, but less efficient, implementation of a subset of GMP's mpn and mpz interfaces. Used in GMP bootstrap, but it can also be bundled with applications as a fallback when the real GMP library is unavailable. * The ABIs under AIX are no longer called aix32 and aix64, but mode64 and 32. This is more consistent with other powerpc systems. * The coverage of the testsuite has been improved, using the lcov tool. See also https://gmplib.org/devel/lcov/. * It is now possible to compile GMP using a C++ compiler. * K&R C compilers are no longer supported. * The BSD MP compatibility functions have been removed. Changes between GMP version 5.0.4 and 5.0.5 BUGS FIXED * A bug causing AMD 11h processors to be treated like AMD 10h has been fixed. The 11h processors do not correctly handle all 10h (aka K10) instructions, and GMP's use of these instructions results in major miscomputations (not as one would have hoped CPU traps of some 'illegal instruction' sort). * A bug affecting recent Intel Sandy Bridge CPUs resulting in configuration failures has been fixed. SPEEDUPS * None. FEATURES * A couple of tests added to the self-check suite. MISC * None. Changes between GMP version 5.0.3 and 5.0.4 BUGS FIXED * Thresholds in mpn_powm_sec for both fat and non-fat builds are now used safely, plugging a one-word buffer overrun introduced in the 5.0.3 release (for non-fat) and a multi-word buffer overrun that existed since 5.0 (for fat). (We have not been able to provoke malign stack smashing in any of the ~100 configurations explored by the GMP nightly builds, but the bug should be assumed to be exploitable.) * Two bugs in multiplication code causing incorrect computation with extremely low probability have been fixed. * A bug in the test suite causing buffer overruns during "make check", sometimes leading to subsequent malloc crashes, has been fixed. * Two bugs in the gcd code have been fixed. They could lead to incorrect results, but for uniformly distributed random operands, the likelihood for that is infinitesimally small. (There was also a third bug, but that was an incorrect ASSERT, which furthermore was not enabled by default.) * A bug affecting 32-bit PowerPC division has been fixed. The bug caused miscomputation for certain divisors in the range 2^32 ... 2^64-1 (about 1 in 2^30 of these). SPEEDUPS * None, except indirectly through recognition of new CPUs, and through better tuning parameters. FEATURES * Some more tests added to the self-check suite. * The AMD "Bulldozer" CPU is now recognised. MISC * None. Changes between GMP version 5.0.2 and 5.0.3 BUGS FIXED * A few minor bugs related to portability fixed. * A slight timing leak of the powm_sec functions have been sealed. (This leak could possibly be used to extract the most significant few bits of the exponent. "Few" here means at most 10.) * The mpz_nextprime function now runs a safer number of pseudo-random prime tests. * A bug in division code possibly causing incorrect computation was fixed. SPEEDUPS * None, except indirectly through recognition of new CPUs, and through better tuning parameters. FEATURES * New CPUs recognised. * IBM S/390 are now supported in both 31/32-bit and 64-bit mode. (We have not been able to fully test this on any multilib machine, since IBM expired our guest account a few days before our release.) MISC * None. Changes between GMP version 5.0.1 and 5.0.2 BUGS FIXED * Many minor bugs related to portability fixed. * The support for HPPA 2.0N now works, after an assembly bug fix. * A test case type error has been fixed. The symptom of this bug was spurious 'make check' failures. SPEEDUPS * None, except indirectly through recognition of new CPUs. FEATURES * Fat builds are now supported for 64-bit x86 processors also under Darwin. MISC * None. Changes between GMP version 5.0.0 and 5.0.1 BUGS FIXED * Fat builds fixed. * Fixed crash for huge multiplies when old FFT_TABLE2 type of parameter selection tables' sentinel was smaller than multiplied operands. * The solib numbers now reflect the removal of the documented but preliminary mpn_bdivmod function; we correctly flag incompatibility with GMP 4.3. GMP 5.0.0 has this wrong, and should perhaps be uninstalled to avoid confusion. SPEEDUPS * Multiplication of large numbers has indirectly been sped up through better FFT tuning and processor recognition. Since many operations depend on multiplication, there will be a general speedup. FEATURES * More Core i3, i5 an Core i7 processor models are recognised. * Fixes and workarounds for Mac OS quirks should make this GMP version build using many of the different versions of "Xcode". MISC * The amount of scratch memory needed for multiplication of huge numbers has been reduced substantially (but is still larger than in GMP 4.3.) * Likewise, the amount of scratch memory needed for division of large numbers has been reduced substantially. * The FFT tuning code of tune/tuneup.c has been completely rewritten, and new, large FFT parameter selection tables are provided for many machines. * Upgraded to the latest autoconf, automake, libtool. Changes between GMP version 4.3.X and 5.0.0 BUGS FIXED * None (contains the same fixes as release 4.3.2). SPEEDUPS * Multiplication has been overhauled: (1) Multiplication of larger same size operands has been improved with the addition of two new Toom functions and a new internal function mpn_mulmod_bnm1 (computing U * V mod (B^n-1), B being the word base. This latter function is used for the largest products, waiting for a better Schoenhage-Strassen U * V mod (B^n+1) implementation. (2) Likewise for squaring. (3) Multiplication of different size operands has been improved with the addition of many new Toom function, and by selecting underlying functions better from the main multiply functions. * Division and mod have been overhauled: (1) Plain "schoolbook" division is reimplemented using faster quotient approximation. (2) Division Q = N/D, R = N mod D where both the quotient and remainder are needed now runs in time O(M(log(N))). This is an improvement of a factor log(log(N)) (3) Division where just the quotient is needed is now O(M(log(Q))) on average. (4) Modulo operations using Montgomery REDC form now take time O(M(n)). (5) Exact division Q = N/D by means of mpz_divexact has been improved for all sizes, and now runs in time O(M(log(N))). * The function mpz_powm is now faster for all sizes. Its complexity has gone from O(M(n)log(n)m) to O(M(n)m) where n is the size of the modulo argument and m is the size of the exponent. It is also radically faster for even modulus, since it now partially factors such modulus and performs two smaller modexp operations, then uses CRT. * The internal support for multiplication yielding just the lower n limbs has been improved by using Mulders' algorithm. * Computation of inverses, both plain 1/N and 1/N mod B^n have been improved by using well-tuned Newton iterations, and wrap-around multiplication using mpn_mulmod_bnm1. * A new algorithm makes mpz_perfect_power_p asymptotically faster. * The function mpz_remove uses a much faster algorithm, is better tuned, and also benefits from the division improvements. * Intel Atom and VIA Nano specific optimisations. * Plus hundreds of smaller improvements and tweaks! FEATURES * New mpz function: mpz_powm_sec for side-channel quiet modexp computations. * New mpn functions: mpn_sqr, mpn_and_n, mpn_ior_n, mpn_xor_n, mpn_nand_n, mpn_nior_n, mpn_xnor_n, mpn_andn_n, mpn_iorn_n, mpn_com, mpn_neg, mpn_copyi, mpn_copyd, mpn_zero. * The function mpn_tdiv_qr now allows certain argument overlap. * Support for fat binaries for 64-bit x86 processors has been added. * A new type, mp_bitcnt_t for bignum bit counts, has been introduced. * Support for Windows64 through mingw64 has been added. * The cofactors of mpz_gcdext and mpn_gcdext are now more strictly normalised, returning to how GMP 4.2 worked. (Note that also release 4.3.2 has this change.) MISC * The mpn_mul function should no longer be used for squaring, instead use the new mpn_sqr. * The algorithm selection has been improved, the number of thresholds have more than doubled, and the tuning and use of existing thresholds have been improved. * The tune/speed program can measure many of new functions. * The mpn_bdivmod function has been removed. We do not consider this an incompatible change, since the function was marked as preliminary. * The testsuite has been enhanced in various ways. Changes between GMP version 4.3.1 and 4.3.2 Bugs: * Fixed bug in mpf_eq. * Fixed overflow issues in mpz_set_str, mpz_inp_str, mpf_set_str, and mpf_get_str. * Avoid unbounded stack allocation for unbalanced multiplication. * Fixed bug in FFT multiplication. Speedups: * None, except that proper processor recognition helps affected processors. Features: * Recognise more "Core 2" processor variants. * The cofactors of mpz_gcdext and mpn_gcdext are now more strictly normalised, returning to how GMP 4.2 worked. Changes between GMP version 4.3.0 and 4.3.1 Bugs: * Fixed bug in mpn_gcdext, affecting also mpz_gcdext and mpz_invert. The bug could cause a cofactor to have a leading zero limb, which could lead to crashes or miscomputation later on. * Fixed some minor documentation issues. Speedups: * None. Features: * Workarounds for various issues with Mac OS X's build tools. * Recognise more IBM "POWER" processor variants. Changes between GMP version 4.2.X and 4.3.0 Bugs: * Fixed bug in mpz_perfect_power_p with recognition of negative perfect powers that can be written both as an even and odd power. * We might accidentally have added bugs since there is a large amount of new code in this release. Speedups: * Vastly improved assembly code for x86-64 processors from AMD and Intel. * Major improvements also for many other processor families, such as Alpha, PowerPC, and Itanium. * New sub-quadratic mpn_gcd and mpn_gcdext, as well as improved basecase gcd code. * The multiply FFT code has been slightly improved. * Balanced multiplication now uses 4-way Toom in addition to schoolbook, Karatsuba, 3-way Toom, and FFT. * Unbalanced multiplication has been vastly improved. * Improved schoolbook division by means of faster quotient approximation. * Several new algorithms for division and mod by single limbs, giving many-fold speedups. * Improved nth root computations. * The mpz_nextprime function uses sieving and is much faster. * Countless minor tweaks. Features: * Updated support for fat binaries for x86_32 include current processors * Lots of new mpn internal interfaces. Some of them will become public in a future GMP release. * Support for the 32-bit ABI under x86-apple-darwin. * x86 CPU recognition code should now default better for future processors. * The experimental nails feature does not work in this release, but it might be re-enabled in the future. Misc: * The gmp_version variable now always contains three parts. For this release, it is "4.3.0". Changes between GMP version 4.2.3 and 4.2.4 Bugs: * Fix bug with parsing exponent '+' sign in mpf. * Fix an allocation bug in mpf_set_str, also affecting mpf_init_set_str, and mpf_inp_str. Speedups: * None, except that proper processor recognition helps affected processors. Features: * Recognize new AMD processors. Changes between GMP version 4.2.2 and 4.2.3 Bugs: * Fix x86 CPU recognition code to properly identify recent AMD and Intel 64-bit processors. * The >> operator of the C++ wrapper gmpxx.h now does floor rounding, not truncation. * Inline semantics now follow the C99 standard, and works with recent GCC releases. * C++ bitwise logical operations work for more types. * For C++, gmp.h now includes cstdio, improving compiler compatibility. * Bases > 36 now work properly in mpf_set_str. Speedups: * None, except that proper processor recognition helps affected processors. Features: * The allocation functions now detect overflow of the mpz_t type. This means that overflow will now cause an abort, except when the allocation computation itself overflows. (Such overflow can probably only happen in powering functions; we will detect powering overflow in the future.) Changes between GMP version 4.2.1 and 4.2.2 * License is now LGPL version 3. Bugs: * Shared library numbers corrected for libcxx. * Fixed serious bug in gmpxx.h where a=a+b*c would generate garbage. Note that this only affects C++ programs. * Fix crash in mpz_set_d for arguments with large negative exponent. * Fix 32-bit ABI bug with Itanium assembly for popcount and hamdist. * Fix assembly syntax problem for powerpc-ibm-aix with AIX native assembler. * Fix problems with x86 --enable-fat, where the compiler where told to generate code for the build machine, not plain i386 code as it should. * Improved recognition of powerpc systems wrt Altivec/VMX capability. * Misc minor fixes, mainly workarounds for compiler/assembler bugs. Speedups: * "Core 2" and Pentium 4 processors, running in 64-bit mode will get a slight boost as they are now specifically recognized. Features: * New support for x86_64-solaris * New, rudimentary support for x86-apple-darwin and x86_64-apple-darwin. (Please see https://gmplib.org/macos.html for more information.) Changes between GMP version 4.2 and 4.2.1 Bugs: * Shared library numbers corrected. * Broken support for 32-bit AIX fixed. * Misc minor fixes. Speedups: * Exact division (mpz_divexact) now falls back to plain division for large operands. Features: * Support for some new systems. Changes between GMP version 4.1.4 and 4.2 Bugs: * Minor bug fixes and code generalizations. * Expanded and improved test suite. Speedups: * Many minor optimizations, too many to mention here. * Division now always subquadratic. * Computation of n-factorial much faster. * Added basic x86-64 assembly code. * Floating-point output is now subquadratic for all bases. * FFT multiply code now about 25% faster. * Toom3 multiply code faster. Features: * Much improved configure. * Workarounds for many more compiler bugs. * Temporary allocations are now made on the stack only if small. * New systems supported: HPPA-2.0 gcc, IA-64 HP-UX, PowerPC-64 Darwin, Sparc64 GNU/Linux. * New i386 fat binaries, selecting optimised code at runtime (--enable-fat). * New build option: --enable-profiling=instrument. * New memory function: mp_get_memory_functions. * New Mersenne Twister random numbers: gmp_randinit_mt, also now used for gmp_randinit_default. * New random functions: gmp_randinit_set, gmp_urandomb_ui, gmp_urandomm_ui. * New integer functions: mpz_combit, mpz_rootrem. * gmp_printf etc new type "M" for mp_limb_t. * gmp_scanf and friends now accept C99 hex floats. * Numeric input and output can now be in bases up to 62. * Comparisons mpz_cmp_d, mpz_cmpabs_d, mpf_cmp_d recognise infinities. * Conversions mpz_get_d, mpq_get_d, mpf_get_d truncate towards zero, previously their behaviour was unspecified. * Fixes for overflow issues with operands >= 2^31 bits. Caveats: * mpfr is gone, and will from now on be released only separately. Please see www.mpfr.org. Changes between GMP version 4.1.3 and 4.1.4 * Bug fix to FFT multiplication code (crash for huge operands). * Bug fix to mpf_sub (miscomputation). * Support for powerpc64-gnu-linux. * Better support for AMD64 in 32-bit mode. * Upwardly binary compatible with 4.1.3, 4.1.2, 4.1.1, 4.1, 4.0.1, 4.0, and 3.x versions. Changes between GMP version 4.1.2 and 4.1.3 * Bug fix for FFT multiplication code (miscomputation). * Bug fix to K6 assembly code for gcd. * Bug fix to IA-64 assembly code for population count. * Portability improvements, most notably functional AMD64 support. * mpz_export allows NULL for countp parameter. * Many minor bug fixes. * mpz_export allows NULL for countp parameter. * Upwardly binary compatible with 4.1.2, 4.1.1, 4.1, 4.0.1, 4.0, and 3.x versions. Changes between GMP version 4.1.1 and 4.1.2 * Bug fixes. Changes between GMP version 4.1 and 4.1.1 * Bug fixes. * New systems supported: NetBSD and OpenBSD sparc64. Changes between GMP version 4.0.1 and 4.1 * Bug fixes. * Speed improvements. * Upwardly binary compatible with 4.0, 4.0.1, and 3.x versions. * Asymptotically fast conversion to/from strings (mpz, mpq, mpn levels), but also major speed improvements for tiny operands. * mpn_get_str parameter restrictions relaxed. * Major speed improvements for HPPA 2.0 systems. * Major speed improvements for UltraSPARC systems. * Major speed improvements for IA-64 systems (but still sub-optimal code). * Extended test suite. * mpfr is back, with many bug fixes and portability improvements. * New function: mpz_ui_sub. * New functions: mpz_export, mpz_import. * Optimization for nth root functions (mpz_root, mpz_perfect_power_p). * Optimization for extended gcd (mpz_gcdext, mpz_invert, mpn_gcdext). * Generalized low-level number format, reserving a `nails' part of each limb. (Please note that this is really experimental; some functions are likely to compute garbage when nails are enabled.) * Nails-enabled Alpha 21264 assembly code, allowing up to 75% better performance. (Use --enable-nails=4 to enable it.) Changes between GMP version 4.0 and 4.0.1 * Bug fixes. Changes between GMP version 3.1.1 and 4.0 * Bug fixes. * Speed improvements. * Upwardly binary compatible with 3.x versions. * New CPU support: IA-64, Pentium 4. * Improved CPU support: 21264, Cray vector systems. * Support for all MIPS ABIs: o32, n32, 64. * New systems supported: Darwin, SCO, Windows DLLs. * New divide-and-conquer square root algorithm. * New algorithms chapter in the manual. * New malloc reentrant temporary memory method. * New C++ class interface by Gerardo Ballabio (beta). * Revamped configure, featuring ABI selection. * Speed improvements for mpz_powm and mpz_powm_ui (mainly affecting small operands). * mpz_perfect_power_p now properly recognizes 0, 1, and negative perfect powers. * mpz_hamdist now supports negative operands. * mpz_jacobi now accepts non-positive denominators. * mpz_powm now supports negative exponents. * mpn_mul_1 operand overlap requirements relaxed. * Float input and output uses locale specific decimal point where available. * New gmp_printf, gmp_scanf and related functions. * New division functions: mpz_cdiv_q_2exp, mpz_cdiv_r_2exp, mpz_divexact_ui. * New divisibility tests: mpz_divisible_p, mpz_divisible_ui_p, mpz_divisible_2exp_p, mpz_congruent_p, mpz_congruent_ui_p, mpz_congruent_2exp_p. * New Fibonacci function: mpz_fib2_ui. * New Lucas number functions: mpz_lucnum_ui, mpz_lucnum2_ui. * Other new integer functions: mpz_cmp_d, mpz_cmpabs_d, mpz_get_d_2exp, mpz_init2, mpz_kronecker, mpz_lcm_ui, mpz_realloc2. * New rational I/O: mpq_get_str, mpq_inp_str, mpq_out_str, mpq_set_str. * Other new rational functions: mpq_abs, mpq_cmp_si, mpq_div_2exp, mpq_mul_2exp, mpq_set_f. * New float tests: mpf_integer_p, mpf_fits_sint_p, mpf_fits_slong_p, mpf_fits_sshort_p, mpf_fits_uint_p, mpf_fits_ulong_p, mpf_fits_ushort_p. * Other new float functions: mpf_cmp_d, mpf_get_default_prec, mpf_get_si, mpf_get_ui, mpf_get_d_2exp. * New random functions: gmp_randinit_default, gmp_randinit_lc_2exp_size. * New demo expression string parser (see demos/expr). * New preliminary perl interface (see demos/perl). * Tuned algorithm thresholds for many more CPUs. Changes between GMP version 3.1 and 3.1.1 * Bug fixes for division (rare), mpf_get_str, FFT, and miscellaneous minor things. Changes between GMP version 3.0 and 3.1 * Bug fixes. * Improved `make check' running more tests. * Tuned algorithm cutoff points for many machines. This will improve speed for a lot of operations, in some cases by a large amount. * Major speed improvements: Alpha 21264. * Some speed improvements: Cray vector computers, AMD K6 and Athlon, Intel P5 and Pentium Pro/II/III. * The mpf_get_prec function now works as it did in GMP 2. * New utilities for auto-tuning and speed measuring. * Multiplication now optionally uses FFT for very large operands. (To enable it, pass --enable-fft to configure.) * Support for new systems: Solaris running on x86, FreeBSD 5, HP-UX 11, Cray vector computers, Rhapsody, Nextstep/Openstep, MacOS. * Support for shared libraries on 32-bit HPPA. * New integer functions: mpz_mul_si, mpz_odd_p, mpz_even_p. * New Kronecker symbol functions: mpz_kronecker_si, mpz_kronecker_ui, mpz_si_kronecker, mpz_ui_kronecker. * New rational functions: mpq_out_str, mpq_swap. * New float functions: mpf_swap. * New mpn functions: mpn_divexact_by3c, mpn_tdiv_qr. * New EXPERIMENTAL function layer for accurate floating-point arithmetic, mpfr. To try it, pass --enable-mpfr to configure. See the mpfr subdirectory for more information; it is not documented in the main GMP manual. Changes between GMP version 3.0 and 3.0.1 * Memory leaks in gmp_randinit and mpz_probab_prime_p fixed. * Documentation for gmp_randinit fixed. Misc documentation errors fixed. Changes between GMP version 2.0 and 3.0 * Source level compatibility with past releases (except mpn_gcd). * Bug fixes. * Much improved speed thanks to both host independent and host dependent optimizations. * Switch to autoconf/automake/libtool. * Support for building libgmp as a shared library. * Multiplication and squaring using 3-way Toom-Cook. * Division using the Burnikel-Ziegler method. * New functions computing binomial coefficients: mpz_bin_ui, mpz_bin_uiui. * New function computing Fibonacci numbers: mpz_fib_ui. * New random number generators: mpf_urandomb, mpz_rrandomb, mpz_urandomb, mpz_urandomm, gmp_randclear, gmp_randinit, gmp_randinit_lc_2exp, gmp_randseed, gmp_randseed_ui. * New function for quickly extracting limbs: mpz_getlimbn. * New functions performing integer size tests: mpz_fits_sint_p, mpz_fits_slong_p, mpz_fits_sshort_p, mpz_fits_uint_p, mpz_fits_ulong_p, mpz_fits_ushort_p. * New mpf functions: mpf_ceil, mpf_floor, mpf_pow_ui, mpf_trunc. * New mpq function: mpq_set_d. * New mpz functions: mpz_addmul_ui, mpz_cmpabs, mpz_cmpabs_ui, mpz_lcm, mpz_nextprime, mpz_perfect_power_p, mpz_remove, mpz_root, mpz_swap, mpz_tdiv_ui, mpz_tstbit, mpz_xor. * New mpn function: mpn_divexact_by3. * New CPU support: DEC Alpha 21264, AMD K6 and Athlon, HPPA 2.0 and 64, Intel Pentium Pro and Pentium-II/III, Sparc 64, PowerPC 64. * Almost 10 times faster mpz_invert and mpn_gcdext. * The interface of mpn_gcd has changed. * Better support for MIPS R4x000 and R5000 under Irix 6. * Improved support for SPARCv8 and SPARCv9 processors. Changes between GMP version 2.0 and 2.0.2 * Many bug fixes. Changes between GMP version 1.3.2 and 2.0 * Division routines in the mpz class have changed. There are three classes of functions, that rounds the quotient to -infinity, 0, and +infinity, respectively. The first class of functions have names that begin with mpz_fdiv (f is short for floor), the second class' names begin with mpz_tdiv (t is short for trunc), and the third class' names begin with mpz_cdiv (c is short for ceil). The old division routines beginning with mpz_m are similar to the new mpz_fdiv, with the exception that some of the new functions return useful values. The old function names can still be used. All the old functions names will now do floor division, not trunc division as some of them used to. This was changed to make the functions more compatible with common mathematical practice. The mpz_mod and mpz_mod_ui functions now compute the mathematical mod function. I.e., the sign of the 2nd argument is ignored. * The mpq assignment functions do not canonicalize their results. A new function, mpq_canonicalize must be called by the user if the result is not known to be canonical. * The mpn functions are now documented. These functions are intended for very time critical applications, or applications that need full control over memory allocation. Note that the mpn interface is irregular and hard to use. * New functions for arbitrary precision floating point arithmetic. Names begin with `mpf_'. Associated type mpf_t. * New and improved mpz functions, including much faster GCD, fast exact division (mpz_divexact), bit scan (mpz_scan0 and mpz_scan1), and number theoretical functions like Jacobi (mpz_jacobi) and multiplicative inverse (mpz_invert). * New variable types (mpz_t and mpq_t) are available that makes syntax of mpz and mpq calls nicer (no need for & before variables). The MP_INT and MP_RAT types are still available for compatibility. * Uses GNU configure. This makes it possible to choose target architecture and CPU variant, and to compile into a separate object directory. * Carefully optimized assembly for important inner loops. Support for DEC Alpha, Amd 29000, HPPA 1.0 and 1.1, Intel Pentium and generic x86, Intel i960, Motorola MC68000, MC68020, MC88100, and MC88110, Motorola/IBM PowerPC, National NS32000, IBM POWER, MIPS R3000, R4000, SPARCv7, SuperSPARC, generic SPARCv8, and DEC VAX. Some support also for ARM, Clipper, IBM ROMP (RT), and Pyramid AP/XP. * Faster. Thanks to the assembler code, new algorithms, and general tuning. In particular, the speed on machines without GCC is improved. * Support for machines without alloca. * Now under the LGPL. INCOMPATIBILITIES BETWEEN GMP 1 AND GMP 2 * mpq assignment functions do not canonicalize their results. * mpz division functions round differently. * mpz mod functions now really compute mod. * mpz_powm and mpz_powm_ui now really use mod for reduction. gcl/gmp4/README000066400000000000000000000102231242227143400133510ustar00rootroot00000000000000Copyright 1991, 1996, 1999, 2000, 2007 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library 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 copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. THE GNU MP LIBRARY GNU MP is a library for arbitrary precision arithmetic, operating on signed integers, rational numbers, and floating point numbers. It has a rich set of functions, and the functions have a regular interface. GNU MP is designed to be as fast as possible, both for small operands and huge operands. The speed is achieved by using fullwords as the basic arithmetic type, by using fast algorithms, with carefully optimized assembly code for the most common inner loops for lots of CPUs, and by a general emphasis on speed (instead of simplicity or elegance). GNU MP is believed to be faster than any other similar library. Its advantage increases with operand sizes for certain operations, since GNU MP in many cases has asymptotically faster algorithms. GNU MP is free software and may be freely copied on the terms contained in the files COPYING* (see the manual for information on which license(s) applies to which components of GNU MP). OVERVIEW OF GNU MP There are five classes of functions in GNU MP. 1. Signed integer arithmetic functions (mpz). These functions are intended to be easy to use, with their regular interface. The associated type is `mpz_t'. 2. Rational arithmetic functions (mpq). For now, just a small set of functions necessary for basic rational arithmetics. The associated type is `mpq_t'. 3. Floating-point arithmetic functions (mpf). If the C type `double' doesn't give enough precision for your application, declare your variables as `mpf_t' instead, set the precision to any number desired, and call the functions in the mpf class for the arithmetic operations. 4. Positive-integer, hard-to-use, very low overhead functions are in the mpn class. No memory management is performed. The caller must ensure enough space is available for the results. The set of functions is not regular, nor is the calling interface. These functions accept input arguments in the form of pairs consisting of a pointer to the least significant word, and an integral size telling how many limbs (= words) the pointer points to. Almost all calculations, in the entire package, are made by calling these low-level functions. 5. Berkeley MP compatible functions. To use these functions, include the file "mp.h". You can test if you are using the GNU version by testing if the symbol __GNU_MP__ is defined. For more information on how to use GNU MP, please refer to the documentation. It is composed from the file doc/gmp.texi, and can be displayed on the screen or printed. How to do that, as well how to build the library, is described in the INSTALL file in this directory. REPORTING BUGS If you find a bug in the library, please make sure to tell us about it! You should first check the GNU MP web pages at https://gmplib.org/, under "Status of the current release". There will be patches for all known serious bugs there. Report bugs to gmp-bugs@gmplib.org. What information is needed in a useful bug report is described in the manual. The same address can be used for suggesting modifications and enhancements. ---------------- Local variables: mode: text fill-column: 78 End: gcl/gmp4/acinclude.m4000066400000000000000000003614021242227143400146720ustar00rootroot00000000000000dnl GMP specific autoconf macros dnl Copyright 2000-2006, 2009, 2011, 2013, 2014 Free Software Foundation, Inc. dnl dnl This file is part of the GNU MP Library. dnl dnl The GNU MP Library is free software; you can redistribute it and/or modify dnl it under the terms of either: dnl dnl * the GNU Lesser General Public License as published by the Free dnl Software Foundation; either version 3 of the License, or (at your dnl option) any later version. dnl dnl or dnl dnl * the GNU General Public License as published by the Free Software dnl Foundation; either version 2 of the License, or (at your option) any dnl later version. dnl dnl or both in parallel, as here. dnl dnl The GNU MP Library is distributed in the hope that it will be useful, but dnl WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY dnl or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License dnl for more details. dnl dnl You should have received copies of the GNU General Public License and the dnl GNU Lesser General Public License along with the GNU MP Library. If not, dnl see https://www.gnu.org/licenses/. dnl Some tests use, or must delete, the default compiler output. The dnl possible filenames are based on what autoconf looks for, namely dnl dnl a.out - normal unix style dnl b.out - i960 systems, including gcc there dnl a.exe - djgpp dnl a_out.exe - OpenVMS DEC C called via GNV wrapper (gnv.sourceforge.net) dnl conftest.exe - various DOS compilers define(IA64_PATTERN, [[ia64*-*-* | itanium-*-* | itanium2-*-*]]) dnl Need to be careful not to match m6811, m6812, m68hc11 and m68hc12, all dnl of which config.sub accepts. (Though none of which are likely to work dnl with GMP.) dnl define(M68K_PATTERN, [[m68k-*-* | m68[0-9][0-9][0-9]-*-*]]) define(POWERPC64_PATTERN, [[powerpc64-*-* | powerpc64le-*-* | powerpc620-*-* | powerpc630-*-* | powerpc970-*-* | power[3-9]-*-*]]) define(S390_PATTERN, [[s390-*-* | z900esa-*-* | z990esa-*-* | z9esa-*-* | z10esa-*-* | z196esa-*-*]]) define(S390X_PATTERN, [[s390x-*-* | z900-*-* | z990-*-* | z9-*-* | z10-*-* | z196-*-*]]) define(X86_PATTERN, [[i?86*-*-* | k[5-8]*-*-* | pentium*-*-* | athlon-*-* | viac3*-*-* | geode*-*-* | atom-*-*]]) define(X86_64_PATTERN, [[athlon64-*-* | k8-*-* | k10-*-* | bobcat-*-* | jaguar-*-* | bulldozer-*-* | piledriver-*-* | steamroller-*-* | excavator-*-* | pentium4-*-* | atom-*-* | core2-*-* | corei*-*-* | x86_64-*-* | nano-*-*]]) dnl GMP_FAT_SUFFIX(DSTVAR, DIRECTORY) dnl --------------------------------- dnl Emit code to set shell variable DSTVAR to the suffix for a fat binary dnl routine from DIRECTORY. DIRECTORY can be a shell expression like $foo dnl etc. dnl dnl The suffix is directory separators / or \ changed to underscores, and dnl if there's more than one directory part, then the first is dropped. dnl dnl For instance, dnl dnl x86 -> x86 dnl x86/k6 -> k6 dnl x86/k6/mmx -> k6_mmx define(GMP_FAT_SUFFIX, [[$1=`echo $2 | sed -e '/\//s:^[^/]*/::' -e 's:[\\/]:_:g'`]]) dnl GMP_REMOVE_FROM_LIST(listvar,item) dnl ---------------------------------- dnl Emit code to remove any occurrence of ITEM from $LISTVAR. ITEM can be a dnl shell expression like $foo if desired. define(GMP_REMOVE_FROM_LIST, [remove_from_list_tmp= for remove_from_list_i in $[][$1]; do if test $remove_from_list_i = [$2]; then :; else remove_from_list_tmp="$remove_from_list_tmp $remove_from_list_i" fi done [$1]=$remove_from_list_tmp ]) dnl GMP_STRIP_PATH(subdir) dnl ---------------------- dnl Strip entries */subdir from $path and $fat_path. define(GMP_STRIP_PATH, [GMP_STRIP_PATH_VAR(path, [$1]) GMP_STRIP_PATH_VAR(fat_path, [$1]) ]) define(GMP_STRIP_PATH_VAR, [tmp_path= for i in $[][$1]; do case $i in */[$2]) ;; *) tmp_path="$tmp_path $i" ;; esac done [$1]="$tmp_path" ]) dnl GMP_INCLUDE_GMP_H dnl ----------------- dnl Expand to the right way to #include gmp-h.in. This must be used dnl instead of gmp.h, since that file isn't generated until the end of the dnl configure. dnl dnl Dummy value for GMP_LIMB_BITS is enough dnl for all current configure-time uses of gmp.h. define(GMP_INCLUDE_GMP_H, [[#define __GMP_WITHIN_CONFIGURE 1 /* ignore template stuff */ #define GMP_NAIL_BITS $GMP_NAIL_BITS #define GMP_LIMB_BITS 123 $DEFN_LONG_LONG_LIMB #include "$srcdir/gmp-h.in"] ]) dnl GMP_HEADER_GETVAL(NAME,FILE) dnl ---------------------------- dnl Expand at autoconf time to the value of a "#define NAME" from the given dnl FILE. The regexps here aren't very rugged, but are enough for gmp. dnl /dev/null as a parameter prevents a hang if $2 is accidentally omitted. define(GMP_HEADER_GETVAL, [patsubst(patsubst( esyscmd([grep "^#define $1 " $2 /dev/null 2>/dev/null]), [^.*$1[ ]+],[]), [[ ]*$],[])]) dnl GMP_VERSION dnl ----------- dnl The gmp version number, extracted from the #defines in gmp-h.in at dnl autoconf time. Two digits like 3.0 if patchlevel <= 0, or three digits dnl like 3.0.1 if patchlevel > 0. define(GMP_VERSION, [GMP_HEADER_GETVAL(__GNU_MP_VERSION,gmp-h.in)[]dnl .GMP_HEADER_GETVAL(__GNU_MP_VERSION_MINOR,gmp-h.in)[]dnl .GMP_HEADER_GETVAL(__GNU_MP_VERSION_PATCHLEVEL,gmp-h.in)]) dnl GMP_SUBST_CHECK_FUNCS(func,...) dnl ------------------------------ dnl Setup an AC_SUBST of HAVE_FUNC_01 for each argument. AC_DEFUN([GMP_SUBST_CHECK_FUNCS], [m4_if([$1],,, [_GMP_SUBST_CHECK_FUNCS(ac_cv_func_[$1],HAVE_[]m4_translit([$1],[a-z],[A-Z])_01) GMP_SUBST_CHECK_FUNCS(m4_shift($@))])]) dnl Called: _GMP_SUBST_CHECK_FUNCS(cachevar,substvar) AC_DEFUN([_GMP_SUBST_CHECK_FUNCS], [case $[$1] in yes) AC_SUBST([$2],1) ;; no) [$2]=0 ;; esac ]) dnl GMP_SUBST_CHECK_HEADERS(foo.h,...) dnl ---------------------------------- dnl Setup an AC_SUBST of HAVE_FOO_H_01 for each argument. AC_DEFUN([GMP_SUBST_CHECK_HEADERS], [m4_if([$1],,, [_GMP_SUBST_CHECK_HEADERS(ac_cv_header_[]m4_translit([$1],[./],[__]), HAVE_[]m4_translit([$1],[a-z./],[A-Z__])_01) GMP_SUBST_CHECK_HEADERS(m4_shift($@))])]) dnl Called: _GMP_SUBST_CHECK_HEADERS(cachevar,substvar) AC_DEFUN([_GMP_SUBST_CHECK_HEADERS], [case $[$1] in yes) AC_SUBST([$2],1) ;; no) [$2]=0 ;; esac ]) dnl GMP_COMPARE_GE(A1,B1, A2,B2, ...) dnl --------------------------------- dnl Compare two version numbers A1.A2.etc and B1.B2.etc. Set dnl $gmp_compare_ge to yes or no according to the result. The A parts dnl should be variables, the B parts fixed numbers. As many parts as dnl desired can be included. An empty string in an A part is taken to be dnl zero, the B parts should be non-empty and non-zero. dnl dnl For example, dnl dnl GMP_COMPARE($major,10, $minor,3, $subminor,1) dnl dnl would test whether $major.$minor.$subminor is greater than or equal to dnl 10.3.1. AC_DEFUN([GMP_COMPARE_GE], [gmp_compare_ge=no GMP_COMPARE_GE_INTERNAL($@) ]) AC_DEFUN([GMP_COMPARE_GE_INTERNAL], [ifelse(len([$3]),0, [if test -n "$1" && test "$1" -ge $2; then gmp_compare_ge=yes fi], [if test -n "$1"; then if test "$1" -gt $2; then gmp_compare_ge=yes else if test "$1" -eq $2; then GMP_COMPARE_GE_INTERNAL(m4_shift(m4_shift($@))) fi fi fi]) ]) dnl GMP_PROG_AR dnl ----------- dnl GMP additions to $AR. dnl dnl A cross-"ar" may be necessary when cross-compiling since the build dnl system "ar" might try to interpret the object files to build a symbol dnl table index, hence the use of AC_CHECK_TOOL. dnl dnl A user-selected $AR is always left unchanged. AC_CHECK_TOOL is still dnl run to get the "checking" message printed though. dnl dnl If extra flags are added to AR, then ac_cv_prog_AR and dnl ac_cv_prog_ac_ct_AR are set too, since libtool (cvs 2003-03-31 at dnl least) will do an AC_CHECK_TOOL and that will AR from one of those two dnl cached variables. (ac_cv_prog_AR is used if there's an ac_tool_prefix, dnl or ac_cv_prog_ac_ct_AR is used otherwise.) FIXME: This is highly dnl dependent on autoconf internals, perhaps it'd work to put our extra dnl flags into AR_FLAGS instead. dnl dnl $AR_FLAGS is set to "cq" rather than leaving it to libtool "cru". The dnl latter fails when libtool goes into piecewise mode and is unlucky dnl enough to have two same-named objects in separate pieces, as happens dnl for instance to random.o (and others) on vax-dec-ultrix4.5. Naturally dnl a user-selected $AR_FLAGS is left unchanged. dnl dnl For reference, $ARFLAGS is used by automake (1.8) for its ".a" archive dnl file rules. This doesn't get used by the piecewise linking, so we dnl leave it at the default "cru". dnl dnl FIXME: Libtool 1.5.2 has its own arrangements for "cq", but that version dnl is broken in other ways. When we can upgrade, remove the forcible dnl AR_FLAGS=cq. AC_DEFUN([GMP_PROG_AR], [dnl Want to establish $AR before libtool initialization. AC_BEFORE([$0],[AC_PROG_LIBTOOL]) gmp_user_AR=$AR AC_CHECK_TOOL(AR, ar, ar) if test -z "$gmp_user_AR"; then eval arflags=\"\$ar${abi1}_flags\" test -n "$arflags" || eval arflags=\"\$ar${abi2}_flags\" if test -n "$arflags"; then AC_MSG_CHECKING([for extra ar flags]) AR="$AR $arflags" ac_cv_prog_AR="$AR $arflags" ac_cv_prog_ac_ct_AR="$AR $arflags" AC_MSG_RESULT([$arflags]) fi fi if test -z "$AR_FLAGS"; then AR_FLAGS=cq fi ]) dnl GMP_PROG_M4 dnl ----------- dnl Find a working m4, either in $PATH or likely locations, and setup $M4 dnl and an AC_SUBST accordingly. If $M4 is already set then it's a user dnl choice and is accepted with no checks. GMP_PROG_M4 is like dnl AC_PATH_PROG or AC_CHECK_PROG, but tests each m4 found to see if it's dnl good enough. dnl dnl See mpn/asm-defs.m4 for details on the known bad m4s. AC_DEFUN([GMP_PROG_M4], [AC_ARG_VAR(M4,[m4 macro processor]) AC_CACHE_CHECK([for suitable m4], gmp_cv_prog_m4, [if test -n "$M4"; then gmp_cv_prog_m4="$M4" else cat >conftest.m4 <<\EOF dnl Must protect this against being expanded during autoconf m4! dnl Dont put "dnl"s in this as autoconf will flag an error for unexpanded dnl macros. [define(dollarhash,``$][#'')ifelse(dollarhash(x),1,`define(t1,Y)', ``bad: $][# not supported (SunOS /usr/bin/m4) '')ifelse(eval(89),89,`define(t2,Y)', `bad: eval() doesnt support 8 or 9 in a constant (OpenBSD 2.6 m4) ')ifelse(eval(9,9),10,`define(t3,Y)', `bad: eval() doesnt support radix in eval (FreeBSD 8.x,9.0,9.1,9.2 m4) ')ifelse(t1`'t2`'t3,YYY,`good ')] EOF dnl ' <- balance the quotes for emacs sh-mode echo "trying m4" >&AC_FD_CC gmp_tmp_val=`(m4 conftest.m4) 2>&AC_FD_CC` echo "$gmp_tmp_val" >&AC_FD_CC if test "$gmp_tmp_val" = good; then gmp_cv_prog_m4="m4" else IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" dnl $ac_dummy forces splitting on constant user-supplied paths. dnl POSIX.2 word splitting is done only on the output of word expansions, dnl not every word. This closes a longstanding sh security hole. ac_dummy="$PATH:/usr/5bin" for ac_dir in $ac_dummy; do test -z "$ac_dir" && ac_dir=. echo "trying $ac_dir/m4" >&AC_FD_CC gmp_tmp_val=`($ac_dir/m4 conftest.m4) 2>&AC_FD_CC` echo "$gmp_tmp_val" >&AC_FD_CC if test "$gmp_tmp_val" = good; then gmp_cv_prog_m4="$ac_dir/m4" break fi done IFS="$ac_save_ifs" if test -z "$gmp_cv_prog_m4"; then AC_MSG_ERROR([No usable m4 in \$PATH or /usr/5bin (see config.log for reasons).]) fi fi rm -f conftest.m4 fi]) M4="$gmp_cv_prog_m4" AC_SUBST(M4) ]) dnl GMP_M4_M4WRAP_SPURIOUS dnl ---------------------- dnl Check for spurious output from m4wrap(), as described in mpn/asm-defs.m4. dnl dnl The following systems have been seen with the problem. dnl dnl - Unicos alpha, but its assembler doesn't seem to mind. dnl - MacOS X Darwin, its assembler fails. dnl - NetBSD 1.4.1 m68k, and gas 1.92.3 there gives a warning and ignores dnl the bad last line since it doesn't have a newline. dnl - NetBSD 1.4.2 alpha, but its assembler doesn't seem to mind. dnl - HP-UX ia64. dnl dnl Enhancement: Maybe this could be in GMP_PROG_M4, and attempt to prefer dnl an m4 with a working m4wrap, if it can be found. AC_DEFUN([GMP_M4_M4WRAP_SPURIOUS], [AC_REQUIRE([GMP_PROG_M4]) AC_CACHE_CHECK([if m4wrap produces spurious output], gmp_cv_m4_m4wrap_spurious, [# hide the d-n-l from autoconf's error checking tmp_d_n_l=d""nl cat >conftest.m4 <&AC_FD_CC cat conftest.m4 >&AC_FD_CC tmp_chars=`$M4 conftest.m4 | wc -c` echo produces $tmp_chars chars output >&AC_FD_CC rm -f conftest.m4 if test $tmp_chars = 0; then gmp_cv_m4_m4wrap_spurious=no else gmp_cv_m4_m4wrap_spurious=yes fi ]) GMP_DEFINE_RAW(["define(,<$gmp_cv_m4_m4wrap_spurious>)"]) ]) dnl GMP_PROG_NM dnl ----------- dnl GMP additions to libtool AC_PROG_NM. dnl dnl Note that if AC_PROG_NM can't find a working nm it still leaves dnl $NM set to "nm", so $NM can't be assumed to actually work. dnl dnl A user-selected $NM is always left unchanged. AC_PROG_NM is still run dnl to get the "checking" message printed though. dnl dnl Perhaps it'd be worthwhile checking that nm works, by running it on an dnl actual object file. For instance on sparcv9 solaris old versions of dnl GNU nm don't recognise 64-bit objects. Checking would give a better dnl error message than just a failure in later tests like GMP_ASM_W32 etc. dnl dnl On the other hand it's not really normal autoconf practice to take too dnl much trouble over detecting a broken set of tools. And libtool doesn't dnl do anything at all for say ranlib or strip. So for now we're inclined dnl to just demand that the user provides a coherent environment. AC_DEFUN([GMP_PROG_NM], [dnl Make sure we're the first to call AC_PROG_NM, so our extra flags are dnl used by everyone. AC_BEFORE([$0],[AC_PROG_NM]) gmp_user_NM=$NM AC_PROG_NM # FIXME: When cross compiling (ie. $ac_tool_prefix not empty), libtool # defaults to plain "nm" if a "${ac_tool_prefix}nm" is not found. In this # case run it again to try the native "nm", firstly so that likely locations # are searched, secondly so that -B or -p are added if necessary for BSD # format. This is necessary for instance on OSF with "./configure # --build=alphaev5-dec-osf --host=alphaev6-dec-osf". # if test -z "$gmp_user_NM" && test -n "$ac_tool_prefix" && test "$NM" = nm; then $as_unset lt_cv_path_NM gmp_save_ac_tool_prefix=$ac_tool_prefix ac_tool_prefix= NM= AC_PROG_NM ac_tool_prefix=$gmp_save_ac_tool_prefix fi if test -z "$gmp_user_NM"; then eval nmflags=\"\$nm${abi1}_flags\" test -n "$nmflags" || eval nmflags=\"\$nm${abi2}_flags\" if test -n "$nmflags"; then AC_MSG_CHECKING([for extra nm flags]) NM="$NM $nmflags" AC_MSG_RESULT([$nmflags]) fi fi ]) dnl GMP_PROG_CC_WORKS(cc+cflags,[ACTION-IF-WORKS][,ACTION-IF-NOT-WORKS]) dnl -------------------------------------------------------------------- dnl Check if cc+cflags can compile and link. dnl dnl This test is designed to be run repeatedly with different cc+cflags dnl selections, so the result is not cached. dnl dnl For a native build, meaning $cross_compiling == no, we require that the dnl generated program will run. This is the same as AC_PROG_CC does in dnl _AC_COMPILER_EXEEXT_WORKS, and checking here will ensure we don't pass dnl a CC/CFLAGS combination that it rejects. dnl dnl sparc-*-solaris2.7 can compile ABI=64 but won't run it if the kernel dnl was booted in 32-bit mode. The effect of requiring the compiler output dnl will run is that a plain native "./configure" falls back on ABI=32, but dnl ABI=64 is still available as a cross-compile. dnl dnl The various specific problems we try to detect are done in separate dnl compiles. Although this is probably a bit slower than one test dnl program, it makes it easy to indicate the problem in AC_MSG_RESULT, dnl hence giving the user a clue about why we rejected the compiler. AC_DEFUN([GMP_PROG_CC_WORKS], [AC_MSG_CHECKING([compiler $1]) gmp_prog_cc_works=yes # first see a simple "main()" works, then go on to other checks GMP_PROG_CC_WORKS_PART([$1], []) GMP_PROG_CC_WORKS_PART([$1], [function pointer return], [/* The following provokes an internal error from gcc 2.95.2 -mpowerpc64 (without -maix64), hence detecting an unusable compiler */ void *g() { return (void *) 0; } void *f() { return g(); } ]) GMP_PROG_CC_WORKS_PART([$1], [cmov instruction], [/* The following provokes an invalid instruction syntax from i386 gcc -march=pentiumpro on Solaris 2.8. The native sun assembler requires a non-standard syntax for cmov which gcc (as of 2.95.2 at least) doesn't know. */ int n; int cmov () { return (n >= 0 ? n : 0); } ]) GMP_PROG_CC_WORKS_PART([$1], [double -> ulong conversion], [/* The following provokes a linker invocation problem with gcc 3.0.3 on AIX 4.3 under "-maix64 -mpowerpc64 -mcpu=630". The -mcpu=630 option causes gcc to incorrectly select the 32-bit libgcc.a, not the 64-bit one, and consequently it misses out on the __fixunsdfdi helper (double -> uint64 conversion). */ double d; unsigned long gcc303 () { return (unsigned long) d; } ]) GMP_PROG_CC_WORKS_PART([$1], [double negation], [/* The following provokes an error from hppa gcc 2.95 under -mpa-risc-2-0 if the assembler doesn't know hppa 2.0 instructions. fneg is a 2.0 instruction, and a negation like this comes out using it. */ double fneg_data; unsigned long fneg () { return -fneg_data; } ]) GMP_PROG_CC_WORKS_PART([$1], [double -> float conversion], [/* The following makes gcc 3.3 -march=pentium4 generate an SSE2 xmm insn (cvtsd2ss) which will provoke an error if the assembler doesn't recognise those instructions. Not sure how much of the gmp code will come out wanting sse2, but it's easiest to reject an option we know is bad. */ double ftod_data; float ftod () { return (float) ftod_data; } ]) GMP_PROG_CC_WORKS_PART([$1], [gnupro alpha ev6 char spilling], [/* The following provokes an internal compiler error from gcc version "2.9-gnupro-99r1" under "-O2 -mcpu=ev6", apparently relating to char values being spilled into floating point registers. The problem doesn't show up all the time, but has occurred enough in GMP for us to reject this compiler+flags. */ #include /* for memcpy */ struct try_t { char dst[2]; char size; long d0, d1, d2, d3, d4, d5, d6; char overlap; }; struct try_t param[6]; int param_init () { struct try_t *p; memcpy (p, ¶m[ 2 ], sizeof (*p)); memcpy (p, ¶m[ 2 ], sizeof (*p)); p->size = 2; memcpy (p, ¶m[ 1 ], sizeof (*p)); p->dst[0] = 1; p->overlap = 2; memcpy (p, ¶m[ 3 ], sizeof (*p)); p->dst[0] = 1; p->overlap = 8; memcpy (p, ¶m[ 4 ], sizeof (*p)); memcpy (p, ¶m[ 4 ], sizeof (*p)); p->overlap = 8; memcpy (p, ¶m[ 5 ], sizeof (*p)); memcpy (p, ¶m[ 5 ], sizeof (*p)); memcpy (p, ¶m[ 5 ], sizeof (*p)); return 0; } ]) # __builtin_alloca is not available everywhere, check it exists before # seeing that it works GMP_PROG_CC_WORKS_PART_TEST([$1],[__builtin_alloca availability], [int k; int foo () { __builtin_alloca (k); }], [GMP_PROG_CC_WORKS_PART([$1], [alloca array], [/* The following provokes an internal compiler error from Itanium HP-UX cc under +O2 or higher. We use this sort of code in mpn/generic/mul_fft.c. */ int k; int foo () { int i, **a; a = __builtin_alloca (k); for (i = 0; i <= k; i++) a[i] = __builtin_alloca (1 << i); } ])]) GMP_PROG_CC_WORKS_PART([$1], [abs int -> double conversion], [/* The following provokes an internal error from the assembler on power2-ibm-aix4.3.1.0. gcc -mrios2 compiles to nabs+fcirz, and this results in "Internal error related to the source program domain". For reference it seems to be the combination of nabs+fcirz which is bad, not either alone. This sort of thing occurs in mpz/get_str.c with the way double chars_per_bit_exactly is applied in MPN_SIZEINBASE. Perhaps if that code changes to a scaled-integer style then we won't need this test. */ double fp[1]; int x; int f () { int a; a = (x >= 0 ? x : -x); return a * fp[0]; } ]) GMP_PROG_CC_WORKS_PART([$1], [long long reliability test 1], [/* The following provokes a segfault in the compiler on powerpc-apple-darwin. Extracted from tests/mpn/t-iord_u.c. Causes Apple's gcc 3.3 build 1640 and 1666 to segfault with e.g., -O2 -mpowerpc64. */ #if defined (__GNUC__) && ! defined (__cplusplus) typedef unsigned long long t1;typedef t1*t2; static __inline__ t1 e(t2 rp,t2 up,int n,t1 v0) {t1 c,x,r;int i;if(v0){c=1;for(i=1;i> tnc; high_limb = low_limb << cnt; for (i = n - 1; i != 0; i--) { low_limb = *up++; *rp++ = ~(high_limb | (low_limb >> tnc)); high_limb = low_limb << cnt; } return retval; } int main () { unsigned long cy, rp[2], up[2]; up[0] = ~ 0L; up[1] = 0; cy = lshift_com (rp, up, 2L, 1); if (cy != 1L) return 1; return 0; } #else int main () { return 0; } #endif ]) GMP_PROG_CC_WORKS_PART_MAIN([$1], [mpn_lshift_com optimization 2], [/* The following is mis-compiled by Intel ia-64 icc version 1.8 under "icc -O3", After several calls, the function writes partial garbage to the result vector. Perhaps relates to the chk.a.nc insn. This code needs to be run to show the problem, but that's fine, the offending cc is a native-only compiler so we don't have to worry about cross compiling. */ #if ! defined (__cplusplus) #include void lshift_com (rp, up, n, cnt) unsigned long *rp; unsigned long *up; long n; unsigned cnt; { unsigned long high_limb, low_limb; unsigned tnc; long i; up += n; rp += n; tnc = 8 * sizeof (unsigned long) - cnt; low_limb = *--up; high_limb = low_limb << cnt; for (i = n - 1; i != 0; i--) { low_limb = *--up; *--rp = ~(high_limb | (low_limb >> tnc)); high_limb = low_limb << cnt; } *--rp = ~high_limb; } int main () { unsigned long *r, *r2; unsigned long a[88 + 1]; long i; for (i = 0; i < 88 + 1; i++) a[i] = ~0L; r = malloc (10000 * sizeof (unsigned long)); r2 = r; for (i = 0; i < 528; i += 22) { lshift_com (r2, a, i / (8 * sizeof (unsigned long)) + 1, i % (8 * sizeof (unsigned long))); r2 += 88 + 1; } if (r[2048] != 0 || r[2049] != 0 || r[2050] != 0 || r[2051] != 0 || r[2052] != 0 || r[2053] != 0 || r[2054] != 0) abort (); return 0; } #else int main () { return 0; } #endif ]) # A certain _GLOBAL_OFFSET_TABLE_ problem in past versions of gas, tickled # by recent versions of gcc. # if test "$gmp_prog_cc_works" = yes; then case $host in X86_PATTERN) # this problem only arises in PIC code, so don't need to test when # --disable-shared. We don't necessarily have $enable_shared set to # yes at this point, it will still be unset for the default (which is # yes); hence the use of "!= no". if test "$enable_shared" != no; then GMP_PROG_CC_X86_GOT_EAX_EMITTED([$1], [GMP_ASM_X86_GOT_EAX_OK([$1],, [gmp_prog_cc_works="no, bad gas GOT with eax"])]) fi ;; esac fi AC_MSG_RESULT($gmp_prog_cc_works) case $gmp_prog_cc_works in yes) [$2] ;; *) [$3] ;; esac ]) dnl Called: GMP_PROG_CC_WORKS_PART(CC+CFLAGS,FAIL-MESSAGE [,CODE]) dnl A dummy main() is appended to the CODE given. dnl AC_DEFUN([GMP_PROG_CC_WORKS_PART], [GMP_PROG_CC_WORKS_PART_MAIN([$1],[$2], [$3] [int main () { return 0; }]) ]) dnl Called: GMP_PROG_CC_WORKS_PART_MAIN(CC+CFLAGS,FAIL-MESSAGE,CODE) dnl CODE must include a main(). dnl AC_DEFUN([GMP_PROG_CC_WORKS_PART_MAIN], [GMP_PROG_CC_WORKS_PART_TEST([$1],[$2],[$3], [], gmp_prog_cc_works="no[]m4_if([$2],,,[[, ]])[$2]", gmp_prog_cc_works="no[]m4_if([$2],,,[[, ]])[$2][[, program does not run]]") ]) dnl Called: GMP_PROG_CC_WORKS_PART_TEST(CC+CFLAGS,TITLE,[CODE], dnl [ACTION-GOOD],[ACTION-BAD][ACTION-NORUN]) dnl AC_DEFUN([GMP_PROG_CC_WORKS_PART_TEST], [if test "$gmp_prog_cc_works" = yes; then # remove anything that might look like compiler output to our "||" expression rm -f conftest* a.out b.out a.exe a_out.exe cat >conftest.c <&AC_FD_CC gmp_compile="$1 conftest.c >&AC_FD_CC" if AC_TRY_EVAL(gmp_compile); then cc_works_part=yes if test "$cross_compiling" = no; then if AC_TRY_COMMAND([./a.out || ./b.out || ./a.exe || ./a_out.exe || ./conftest]); then :; else cc_works_part=norun fi fi else cc_works_part=no fi if test "$cc_works_part" != yes; then echo "failed program was:" >&AC_FD_CC cat conftest.c >&AC_FD_CC fi rm -f conftest* a.out b.out a.exe a_out.exe case $cc_works_part in yes) $4 ;; no) $5 ;; norun) $6 ;; esac fi ]) dnl GMP_PROG_CC_WORKS_LONGLONG(cc+cflags,[ACTION-YES][,ACTION-NO]) dnl -------------------------------------------------------------- dnl Check that cc+cflags accepts "long long". dnl dnl This test is designed to be run repeatedly with different cc+cflags dnl selections, so the result is not cached. AC_DEFUN([GMP_PROG_CC_WORKS_LONGLONG], [AC_MSG_CHECKING([compiler $1 has long long]) cat >conftest.c <&AC_FD_CC cat conftest.c >&AC_FD_CC fi rm -f conftest* a.out b.out a.exe a_out.exe AC_MSG_RESULT($gmp_prog_cc_works) if test $gmp_prog_cc_works = yes; then ifelse([$2],,:,[$2]) else ifelse([$3],,:,[$3]) fi ]) dnl GMP_C_TEST_SIZEOF(cc/cflags,test,[ACTION-GOOD][,ACTION-BAD]) dnl ------------------------------------------------------------ dnl The given cc/cflags compiler is run to check the size of a type dnl specified by the "test" argument. "test" can either be a string, or a dnl variable like $foo. The value should be for instance "sizeof-long-4", dnl to test that sizeof(long)==4. dnl dnl This test is designed to be run for different compiler and/or flags dnl combinations, so the result is not cached. dnl dnl The idea for making an array that has a negative size if the desired dnl condition test is false comes from autoconf AC_CHECK_SIZEOF. The cast dnl to "long" in the array dimension also follows autoconf, apparently it's dnl a workaround for a HP compiler bug. AC_DEFUN([GMP_C_TEST_SIZEOF], [echo "configure: testlist $2" >&AC_FD_CC [gmp_sizeof_type=`echo "$2" | sed 's/sizeof-\([a-z]*\).*/\1/'`] [gmp_sizeof_want=`echo "$2" | sed 's/sizeof-[a-z]*-\([0-9]*\).*/\1/'`] AC_MSG_CHECKING([compiler $1 has sizeof($gmp_sizeof_type)==$gmp_sizeof_want]) cat >conftest.c <conftest.c <