diff options
author | cvs2svn <admin@example.com> | 2002-08-04 00:18:34 +0000 |
---|---|---|
committer | cvs2svn <admin@example.com> | 2002-08-04 00:18:34 +0000 |
commit | 2f4c89c4f475d3b2c718cbd4332c650214488ff9 (patch) | |
tree | 5abd57b1ace53b0c6970da9395f15d80d5f79430 /test-suite | |
parent | c7743d027a335eae585335b959e483c5a6c38d36 (diff) | |
download | guile-after-hanwen-gc-change.tar.gz |
This commit was manufactured by cvs2svn to create tagafter-hanwen-gc-change
'after-hanwen-gc-change'.
Diffstat (limited to 'test-suite')
57 files changed, 0 insertions, 12684 deletions
diff --git a/test-suite/.cvsignore b/test-suite/.cvsignore deleted file mode 100644 index 8ba23a55b..000000000 --- a/test-suite/.cvsignore +++ /dev/null @@ -1,6 +0,0 @@ -guile.log -tmp1 -tmp2 -tmp3 -Makefile -Makefile.in diff --git a/test-suite/COPYING b/test-suite/COPYING deleted file mode 100644 index eeb586b39..000000000 --- a/test-suite/COPYING +++ /dev/null @@ -1,340 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991 Free Software Foundation, Inc. - 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - <one line to give the program's name and a brief idea of what it does.> - Copyright (C) 19yy <name of author> - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) 19yy name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - <signature of Ty Coon>, 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog deleted file mode 100644 index da61a418f..000000000 --- a/test-suite/ChangeLog +++ /dev/null @@ -1,815 +0,0 @@ -2002-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/goops.test: Added tests for define-generic and - define-accessor. - -2002-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/goops.test: Added tests for define-class. - -2002-05-07 Marius Vollmer <mvo@zagadka.ping.de> - - * tests/numbers.test (/): Expect divison by an inexact zero to - yield +inf.0. - -2002-05-06 Marius Vollmer <mvo@zagadka.ping.de> - - * tests/regexp.test (regexp-substitute/global): Do not test with - empty regexp. Empty regexps do not work on NetBSD. - - * tests/syncase.test (basic syncase macro): Added. - -2002-04-26 Marius Vollmer <mvo@zagadka.ping.de> - - * tests/srfi-13.test (string-tokenize): Updated for fixed - semantics. - -2002-04-16 Marius Vollmer <mvo@zagadka.ping.de> - - * Makefile.am (SCM_TESTS_DIRS, dist-hook): New, distribute - directories manually. - -2002-02-09 Thien-Thi Nguyen <ttn@giblet.glug.org> - - * guile-test (main): Handle `--flag-unresolved'. No longer set - exit value to #f unconditionally on UNRESOLVED results. - (for-each-file): Do not recurse into "CVS" or "RCS" subdirs. - -2002-02-08 Neil Jerram <neil@ossau.uklinux.net> - - * tests/elisp.test: Add tests of Elisp expression evaluation. - -2002-01-25 Neil Jerram <neil@ossau.uklinux.net> - - * tests/load.test: New test; for search-path with Elisp - nil-terminated lists for PATH and EXTENSIONS. - - * tests/elisp.test: More tests for Scheme primitives that should - accept Elisp nil-terminated lists. - -2002-01-24 Neil Jerram <neil@ossau.uklinux.net> - - * tests/elisp.test: More new tests for the Elisp nil value. - -2002-01-22 Neil Jerram <neil@ossau.uklinux.net> - - * Makefile.am (SCM_TESTS): Added elisp.test. - - * tests/elisp.test: New file. - -2001-11-22 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/numbers.test: Added more division by zero tests. - -2001-11-22 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/numbers.test: Added division by zero tests. - -2001-11-17 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/syntax.test: Added some tests, updated some others with - respect to recent changes in eval.c. Further, extracted test - cases for guile's extended set! functionality to srfi-17.test. - - * tests/srfi-17.test: New file. - -2001-11-04 Stefan Jahn <stefan@lkcc.org> - - * tests/ports.test: Run (close-port) before (delete-file) if - necessary/advisory. - -2001-10-26 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/eval.test: Added tests for promises. - -2001-10-21 Mikael Djurfeldt <mdj@linnaeus> - - * lib.scm: Move module the system directives `export', - `export-syntax', `re-export' and `re-export-syntax' into the - `define-module' form. This is the recommended way of exporting - bindings. - -2001-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/syntax.test: Added test cases for 'cond =>' syntax with - else clause. Changed some tests and comments related to the - 'case' form to reflect recent changes in the implementation. - -2001-10-14 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/syntax.test: Added test cases for 'lambda' syntax. - -2001-10-13 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/syntax.test: Added test cases for 'case' syntax. - -2001-10-13 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/numbers.test: Added a test case that checks if valid - number strings are transformed correctly by string->number. - -2001-09-21 Rob Browning <rlb@defaultvalue.org> - - * tests/numbers.test (fixnum-bit): compute dynamically. - - * tests/bit-operations.test (fixnum-bit): compute dynamically. - -2001-09-07 Thien-Thi Nguyen <ttn@revel.glug.org> - - * tests/getopt-long.test ("apples-blimps-catalexis example", - "multiple occurances"): New top-level sections. - -2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/numbers.test: Made some of the patterns better readable. - -2001-08-25 Thien-Thi Nguyen <ttn@revel.glug.org> - - * tests/srfi-19.test (test-time-comparision, - test-time-arithmatic): New procs. - - Add time comparison tests using new procs. - Thanks to Alex Shinn. - -2001-08-25 Marius Vollmer <mvo@zagadka.ping.de> - - * tests/dynamic-scope.test: New file. - -2001-08-24 Thien-Thi Nguyen <ttn@revel.glug.org> - - * tests/srfi-13.test (string-for-each, string-for-each-index): - Add tests. (Thanks to Alex Shinn.) - -2001-08-22 Mikael Djurfeldt <mdj@linnaeus.mit.edu> - - * tests/srfi-13.test (string-map): Swapped order of string and - proc args to conform with the srfi. (Thanks to Alex Shinn.) - -2001-08-12 Thien-Thi Nguyen <ttn@revel.glug.org> - - * tests/getopt-long.test (exception:no-such-option, - exception:option-does-not-support-arg, - exception:option-must-be-specified, - exception:option-must-have-arg, exception:not-enough-args): - New vars. - - ("option-ref", "required", "specified no value, given anyway", - "specified arg required"): New top-level sections. - -2001-08-11 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/numbers.test: Added Some syntax tests for - string->number. - -2001-08-09 Marius Vollmer <marius.vollmer@uni-dortmund.de> - - * Makefile.am (TESTS): Do not call the variable "TESTS", call it - "SCM_TESTS". This has special meaning to automake. How many - tries left to get this right, mvo? - -2001-08-08 Marius Vollmer <marius.vollmer@uni-dortmund.de> - - * Makefile.am (TESTS): List tests explicitely instead of using a - wildcard. Wildcards don't seem to work for VPATH "make dist"s. - -2001-08-07 Marius Vollmer <mvo@zagadka.ping.de> - - * Makefile.am: New file, to control distribution of the - test-suite. - -2001-08-02 Thien-Thi Nguyen <ttn@revel.glug.org> - - * tests/getopt-long.test: New file. - -2001-08-01 Thien-Thi Nguyen <ttn@revel.glug.org> - - * lib.scm (run-test-exception): Add special handling for - `error'-generated exceptions, which pass key `misc-error' and - leave messages unformatted. - -2001-07-18 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> - - * tests/alist.test, tests/bit-operations.test, - tests/common-list.test, tests/environments.test, tests/eval.test, - tests/gc.test, tests/hooks.test, tests/import.test, - tests/interp.test, tests/list.test, tests/load.test, - tests/numbers.test, tests/ports.test, tests/r4rs.test, - tests/version.test, tests/weaks.test, lib.scm, guile-test: Updated - copyright notice. - -2001-07-16 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> - - * tests/srfi-14.test: New file. - -2001-07-13 Marius Vollmer <mvo@zagadka.ping.de> - - * tests/import.test: New file. - -2001-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/goops.test: Started with some real tests. - -2001-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * guile-test: Use module (ice-9 rdelim). - -2001-06-27 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> - - * tests/srfi-4.test: New file. - -2001-06-16 Marius Vollmer <mvo@zagadka.ping.de> - - Thanks to Matthias Köppe! - - * tests/ports.test: New test for output port line counts. - * tests/format.test, tests/optargs.test, tests/srfi-19.test: New - files. - -2001-05-28 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> - - * tests/symbols.test ("gensym"): New tests for long gensym - prefices and embedded NULs in prefices. - -2001-05-21 Marius Vollmer <mvo@zagadka.ping.de> - - * test/goops.test, test/syncase.test: New, minimal tests. - -2001-05-19 Marius Vollmer <mvo@zagadka.ping.de> - - * tests/version.test: Updated test for new micro version stuff. - -2001-05-16 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> - - * tests/srfi-13.test: More tests. - -2001-05-10 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> - - * tests/srfi-10.test: New file. - - * tests/srfi-9.test: New file. - - * tests/srfi-13.test: Added some more tests. - -2001-05-09 Thien-Thi Nguyen <ttn@revel.glug.org> - - * tests/eval.test: ("evaluator" "memoization"): New test - prefix block. - ("transparency"): New "evaluator memoization" test. - -2001-05-08 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> - - * tests/srfi-13.test: Added module access kludge, and uncommented - some tests depending on this. - -2001-05-07 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> - - * tests/srfi-13.test: New file testing the SRFI string library. - -2001-04-26 Gary Houston <ghouston@arglist.com> - - * tests/r4rs.test: delete files tmp1, tmp2, tmp3 after the tests - have run. - - * tests/ports.test (test-file), tests/load.test (temp-dir): - redefined using data-file-name instead of tmpnam. the test files - will be created in the build directory instead of /var/tmp or - whereever tmpnam puts them. - -2001-04-02 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/symbols.c: Added some tests. - -2001-03-19 Gary Houston <ghouston@arglist.com> - - * tests/r4rs.test: use test-file-name to locate r4rs.test, - not data-file-name. - - * guile-test: define tmp-dir, the location where r4rs.test will - create it's temporary files. - (data-file-name): use tmp-dir. this must be under build-dir, - not src-dir. - -2001-03-18 Gary Houston <ghouston@arglist.com> - - * guile-test: use #!/bogus-path/..., not #!/home/dirk/... in the - first line. - -2001-03-12 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/syntax.test: Added a test for let* bindings and - re-arranged and slightly improved the existing one. - -2001-03-09 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> - - * tests/syntax.test ("let*"): Changed the `duplicate bindings' - test, dups are allowed in `let*' and are now expected to pass. - -2001-03-05 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * lib.scm (run-test-exception): Preserve the original error's - stack for re-throwing. - -2001-03-04 Marius Vollmer <mvo@zagadka.ping.de> - - * tests/syntax.test ("let,duplicate bindings", "let*,duplicate - bindings", "letrec,duplicate bindings"): Expect to pass, bug has - been fixed. - -2001-03-03 Marius Vollmer <mvo@zagadka.ping.de> - - * tests/syntax.test ("duplicate formals"): New category, move - appropriate tests here. Expect them to pass. - ("empty parentheses"): Expect to pass, bug has been fixed. - - * tests/alist.test: Use "'()" instead of "()" in all places - where the empty list is meant. - -2001-03-01 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * lib.scm (exception:unbound-var, exception:wrong-num-args): New - exported constants. - - * tests/r4rs.test: Make sure that no bindings for x and y exist - after the file is loaded. - - * tests/syntax.test: New file. - - * tests/exceptions.test, tests/syntax.test, tests/eval.test: - Moved the test cases that are related to guile's syntactic forms - from tests/exceptions.test to tests/syntax.test. Moved tests - related to evaluation and application to tests/eval.test. - - * tests/exceptions.test: Added some test cases that check guile's - exception handling. - -2001-03-01 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/exceptions.test, tests/numbers.test: Moved the number - related test cases from tests/exceptions.test to - tests/numbers.test. - - * tests/numbers.test: Added a test case. - -2001-03-01 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/symbols.test: New file. - - (exception:immutable-string): New constant. Currently, this is a - dummy since guile does not have immutable strings. - - * tests/exceptions.test, tests/strings.test, tests/symbols.test: - Moved the string related test cases from tests/exceptions.test to - tests/strings.test and the symbol related test cases to - tests/symbols.test. - - * tests/strings.test: Copyright notice updated. Added a couple - of test cases. - - (exception:immutable-string): New constant. Currently, this is a - dummy since guile does not have immutable strings. - -2001-02-28 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/exceptions.test: Use expect-fail-exception to indicate - test cases where exceptions should occur, but don't. - - (exception:bad-bindings, exception:bad-formals, exception:bad-var, - exception:missing/extra-expr): New constants. - -2001-02-28 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/reader.test, tests/exceptions.test: Moved the reader - related test cases from tests/exceptions.test to - tests/reader.test. - - * tests/reader.test (exception:eof, exception:unexpected-rparen): - New constants. - - * tests/exceptions.test (read-string, x:eof, x:unexpected-rparen): - Removed. - -2001-02-28 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * lib.scm (signals-error?, signals-error?*): Removed. - -2001-02-28 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * lib.scm: Added comment about new convenience functions/macros - to test for exceptions. - - (exception:out-of-range, exception:wrong-type-arg): New exported - constants. - - (run-test-exception): New function. - - (pass-if-exception, expect-fail-exception): New exported macros. - - * tests/environments.test: Fixed tests that were checking for - exceptions when set!ing an unbound symbol. - - (exception:unbound-symbol): New constant. - - * tests/hooks.test (catch-error-returning-true, pass-if-not, - catch-error-returning-false), tests/weaks.test - (catch-error-returning-true, pass-if-not, - catch-error-returning-false): Removed. The macro pass-if-not was - not used. The macro catch-error-returning-false is unnecessary - since exceptions are caught by the test-suite anyway. The - functionality of catch-error-returning-true is provided by the new - convenience macro pass-if-exception. - - * tests/hooks.test (exception:wrong-num-hook-args): New constant. - Maybe a standard wrong-num-arg exception should be thrown instead - of a misc-error? - - * tests/reader.test (try-to-read): Replaced by read-string. - - (read-string): New function. - - * tests/alist.test, tests/environments.test, tests/eval.test, - tests/hooks.test, tests/list.test, tests/ports.test, - tests/reader.test, tests/strings.test, tests/weaks.test: Replace - tests for exceptions with the new convenience macros. - -2001-02-28 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/alist.test: Remove redundant test name prefix. - -2001-02-28 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * lib.scm (pass-if): Tests shall return a boolean value. - - * tests/bit-operations.test (documented?), tests/common-list.test - (documented?), tests/environments.test (documented?), - tests/eval.test (documented?), tests/gc.test (documented?), - tests/numbers.test (documented?), tests/guardians.test, - tests/hooks.test, tests/interp.test, tests/weaks.test: Make sure - that tests return a boolean value. - - * tests/list.test (documented?): New function, replace all checks - for documentation with calls to this function. - -2001-02-27 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * lib.scm (data-file): Remove from export list. - -2001-02-22 Thien-Thi Nguyen <ttn@revel.glug.org> - - * tests/exceptions.test (syntax lambda): Renamed from (lambda). - (syntax lambda cond-arrow-proc): Renamed from (lambda cond-arrow-proc). - (syntax reading): New section. - (syntax let*): New section. - (syntax letrec): New section. - (syntax set!): New section. - (syntax misc): New section. - (bindings unbound): New section. - (bindings immutable-modification): New section. - (bindings let): New section. - (bindings let*): New section. - (bindings letrec): New section. - - * tests/exceptions.test: New file. - -2001-02-08 Marius Vollmer <marius.vollmer@uni-dortmund.de> - - * guile-test: Use (ice-9 and-let-star) instead of (ice-9 - and-let*). - -2001-01-26 Dirk Herrmann <D.Herrmann@tu-bs.de> - - This patch fixes things that I have broken with the last one :-( - - * guile-test (test-suite): New variable. - - (data-file-name): New function. Has the same purpose as the - former function data-file from lib.scm. Moved here in order to - have all file name handling at the same place. In contrast to the - former 'data-file function, it is not checked whether a file - exists. This allows to use this function also for file names of - files that are still to be created. - - (test-file-name): Use the global 'test-suite variable. - - (main): Initialize 'test-suite instead of a local variable. - - * lib.scm: Don't import paths any more. - - (data-file): Removed. Resurrected with a sligtly different - functionality as 'data-file-name' in guile-test. - - * r4rs.scm: For all references to temporary file, make use of - data-file-name. - -2001-01-26 Dirk Herrmann <D.Herrmann@tu-bs.de> - - The following patch was sent by Thien-Thi Nguyen and a little bit - modified by me. - - * guile-test: Usage and installation comments improved. Added - support for --test-suite and --debug command line options. - - (default-test-suite): Added to allow for simplified - configurability. No need to load the paths file any more. - - (enable-debug-mode): New function. Will be called when the - --debug command line option is given. - - (test-root): Removed. The test directory has to be fully given. - This allows for arbitrarily named test directories. - - (test-file-name, enumerate-tets): Take the test directory as a - paramter instead of using the global variable 'test-root'. - - (main): Handle the new command line options. Return an exit code - depending on whether all tests came out as expected. - - * README: Updated. - - * paths.scm: Removed. - -2001-01-24 Gary Houston <ghouston@arglist.com> - - * tests/ports.test: include (ice-9 rdelim) module. - -2001-01-18 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/numbers.test: Converted to do real boundary testing. - -2001-01-17 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/bit-operations.test: Added. - -2000-11-03 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/gc.test: Added. - -2000-10-30 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/strings.test: string=? is fixed. - -2000-10-13 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/list.test: Removed references to sloppy-mem(q|v|ber) - -2000-09-26 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/strings.test: Added a test to help remember that string=? - and friends need fixing. - -2000-09-12 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/environments.test: For tests that rely on garbage - collection, conservative scanning can be a problem. Add a comment - for these tests and make them turn out unresolved if things don't - work as expected. - -2000-09-05 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/environments.test: Finished and cleaned up the tests for - the leaf environments. Added a complete set of testcases for the - leaf environment based eval environments. Started with the tests - for the import environments. - -2000-08-25 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/environments.test: Added. - -2000-08-21 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * lib.scm (pass-if, expect-fail): Generalized to allow a sequence - of expressions. - - * tests/eval.test: Fix documentation test. - -2000-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/list.test: Added tests for list-ref, list-set! and - list-cdr-set! - -2000-06-21 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/common-list.test: Added. - -2000-06-21 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/eval.test: Added. - -2000-06-16 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/list.test: Use cons* instead of list*. - -2000-06-13 Mikael Djurfeldt <mdj@thalamus.nada.kth.se> - - * tests/numbers.test, tests/list.test: Updated for new - documentation module. - -2000-05-26 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/hooks.test: make-hook-with-name is deprecated. - -2000-05-08 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * tests/list.test, tests/numbers.test: Added. - -2000-05-08 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * guile-test: Eliminate use of catch-test-errors. - - * lib.scm: Adopted a couple of nice ideas from Greg. - - (pass, fail, expect-failure, expect-failure-if, - expect-failure-if*, catch-test-errors, catch-test-errors*, - expected-failure-fluid, pessimist?): Removed. - - (run-test, expect-fail, result-tags, important-result-tags): - Added. - - (report, make-count-reporter, print-counts, make-log-reporter, - full-reporter, user-reporter): Reporters take two mandatory - arguments and make use of the tag descriptions in result-tags and - important-result-tags. - - * tests/alist.test, tests/hooks.test, tests/ports.test, - tests/weaks.test: Don't use catch-test-errors and - expect-failure-if. - -2000-05-05 Dirk Herrmann <D.Herrmann@tu-bs.de> - - * mambo.test: Removed dummy file. - -2000-03-31 Gary Houston <ghouston@arglist.com> - - * tests/ports.test (non-blocking-I/O): a couple more details: - a) combine the O_NONBLOCK flag with the default flags instead - of replacing them. b) check EWOULDBLOCK as well as EAGAIN. - -2000-03-22 Jim Blandy <jimb@savonarola.red-bean.com> - - * lib.scm: Doc fixes. - -Sun Jan 16 14:01:51 2000 Greg J. Badros <gjb@cs.washington.edu> - - * paths.scm: Assume that ~/guile-core/test-suite is the location - of the test suite now. - - * tests/version.test: Added -- version.c had 0% coverage before, - now at 100%. - - * tests/chars.test: Added -- needed test of char-is-both?. - -1999-12-22 Greg Harvey <Greg.Harvey@thezone.net> - - * tests/weaks.test, tests/hooks.test: Added. - -1999-12-18 Greg Harvey <Greg.Harvey@thezone.net> - - * tests/alist.test: Added. - -Fri Dec 17 12:14:10 1999 Greg J. Badros <gjb@cs.washington.edu> - - * tests/c-api.test: Refine the list of files that are checked in - the seek-offset-test. Was just using files that end in "c", but - that caught the new ".doc" files, too, so make sure that files end - in ".c" before requiring that they include unistd.h if they - reference SEEK_(SET|CUR|END). - -1999-10-24 Gary Houston <ghouston@freewire.co.uk> - - * tests/ports.test ("string ports"): test seeking/unreading from - an input string and seeking an output string. - -1999-10-20 Gary Houston <ghouston@freewire.co.uk> - - * tests/ports.test: in seek/tell test on input port, also test - that ftell doesn't discard unread chars. - -1999-10-18 Gary Houston <ghouston@freewire.co.uk> - - * tests/ports.test: add seek/tell tests for unidirectional ports. - -1999-09-25 Jim Blandy <jimb@savonarola.red-bean.com> - - * tests/reader.test: Check that number->string checks its radix - properly. - -1999-09-20 Jim Blandy <jimb@savonarola.red-bean.com> - - * tests/ports.test: Check that our input functions cope when - current-input-port is closed. - - * tests/regexp.test: Check regexp-substitute/global when there are - no matches. (Duh.) - -1999-09-15 Mikael Djurfeldt <mdj@thalamus.nada.kth.se> - - * tests/c-api.test: New file. Add test to check that all source - files which use SEEK_SET, SEEK_CUR, and SEEK_END include unistd.h. - -1999-09-14 Gary Houston <ghouston@freewire.co.uk> - - * tests/ports.test: test non-blocking I/O. - -1999-09-11 Jim Blandy <jimb@savonarola.red-bean.com> - - * tests/strings.test: Add test for substring-move! argument checking. - - * lib.scm (signals-error?, signals-error?*): New macro and function. - * tests/reader.test: Use them. - - * tests/interp.test: Add copyright notice. - - * tests/reader.test: New test file. - - * tests/regexp.test: New test file. - -1999-09-06 Mikael Djurfeldt <mdj@thalamus.nada.kth.se> - - * tests/interp.test: Added tests for evaluation of closure bodies. - -1999-09-03 James Blandy <jimb@mule.m17n.org> - - * tests/multilingual.nottest: New file, which we will turn into a - test file once we actually have multilingual support to test. - - * tests/load.test: New test file. - -1999-08-30 James Blandy <jimb@mule.m17n.org> - - * tests/strings.test: New test file. - -1999-08-29 Gary Houston <ghouston@easynet.co.uk> - - * tests/ports.test: test unread-char and unread-string. - -1999-08-19 Gary Houston <ghouston@easynet.co.uk> - - * tests/ports.test: test line-buffering of fports. - -1999-08-18 Gary Houston <ghouston@easynet.co.uk> - - * tests/ports.test: tests for NUL and non-ASCII chars to fports. - -1999-08-12 Gary Houston <ghouston@easynet.co.uk> - - * tests/ports.test: lseek -> seek. - -1999-08-04 Gary Houston <ghouston@easynet.co.uk> - - * tests/ports.test: tests for buffered and unbuffered input/output - fports with seeking. - -1999-08-01 Jim Blandy <jimb@savonarola.red-bean.com> - - * tests/r4rs.test (SECTION 3 4): Each element of type-matrix - corresponds to an example object, not a predicate. Aubrey - probably never noticed this because SCM doesn't check the lengths - of the arguments to for-each and map... - - * tests/ports.test: Add some regression tests for char-ready?. - -1999-07-19 Jim Blandy <jimb@savonarola.red-bean.com> - - * tests/ports.test: Fix copyright years. - - * tests/guardians.test: New test file. - - * tests/ports.test ("read-delimited!"): New tests. - -1999-06-19 Jim Blandy <jimb@savonarola.red-bean.com> - - * tests/interp.test: New file. - -1999-06-15 Jim Blandy <jimb@savonarola.red-bean.com> - - * tests/time.test: New test file. - - * tests/r4rs.test: New set of tests, taken from Guile's test - script, taken from SCM. - - * tests/ports.test: Group the string port tests under a new - test name prefix. - - * tests/ports.test ("line counter"): Check the final column, too. - - * lib.scm: Import (test-suite paths). - (data-file): New exported function. - -1999-06-12 Jim Blandy <jimb@savonarola.red-bean.com> - - * tests/ports.test ("line counter"): Add test for correct column - at EOF. - -1999-06-09 Jim Blandy <jimb@savonarola.red-bean.com> - - * tests/ports.test ("line counter"): Verify that we do eventually - get EOF on the port --- don't just read forever. - - * lib.scm (full-reporter): The test name is the cadr of the - result, not the cdr. I'm not macho enough to handle run-time - typechecking. - - * lib.scm (print-counts): XFAILS are "expected failures", not - "unexpected failures." - - * lib.scm, guile-test, paths.scm: Log begins. - diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am deleted file mode 100644 index 727601ecd..000000000 --- a/test-suite/Makefile.am +++ /dev/null @@ -1,52 +0,0 @@ -SCM_TESTS = tests/alist.test \ - tests/bit-operations.test \ - tests/c-api.test \ - tests/chars.test \ - tests/common-list.test \ - tests/elisp.test \ - tests/environments.test \ - tests/eval.test \ - tests/exceptions.test \ - tests/format.test \ - tests/gc.test \ - tests/getopt-long.test \ - tests/goops.test \ - tests/guardians.test \ - tests/hooks.test \ - tests/import.test \ - tests/interp.test \ - tests/list.test \ - tests/load.test \ - tests/multilingual.nottest \ - tests/numbers.test \ - tests/optargs.test \ - tests/ports.test \ - tests/r4rs.test \ - tests/reader.test \ - tests/regexp.test \ - tests/srfi-10.test \ - tests/srfi-13.test \ - tests/srfi-14.test \ - tests/srfi-19.test \ - tests/srfi-4.test \ - tests/srfi-9.test \ - tests/strings.test \ - tests/symbols.test \ - tests/syncase.test \ - tests/syntax.test \ - tests/time.test \ - tests/version.test \ - tests/weaks.test - -SCM_TESTS_DIRS = tests/asmobs \ - tests/c-api - -EXTRA_DIST = guile-test lib.scm $(SCM_TESTS) - -## Automake should be able to handle the distribution of tests/asmobs -## etc without any help, but not all version can handle 'deep' -## directories. So we do it on our own. -dist-hook: - for d in $(SCM_TESTS_DIRS); do \ - cp -pR $(srcdir)/$$d $(distdir)/$$d; \ - done diff --git a/test-suite/README b/test-suite/README deleted file mode 100644 index 116869e17..000000000 --- a/test-suite/README +++ /dev/null @@ -1,47 +0,0 @@ -This directory contains some tests for Guile, and some generic test -support code. - -To run these tests, you will need a version of Guile more recent than -15 Feb 1999 --- the tests use the (ice-9 and-let*) and (ice-9 -getopt-long) modules, which were added to Guile around then. - -For information about how to run the test suite, read the usage -instructions in the comments at the top of the guile-test script. - -You can reference the file `lib.scm' from your own code as the module -(test-suite lib); it also has comments at the top and before each -function explaining what's going on. - -Please write more Guile tests, and send them to bug-guile@gnu.org. -We'll merge them into the distribution. All test suites must be -licensed for our use under the GPL, but I don't think I'm going to -collect assignment papers for them. - - - -Some test suite philosophy: - -GDB has an extensive test suite --- around 6300 tests. Every time the -test suite catches a bug, it's great. - -GDB is so complicated that folks are often unable to get a solid -understanding of the code before making a change --- we just don't -have time. You'll see people say things like, "Here's a fix for X; it -doesn't cause any regressions." The subtext is, I made a change that -looks reasonable, and the test suite didn't complain, so it must be -okay. - -I think this is terrible, because it suggests that the writer is using -the test suite as a substitute for having a rock-solid explanation of -why their changes are correct. The problem is that any test suite is -woefully incomplete. Diligent reasoning about code can catch corner -conditions or limitations that no test suite will ever find. - - - -Jim's rule for test suites: - -Every test suite failure should be a complete, mysterious surprise, -never a possibility you were prepared for. Any other attitude -indicates that you're using the test suite as a crutch, which you need -only because your understanding is weak. diff --git a/test-suite/guile-test b/test-suite/guile-test deleted file mode 100755 index 1d16368d8..000000000 --- a/test-suite/guile-test +++ /dev/null @@ -1,235 +0,0 @@ -#!../libguile/guile \ --e main -s -!# - -;;;; guile-test --- run the Guile test suite -;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 -;;;; -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - - -;;;; Usage: [guile -e main -s] guile-test [OPTIONS] [TEST ...] -;;;; -;;;; Run tests from the Guile test suite. Report failures and -;;;; unexpected passes to the standard output, along with a summary of -;;;; all the results. Record each reported test outcome in the log -;;;; file, `guile.log'. The exit status is #f if any of the tests -;;;; fail or pass unexpectedly. -;;;; -;;;; Normally, guile-test scans the test directory, and executes all -;;;; files whose names end in `.test'. (It assumes they contain -;;;; Scheme code.) However, you can have it execute specific tests by -;;;; listing their filenames on the command line. -;;;; -;;;; The option `--test-suite' can be given to specify the test -;;;; directory. If no such option is given, the test directory is -;;;; taken from the environment variable TEST_SUITE_DIR (if defined), -;;;; otherwise a default directory that is hardcoded in this file is -;;;; used (see "Installation" below). -;;;; -;;;; If present, the `--log-file LOG' option tells `guile-test' to put -;;;; the log output in a file named LOG. -;;;; -;;;; If present, the `--debug' option will enable a debugging mode. -;;;; -;;;; If present, the `--flag-unresolved' option will cause guile-test -;;;; to exit with failure status if any tests are UNRESOLVED. -;;;; -;;;; -;;;; Installation: -;;;; -;;;; If you change the #! line at the top of this script to point at -;;;; the Guile interpreter you want to test, you can call this script -;;;; as an executable instead of having to pass it as a parameter to -;;;; guile via "guile -e main -s guile-test". Further, you can edit -;;;; the definition of default-test-suite to point to the parent -;;;; directory of the `tests' tree, which makes it unnecessary to set -;;;; the environment variable `TEST_SUITE_DIR'. -;;;; -;;;; -;;;; Shortcomings: -;;;; -;;;; At the moment, due to a simple-minded implementation, test files -;;;; must live in the test directory, and you must specify their names -;;;; relative to the top of the test directory. If you want to send -;;;; me a patch that fixes this, but still leaves sane test names in -;;;; the log file, that would be great. At the moment, all the tests -;;;; I care about are in the test directory, though. -;;;; -;;;; It would be nice if you could specify the Guile interpreter you -;;;; want to test on the command line. As it stands, if you want to -;;;; change which Guile interpreter you're testing, you need to edit -;;;; the #! line at the top of this file, which is stupid. - - -;;; User configurable settings: -(define default-test-suite - (string-append (getenv "HOME") "/bogus-path/test-suite")) - - -(use-modules (test-suite lib) - (ice-9 getopt-long) - (ice-9 and-let-star) - (ice-9 rdelim)) - - -;;; Variables that will receive their actual values later. -(define test-suite default-test-suite) - -(define tmp-dir #f) - - -;;; General utilities, that probably should be in a library somewhere. - -;;; Enable debugging -(define (enable-debug-mode) - (write-line %load-path) - (set! %load-verbosely #t) - (debug-enable 'backtrace 'debug)) - -;;; Traverse the directory tree at ROOT, applying F to the name of -;;; each file in the tree, including ROOT itself. For a subdirectory -;;; SUB, if (F SUB) is true, we recurse into SUB. Do not follow -;;; symlinks. -(define (for-each-file f root) - - ;; A "hard directory" is a path that denotes a directory and is not a - ;; symlink. - (define (file-is-hard-directory? filename) - (eq? (stat:type (lstat filename)) 'directory)) - - (let visit ((root root)) - (let ((should-recur (f root))) - (if (and should-recur (file-is-hard-directory? root)) - (let ((dir (opendir root))) - (let loop () - (let ((entry (readdir dir))) - (cond - ((eof-object? entry) #f) - ((or (string=? entry ".") - (string=? entry "..") - (string=? entry "CVS") - (string=? entry "RCS")) - (loop)) - (else - (visit (string-append root "/" entry)) - (loop)))))))))) - - -;;; The test driver. - - -;;; Localizing test files and temporary data files. - -(define (data-file-name filename) - (in-vicinity tmp-dir filename)) - -(define (test-file-name test) - (in-vicinity test-suite test)) - -;;; Return a list of all the test files in the test tree. -(define (enumerate-tests test-dir) - (let ((root-len (+ 1 (string-length test-dir))) - (tests '())) - (for-each-file (lambda (file) - (if (has-suffix? file ".test") - (let ((short-name - (substring file root-len))) - (set! tests (cons short-name tests)))) - #t) - test-dir) - - ;; for-each-file presents the files in whatever order it finds - ;; them in the directory. We sort them here, so they'll always - ;; appear in the same order. This makes it easier to compare test - ;; log files mechanically. - (sort tests string<?))) - -(define (main args) - (let ((options (getopt-long args - `((test-suite - (single-char #\t) - (value #t)) - (flag-unresolved - (single-char #\u)) - (log-file - (single-char #\l) - (value #t)) - (debug - (single-char #\d)))))) - (define (opt tag default) - (let ((pair (assq tag options))) - (if pair (cdr pair) default))) - - (if (opt 'debug #f) - (enable-debug-mode)) - - (set! test-suite - (or (opt 'test-suite #f) - (getenv "TEST_SUITE_DIR") - default-test-suite)) - - ;; directory where temporary files are created. - ;; when run from "make check", this must be under the build-dir, - ;; not the src-dir. - (set! tmp-dir (getcwd)) - - (let* ((tests - (let ((foo (opt '() '()))) - (if (null? foo) - (enumerate-tests test-suite) - foo))) - (log-file - (opt 'log-file "guile.log"))) - - ;; Open the log file. - (let ((log-port (open-output-file log-file))) - - ;; Register some reporters. - (let ((global-pass #t) - (counter (make-count-reporter))) - (register-reporter (car counter)) - (register-reporter (make-log-reporter log-port)) - (register-reporter user-reporter) - (register-reporter (lambda results - (case (car results) - ((unresolved) - (and (opt 'flag-unresolved #f) - (set! global-pass #f))) - ((fail upass error) - (set! global-pass #f))))) - - ;; Run the tests. - (for-each (lambda (test) - (with-test-prefix test - (load (test-file-name test)))) - tests) - - ;; Display the final counts, both to the user and in the log - ;; file. - (let ((counts ((cadr counter)))) - (print-counts counts) - (print-counts counts log-port)) - - (close-port log-port) - (quit global-pass)))))) - - -;;; Local Variables: -;;; mode: scheme -;;; End: diff --git a/test-suite/lib.scm b/test-suite/lib.scm deleted file mode 100644 index de242bd11..000000000 --- a/test-suite/lib.scm +++ /dev/null @@ -1,484 +0,0 @@ -;;;; test-suite/lib.scm --- generic support for testing -;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(define-module (test-suite lib) - :use-module (ice-9 stack-catch) - :use-module (ice-9 regex) - :export ( - - ;; Exceptions which are commonly being tested for. - exception:out-of-range exception:unbound-var - exception:wrong-num-args exception:wrong-type-arg - - ;; Reporting passes and failures. - run-test - pass-if expect-fail - pass-if-exception expect-fail-exception - - ;; Naming groups of tests in a regular fashion. - with-test-prefix with-test-prefix* current-test-prefix - - ;; Reporting results in various ways. - register-reporter unregister-reporter reporter-registered? - make-count-reporter print-counts - make-log-reporter - full-reporter - user-reporter - format-test-name)) - - -;;;; If you're using Emacs's Scheme mode: -;;;; (put 'with-test-prefix 'scheme-indent-function 1) - - -;;;; CORE FUNCTIONS -;;;; -;;;; The function (run-test name expected-result thunk) is the heart of the -;;;; testing environment. The first parameter NAME is a unique name for the -;;;; test to be executed (for an explanation of this parameter see below under -;;;; TEST NAMES). The second parameter EXPECTED-RESULT is a boolean value -;;;; that indicates whether the corresponding test is expected to pass. If -;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is -;;;; #f the test is expected to fail. Finally, THUNK is the function that -;;;; actually performs the test. For example: -;;;; -;;;; (run-test "integer addition" #t (lambda () (= 2 (+ 1 1)))) -;;;; -;;;; To report success, THUNK should either return #t or throw 'pass. To -;;;; report failure, THUNK should either return #f or throw 'fail. If THUNK -;;;; returns a non boolean value or throws 'unresolved, this indicates that -;;;; the test did not perform as expected. For example the property that was -;;;; to be tested could not be tested because something else went wrong. -;;;; THUNK may also throw 'untested to indicate that the test was deliberately -;;;; not performed, for example because the test case is not complete yet. -;;;; Finally, if THUNK throws 'unsupported, this indicates that this test -;;;; requires some feature that is not available in the configured testing -;;;; environment. All other exceptions thrown by THUNK are considered as -;;;; errors. -;;;; -;;;; -;;;; Convenience macros for tests expected to pass or fail -;;;; -;;;; * (pass-if name body) is a short form for -;;;; (run-test name #t (lambda () body)) -;;;; * (expect-fail name body) is a short form for -;;;; (run-test name #f (lambda () body)) -;;;; -;;;; For example: -;;;; -;;;; (pass-if "integer addition" (= 2 (+ 1 1))) -;;;; -;;;; -;;;; Convenience macros to test for exceptions -;;;; -;;;; The following macros take exception parameters which are pairs -;;;; (type . message), where type is a symbol that denotes an exception type -;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a -;;;; regular expression that describes the error message for the exception -;;;; like "Argument .* out of range". -;;;; -;;;; * (pass-if-exception name exception body) will pass if the execution of -;;;; body causes the given exception to be thrown. If no exception is -;;;; thrown, the test fails. If some other exception is thrown, is is an -;;;; error. -;;;; * (expect-fail-exception name exception body) will pass unexpectedly if -;;;; the execution of body causes the given exception to be thrown. If no -;;;; exception is thrown, the test fails expectedly. If some other -;;;; exception is thrown, it is an error. - - -;;;; TEST NAMES -;;;; -;;;; Every test in the test suite has a unique name, to help -;;;; developers find tests that are failing (or unexpectedly passing), -;;;; and to help gather statistics. -;;;; -;;;; A test name is a list of printable objects. For example: -;;;; ("ports.scm" "file" "read and write back list of strings") -;;;; ("ports.scm" "pipe" "read") -;;;; -;;;; Test names may contain arbitrary objects, but they always have -;;;; the following properties: -;;;; - Test names can be compared with EQUAL?. -;;;; - Test names can be reliably stored and retrieved with the standard WRITE -;;;; and READ procedures; doing so preserves their identity. -;;;; -;;;; For example: -;;;; -;;;; (pass-if "simple addition" (= 4 (+ 2 2))) -;;;; -;;;; In that case, the test name is the list ("simple addition"). -;;;; -;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish -;;;; a prefix for the names of all tests whose results are reported -;;;; within their dynamic scope. For example: -;;;; -;;;; (begin -;;;; (with-test-prefix "basic arithmetic" -;;;; (pass-if "addition" (= (+ 2 2) 4)) -;;;; (pass-if "subtraction" (= (- 4 2) 2))) -;;;; (pass-if "multiplication" (= (* 2 2) 4))) -;;;; -;;;; In that example, the three test names are: -;;;; ("basic arithmetic" "addition"), -;;;; ("basic arithmetic" "subtraction"), and -;;;; ("multiplication"). -;;;; -;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX postpends -;;;; a new element to the current prefix: -;;;; -;;;; (with-test-prefix "arithmetic" -;;;; (with-test-prefix "addition" -;;;; (pass-if "integer" (= (+ 2 2) 4)) -;;;; (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i))) -;;;; (with-test-prefix "subtraction" -;;;; (pass-if "integer" (= (- 2 2) 0)) -;;;; (pass-if "complex" (= (- 2+3i 1+2i) 1+1i)))) -;;;; -;;;; The four test names here are: -;;;; ("arithmetic" "addition" "integer") -;;;; ("arithmetic" "addition" "complex") -;;;; ("arithmetic" "subtraction" "integer") -;;;; ("arithmetic" "subtraction" "complex") -;;;; -;;;; To print a name for a human reader, we DISPLAY its elements, -;;;; separated by ": ". So, the last set of test names would be -;;;; reported as: -;;;; -;;;; arithmetic: addition: integer -;;;; arithmetic: addition: complex -;;;; arithmetic: subtraction: integer -;;;; arithmetic: subtraction: complex -;;;; -;;;; The Guile benchmarks use with-test-prefix to include the name of -;;;; the source file containing the test in the test name, to help -;;;; developers to find failing tests, and to provide each file with its -;;;; own namespace. - - -;;;; REPORTERS -;;;; -;;;; A reporter is a function which we apply to each test outcome. -;;;; Reporters can log results, print interesting results to the -;;;; standard output, collect statistics, etc. -;;;; -;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and -;;;; possibly additional arguments depending on RESULT; its return value -;;;; is ignored. RESULT has one of the following forms: -;;;; -;;;; pass - The test named TEST passed. -;;;; Additional arguments are ignored. -;;;; upass - The test named TEST passed unexpectedly. -;;;; Additional arguments are ignored. -;;;; fail - The test named TEST failed. -;;;; Additional arguments are ignored. -;;;; xfail - The test named TEST failed, as expected. -;;;; Additional arguments are ignored. -;;;; unresolved - The test named TEST did not perform as expected, for -;;;; example the property that was to be tested could not be -;;;; tested because something else went wrong. -;;;; Additional arguments are ignored. -;;;; untested - The test named TEST was not actually performed, for -;;;; example because the test case is not complete yet. -;;;; Additional arguments are ignored. -;;;; unsupported - The test named TEST requires some feature that is not -;;;; available in the configured testing environment. -;;;; Additional arguments are ignored. -;;;; error - An error occurred while the test named TEST was -;;;; performed. Since this result means that the system caught -;;;; an exception it could not handle, the exception arguments -;;;; are passed as additional arguments. -;;;; -;;;; This library provides some standard reporters for logging results -;;;; to a file, reporting interesting results to the user, and -;;;; collecting totals. -;;;; -;;;; You can use the REGISTER-REPORTER function and friends to add -;;;; whatever reporting functions you like. If you don't register any -;;;; reporters, the library uses FULL-REPORTER, which simply writes -;;;; all results to the standard output. - - -;;;; MISCELLANEOUS -;;;; - -;;; Define some exceptions which are commonly being tested for. -(define exception:out-of-range - (cons 'out-of-range "^Argument .*out of range")) -(define exception:unbound-var - (cons 'unbound-variable "^Unbound variable")) -(define exception:wrong-num-args - (cons 'wrong-number-of-args "^Wrong number of arguments")) -(define exception:wrong-type-arg - (cons 'wrong-type-arg "^Wrong type argument")) - -;;; Display all parameters to the default output port, followed by a newline. -(define (display-line . objs) - (for-each display objs) - (newline)) - -;;; Display all parameters to the given output port, followed by a newline. -(define (display-line-port port . objs) - (for-each (lambda (obj) (display obj port)) objs) - (newline port)) - - -;;;; CORE FUNCTIONS -;;;; - -;;; The central testing routine. -;;; The idea is taken from Greg, the GNUstep regression test environment. -(define run-test #f) -(let ((test-running #f)) - (define (local-run-test name expect-pass thunk) - (if test-running - (error "Nested calls to run-test are not permitted.") - (let ((test-name (full-name name))) - (set! test-running #t) - (catch #t - (lambda () - (let ((result (thunk))) - (if (eq? result #t) (throw 'pass)) - (if (eq? result #f) (throw 'fail)) - (throw 'unresolved))) - (lambda (key . args) - (case key - ((pass) - (report (if expect-pass 'pass 'upass) test-name)) - ((fail) - (report (if expect-pass 'fail 'xfail) test-name)) - ((unresolved untested unsupported) - (report key test-name)) - ((quit) - (report 'unresolved test-name) - (quit)) - (else - (report 'error test-name (cons key args)))))) - (set! test-running #f)))) - (set! run-test local-run-test)) - -;;; A short form for tests that are expected to pass, taken from Greg. -(defmacro pass-if (name body . rest) - `(run-test ,name #t (lambda () ,body ,@rest))) - -;;; A short form for tests that are expected to fail, taken from Greg. -(defmacro expect-fail (name body . rest) - `(run-test ,name #f (lambda () ,body ,@rest))) - -;;; A helper function to implement the macros that test for exceptions. -(define (run-test-exception name exception expect-pass thunk) - (run-test name expect-pass - (lambda () - (stack-catch (car exception) - (lambda () (thunk) #f) - (lambda (key proc message . rest) - (cond - ;; handle explicit key - ((string-match (cdr exception) message) - #t) - ;; handle `(error ...)' which uses `misc-error' for key and doesn't - ;; yet format the message and args (we have to do it here). - ((and (eq? 'misc-error (car exception)) - (list? rest) - (string-match (cdr exception) - (apply simple-format #f message (car rest)))) - #t) - ;; unhandled; throw again - (else - (apply throw key proc message rest)))))))) - -;;; A short form for tests that expect a certain exception to be thrown. -(defmacro pass-if-exception (name exception body . rest) - `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest))) - -;;; A short form for tests expected to fail to throw a certain exception. -(defmacro expect-fail-exception (name exception body . rest) - `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest))) - - -;;;; TEST NAMES -;;;; - -;;;; Turn a test name into a nice human-readable string. -(define (format-test-name name) - (call-with-output-string - (lambda (port) - (let loop ((name name) - (separator "")) - (if (pair? name) - (begin - (display separator port) - (display (car name) port) - (loop (cdr name) ": "))))))) - -;;;; For a given test-name, deliver the full name including all prefixes. -(define (full-name name) - (append (current-test-prefix) (list name))) - -;;; A fluid containing the current test prefix, as a list. -(define prefix-fluid (make-fluid)) -(fluid-set! prefix-fluid '()) -(define (current-test-prefix) - (fluid-ref prefix-fluid)) - -;;; Postpend PREFIX to the current name prefix while evaluting THUNK. -;;; The name prefix is only changed within the dynamic scope of the -;;; call to with-test-prefix*. Return the value returned by THUNK. -(define (with-test-prefix* prefix thunk) - (with-fluids ((prefix-fluid - (append (fluid-ref prefix-fluid) (list prefix)))) - (thunk))) - -;;; (with-test-prefix PREFIX BODY ...) -;;; Postpend PREFIX to the current name prefix while evaluating BODY ... -;;; The name prefix is only changed within the dynamic scope of the -;;; with-test-prefix expression. Return the value returned by the last -;;; BODY expression. -(defmacro with-test-prefix (prefix . body) - `(with-test-prefix* ,prefix (lambda () ,@body))) - - -;;;; REPORTERS -;;;; - -;;; The global list of reporters. -(define reporters '()) - -;;; The default reporter, to be used only if no others exist. -(define default-reporter #f) - -;;; Add the procedure REPORTER to the current set of reporter functions. -;;; Signal an error if that reporter procedure object is already registered. -(define (register-reporter reporter) - (if (memq reporter reporters) - (error "register-reporter: reporter already registered: " reporter)) - (set! reporters (cons reporter reporters))) - -;;; Remove the procedure REPORTER from the current set of reporter -;;; functions. Signal an error if REPORTER is not currently registered. -(define (unregister-reporter reporter) - (if (memq reporter reporters) - (set! reporters (delq! reporter reporters)) - (error "unregister-reporter: reporter not registered: " reporter))) - -;;; Return true iff REPORTER is in the current set of reporter functions. -(define (reporter-registered? reporter) - (if (memq reporter reporters) #t #f)) - -;;; Send RESULT to all currently registered reporter functions. -(define (report . args) - (if (pair? reporters) - (for-each (lambda (reporter) (apply reporter args)) - reporters) - (apply default-reporter args))) - - -;;;; Some useful standard reporters: -;;;; Count reporters count the occurrence of each test result type. -;;;; Log reporters write all test results to a given log file. -;;;; Full reporters write all test results to the standard output. -;;;; User reporters write interesting test results to the standard output. - -;;; The complete list of possible test results. -(define result-tags - '((pass "PASS" "passes: ") - (fail "FAIL" "failures: ") - (upass "UPASS" "unexpected passes: ") - (xfail "XFAIL" "expected failures: ") - (unresolved "UNRESOLVED" "unresolved test cases: ") - (untested "UNTESTED" "untested test cases: ") - (unsupported "UNSUPPORTED" "unsupported test cases: ") - (error "ERROR" "errors: "))) - -;;; The list of important test results. -(define important-result-tags - '(fail upass unresolved error)) - -;;; Display a single test result in formatted form to the given port -(define (print-result port result name . args) - (let* ((tag (assq result result-tags)) - (label (if tag (cadr tag) #f))) - (if label - (begin - (display label port) - (display ": " port) - (display (format-test-name name) port) - (if (pair? args) - (begin - (display " - arguments: " port) - (write args port))) - (newline port)) - (error "(test-suite lib) FULL-REPORTER: unrecognized result: " - result)))) - -;;; Return a list of the form (COUNTER RESULTS), where: -;;; - COUNTER is a reporter procedure, and -;;; - RESULTS is a procedure taking no arguments which returns the -;;; results seen so far by COUNTER. The return value is an alist -;;; mapping outcome symbols (`pass', `fail', etc.) onto counts. -(define (make-count-reporter) - (let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags))) - (list - (lambda (result name . args) - (let ((pair (assq result counts))) - (if pair - (set-cdr! pair (+ 1 (cdr pair))) - (error "count-reporter: unexpected test result: " - (cons result (cons name args)))))) - (lambda () - (append counts '()))))) - -;;; Print a count reporter's results nicely. Pass this function the value -;;; returned by a count reporter's RESULTS procedure. -(define (print-counts results . port?) - (let ((port (if (pair? port?) - (car port?) - (current-output-port)))) - (newline port) - (display-line-port port "Totals for this test run:") - (for-each - (lambda (tag) - (let ((result (assq (car tag) results))) - (if result - (display-line-port port (caddr tag) (cdr result)) - (display-line-port port - "Test suite bug: " - "no total available for `" (car tag) "'")))) - result-tags) - (newline port))) - -;;; Return a reporter procedure which prints all results to the file -;;; FILE, in human-readable form. FILE may be a filename, or a port. -(define (make-log-reporter file) - (let ((port (if (output-port? file) file - (open-output-file file)))) - (lambda args - (apply print-result port args) - (force-output port)))) - -;;; A reporter that reports all results to the user. -(define (full-reporter . args) - (apply print-result (current-output-port) args)) - -;;; A reporter procedure which shows interesting results (failures, -;;; unexpected passes etc.) to the user. -(define (user-reporter result name . args) - (if (memq result important-result-tags) - (apply full-reporter result name args))) - -(set! default-reporter full-reporter) diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test deleted file mode 100644 index c25459c53..000000000 --- a/test-suite/tests/alist.test +++ /dev/null @@ -1,269 +0,0 @@ -;;;; alist.test --- tests guile's alists -*- scheme -*- -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - -(use-modules (test-suite lib)) - -;;; (gbh) some of these are duplicated in r4rs. This is probably a bit -;;; more thorough, though (maybe overkill? I need it, anyway). -;;; -;;; -;;; Also: it will fail on the ass*-ref & remove functions. -;;; Sloppy versions should be added with the current behaviour -;;; (it's the only set of 'ref functions that won't cause an -;;; error on an incorrect arg); they aren't actually used anywhere -;;; so changing's not a big deal. - -;;; Misc - -(define-macro (pass-if-not str form) - `(pass-if ,str (not ,form))) - -(define (safe-assq-ref alist elt) - (let ((x (assq elt alist))) - (if x (cdr x) x))) - -(define (safe-assv-ref alist elt) - (let ((x (assv elt alist))) - (if x (cdr x) x))) - -(define (safe-assoc-ref alist elt) - (let ((x (assoc elt alist))) - (if x (cdr x) x))) - -;;; Creators, getters -(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f '())))) - (b (acons "this" "is" (acons "a" "test" '()))) - (deformed '(a b c d e f g))) - (pass-if "acons" - (and (equal? a '((a . b) (c . d) (e . f))) - (equal? b '(("this" . "is") ("a" . "test"))))) - (pass-if "sloppy-assq" - (let ((x (sloppy-assq 'c a))) - (and (pair? x) - (eq? (car x) 'c) - (eq? (cdr x) 'd)))) - (pass-if "sloppy-assq not" - (let ((x (sloppy-assq "this" b))) - (not x))) - (pass-if "sloppy-assv" - (let ((x (sloppy-assv 'c a))) - (and (pair? x) - (eq? (car x) 'c) - (eq? (cdr x) 'd)))) - (pass-if "sloppy-assv not" - (let ((x (sloppy-assv "this" b))) - (not x))) - (pass-if "sloppy-assoc" - (let ((x (sloppy-assoc "this" b))) - (and (pair? x) - (string=? (cdr x) "is")))) - (pass-if "sloppy-assoc not" - (let ((x (sloppy-assoc "heehee" b))) - (not x))) - (pass-if "assq" - (let ((x (assq 'c a))) - (and (pair? x) - (eq? (car x) 'c) - (eq? (cdr x) 'd)))) - (pass-if-exception "assq deformed" - exception:wrong-type-arg - (assq 'x deformed)) - (pass-if-not "assq not" (assq 'r a)) - (pass-if "assv" - (let ((x (assv 'a a))) - (and (pair? x) - (eq? (car x) 'a) - (eq? (cdr x) 'b)))) - (pass-if-exception "assv deformed" - exception:wrong-type-arg - (assv 'x deformed)) - (pass-if-not "assv not" (assq "this" b)) - - (pass-if "assoc" - (let ((x (assoc "this" b))) - (and (pair? x) - (string=? (car x) "this") - (string=? (cdr x) "is")))) - (pass-if-exception "assoc deformed" - exception:wrong-type-arg - (assoc 'x deformed)) - (pass-if-not "assoc not" (assoc "this isn't" b))) - - -;;; Refers -(let ((a '((foo bar) (baz quux))) - (b '(("one" 2 3) ("four" 5 6) ("seven" 8 9))) - (deformed '(thats a real sloppy assq you got there))) - (pass-if "assq-ref" - (let ((x (assq-ref a 'foo))) - (and (list? x) - (eq? (car x) 'bar)))) - - (pass-if-not "assq-ref not" (assq-ref b "one")) - (pass-if "assv-ref" - (let ((x (assv-ref a 'baz))) - (and (list? x) - (eq? (car x) 'quux)))) - - (pass-if-not "assv-ref not" (assv-ref b "one")) - - (pass-if "assoc-ref" - (let ((x (assoc-ref b "one"))) - (and (list? x) - (eq? (car x) 2) - (eq? (cadr x) 3)))) - - - (pass-if-not "assoc-ref not" (assoc-ref a 'testing)) - - (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) - - (pass-if-exception "assv-ref deformed" - exception:wrong-type-arg - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assv-ref deformed 'sloppy)) - - (pass-if-exception "assoc-ref deformed" - exception:wrong-type-arg - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assoc-ref deformed 'sloppy)) - - (pass-if-exception "assq-ref deformed" - exception:wrong-type-arg - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assq-ref deformed 'sloppy)))) - - -;;; Setters -(let ((a '((another . silly) (alist . test-case))) - (b '(("this" "one" "has") ("strings" "!"))) - (deformed '(canada is a cold nation))) - (pass-if "assq-set!" - (begin - (set! a (assq-set! a 'another 'stupid)) - (let ((x (safe-assq-ref a 'another))) - (and x - (symbol? x) (eq? x 'stupid))))) - - (pass-if "assq-set! add" - (begin - (set! a (assq-set! a 'fickle 'pickle)) - (let ((x (safe-assq-ref a 'fickle))) - (and x (symbol? x) - (eq? x 'pickle))))) - - (pass-if "assv-set!" - (begin - (set! a (assv-set! a 'another 'boring)) - (let ((x (safe-assv-ref a 'another))) - (and x - (eq? x 'boring))))) - (pass-if "assv-set! add" - (begin - (set! a (assv-set! a 'whistle '(while you work))) - (let ((x (safe-assv-ref a 'whistle))) - (and x (equal? x '(while you work)))))) - - (pass-if "assoc-set!" - (begin - (set! b (assoc-set! b "this" "has")) - (let ((x (safe-assoc-ref b "this"))) - (and x (string? x) - (string=? x "has"))))) - (pass-if "assoc-set! add" - (begin - (set! b (assoc-set! b "flugle" "horn")) - (let ((x (safe-assoc-ref b "flugle"))) - (and x (string? x) - (string=? x "horn"))))) - - (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) - - (pass-if-exception "assq-set! deformed" - exception:wrong-type-arg - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assq-set! deformed 'cold '(very cold))) - - (pass-if-exception "assv-set! deformed" - exception:wrong-type-arg - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assv-set! deformed 'canada 'Canada)) - - (pass-if-exception "assoc-set! deformed" - exception:wrong-type-arg - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assoc-set! deformed 'canada '(Iceland hence the name))))) - -;;; Removers - -(let ((a '((a b) (c d) (e boring))) - (b '(("what" . "else") ("could" . "I") ("say" . "here"))) - (deformed 1)) - (pass-if "assq-remove!" - (begin - (set! a (assq-remove! a 'a)) - (equal? a '((c d) (e boring))))) - (pass-if "assv-remove!" - (begin - (set! a (assv-remove! a 'c)) - (equal? a '((e boring))))) - (pass-if "assoc-remove!" - (begin - (set! b (assoc-remove! b "what")) - (equal? b '(("could" . "I") ("say" . "here"))))) - - (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove))) - - (pass-if-exception "assq-remove! deformed" - exception:wrong-type-arg - (if (not have-sloppy-assq-remove?) (throw 'unsupported)) - (assq-remove! deformed 'puddle)) - - (pass-if-exception "assv-remove! deformed" - exception:wrong-type-arg - (if (not have-sloppy-assq-remove?) (throw 'unsupported)) - (assv-remove! deformed 'splashing)) - - (pass-if-exception "assoc-remove! deformed" - exception:wrong-type-arg - (if (not have-sloppy-assq-remove?) (throw 'unsupported)) - (assoc-remove! deformed 'fun)))) diff --git a/test-suite/tests/asmobs/Makefile b/test-suite/tests/asmobs/Makefile deleted file mode 100644 index e69de29bb..000000000 --- a/test-suite/tests/asmobs/Makefile +++ /dev/null diff --git a/test-suite/tests/asmobs/README b/test-suite/tests/asmobs/README deleted file mode 100644 index e69de29bb..000000000 --- a/test-suite/tests/asmobs/README +++ /dev/null diff --git a/test-suite/tests/asmobs/asmobs-test.scm b/test-suite/tests/asmobs/asmobs-test.scm deleted file mode 100644 index e69de29bb..000000000 --- a/test-suite/tests/asmobs/asmobs-test.scm +++ /dev/null diff --git a/test-suite/tests/asmobs/asmobs.c b/test-suite/tests/asmobs/asmobs.c deleted file mode 100644 index e69de29bb..000000000 --- a/test-suite/tests/asmobs/asmobs.c +++ /dev/null diff --git a/test-suite/tests/bit-operations.test b/test-suite/tests/bit-operations.test deleted file mode 100644 index 47cca5fdc..000000000 --- a/test-suite/tests/bit-operations.test +++ /dev/null @@ -1,354 +0,0 @@ -;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - -(use-modules (ice-9 documentation)) - - -;;; -;;; miscellaneous -;;; - -(define (run-tests name-proc test-proc arg-sets) - (for-each - (lambda (arg-set) - (pass-if (apply name-proc arg-set) - (apply test-proc arg-set))) - arg-sets)) - -(define (documented? object) - (not (not (object-documentation object)))) - -(define fixnum-bit - (inexact->exact (+ (/ (log (+ most-positive-fixnum 1)) (log 2)) 1))) - -(define fixnum-min most-negative-fixnum) -(define fixnum-max most-positive-fixnum) - -(with-test-prefix "bit-extract" - - (pass-if "documented?" - (documented? bit-extract)) - - (with-test-prefix "extract from zero" - - (run-tests - (lambda (a b c d) - (string-append "single bit " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list 0 0 1 0) - (list 0 1 2 0) - (list 0 (+ fixnum-bit -2) (+ fixnum-bit -1) 0) - (list 0 (+ fixnum-bit -1) (+ fixnum-bit 0) 0) - (list 0 (+ fixnum-bit 0) (+ fixnum-bit 1) 0) - (list 0 (+ fixnum-bit 1) (+ fixnum-bit 2) 0))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit - 1 bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list 0 0 (+ fixnum-bit -1) 0) - (list 0 1 (+ fixnum-bit 0) 0) - (list 0 2 (+ fixnum-bit 1) 0) - (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 0) - (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 0) - (list 0 (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1) 0) - (list 0 (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0) 0))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list 0 0 (+ fixnum-bit 0) 0) - (list 0 1 (+ fixnum-bit 1) 0) - (list 0 2 (+ fixnum-bit 2) 0) - (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 0) - (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 0) - (list 0 (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0) 0) - (list 0 (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1) 0))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit + 1 bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list 0 0 (+ fixnum-bit 1) 0) - (list 0 1 (+ fixnum-bit 2) 0) - (list 0 2 (+ fixnum-bit 3) 0) - (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 0) - (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0) 0) - (list 0 (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1) 0) - (list 0 (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2) 0)))) - - (with-test-prefix "extract from fixnum-max" - - (run-tests - (lambda (a b c d) - (string-append "single bit " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list fixnum-max 0 1 1) - (list fixnum-max 1 2 1) - (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit -1) 1) - (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit 0) 0) - (list fixnum-max (+ fixnum-bit 0) (+ fixnum-bit 1) 0) - (list fixnum-max (+ fixnum-bit 1) (+ fixnum-bit 2) 0))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit - 1 bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list fixnum-max 0 (+ fixnum-bit -1) (ash fixnum-max 0)) - (list fixnum-max 1 (+ fixnum-bit 0) (ash fixnum-max -1)) - (list fixnum-max 2 (+ fixnum-bit 1) (ash fixnum-max -2)) - (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 1) - (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 0) - (list fixnum-max (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1) 0) - (list fixnum-max (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0) 0))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list fixnum-max 0 (+ fixnum-bit 0) (ash fixnum-max 0)) - (list fixnum-max 1 (+ fixnum-bit 1) (ash fixnum-max -1)) - (list fixnum-max 2 (+ fixnum-bit 2) (ash fixnum-max -2)) - (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 1) - (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 0) - (list fixnum-max (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0) 0) - (list fixnum-max (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1) 0))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit + 1 bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list fixnum-max 0 (+ fixnum-bit 1) (ash fixnum-max 0)) - (list fixnum-max 1 (+ fixnum-bit 2) (ash fixnum-max -1)) - (list fixnum-max 2 (+ fixnum-bit 3) (ash fixnum-max -2)) - (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 1) - (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0) 0) - (list fixnum-max (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1) 0) - (list fixnum-max (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2) 0)))) - - (with-test-prefix "extract from fixnum-max + 1" - - (run-tests - (lambda (a b c d) - (string-append "single bit " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list (+ fixnum-max 1) 0 1 0) - (list (+ fixnum-max 1) 1 2 0) - (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit -1) 0) - (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit 0) 1) - (list (+ fixnum-max 1) (+ fixnum-bit 0) (+ fixnum-bit 1) 0) - (list (+ fixnum-max 1) (+ fixnum-bit 1) (+ fixnum-bit 2) 0))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit - 1 bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list (+ fixnum-max 1) 0 (+ fixnum-bit -1) (ash 0 (- fixnum-bit 1))) - (list (+ fixnum-max 1) 1 (+ fixnum-bit 0) (ash 1 (- fixnum-bit 2))) - (list (+ fixnum-max 1) 2 (+ fixnum-bit 1) (ash 1 (- fixnum-bit 3))) - (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 2) - (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 1) - (list (+ fixnum-max 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1) 0) - (list (+ fixnum-max 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0) 0))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list (+ fixnum-max 1) 0 (+ fixnum-bit 0) (ash 1 (- fixnum-bit 1))) - (list (+ fixnum-max 1) 1 (+ fixnum-bit 1) (ash 1 (- fixnum-bit 2))) - (list (+ fixnum-max 1) 2 (+ fixnum-bit 2) (ash 1 (- fixnum-bit 3))) - (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 2) - (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 1) - (list (+ fixnum-max 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0) 0) - (list (+ fixnum-max 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1) 0))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit + 1 bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list (+ fixnum-max 1) 0 (+ fixnum-bit 1) (ash 1 (- fixnum-bit 1))) - (list (+ fixnum-max 1) 1 (+ fixnum-bit 2) (ash 1 (- fixnum-bit 2))) - (list (+ fixnum-max 1) 2 (+ fixnum-bit 3) (ash 1 (- fixnum-bit 3))) - (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 2) - (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0) 1) - (list (+ fixnum-max 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1) 0) - (list (+ fixnum-max 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2) 0)))) - - (with-test-prefix "extract from fixnum-min" - - (run-tests - (lambda (a b c d) - (string-append "single bit " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list fixnum-min 0 1 0) - (list fixnum-min 1 2 0) - (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit -1) 0) - (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit 0) 1) - (list fixnum-min (+ fixnum-bit 0) (+ fixnum-bit 1) 1) - (list fixnum-min (+ fixnum-bit 1) (+ fixnum-bit 2) 1))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit - 1 bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list fixnum-min 0 (+ fixnum-bit -1) (ash 0 (- fixnum-bit 1))) - (list fixnum-min 1 (+ fixnum-bit 0) (ash 1 (- fixnum-bit 2))) - (list fixnum-min 2 (+ fixnum-bit 1) (ash 3 (- fixnum-bit 3))) - (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) (- (ash 1 (- fixnum-bit 1)) 2)) - (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) (- (ash 1 (- fixnum-bit 1)) 1)) - (list fixnum-min (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1) (- (ash 1 (- fixnum-bit 1)) 1)) - (list fixnum-min (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0) (- (ash 1 (- fixnum-bit 1)) 1)))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list fixnum-min 0 (+ fixnum-bit 0) (ash 1 (- fixnum-bit 1))) - (list fixnum-min 1 (+ fixnum-bit 1) (ash 3 (- fixnum-bit 2))) - (list fixnum-min 2 (+ fixnum-bit 2) (ash 7 (- fixnum-bit 3))) - (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) (- (ash 1 fixnum-bit) 2)) - (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) (- (ash 1 fixnum-bit) 1)) - (list fixnum-min (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0) (- (ash 1 fixnum-bit) 1)) - (list fixnum-min (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1) (- (ash 1 fixnum-bit) 1)))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit + 1 bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list fixnum-min 0 (+ fixnum-bit 1) (ash 3 (- fixnum-bit 1))) - (list fixnum-min 1 (+ fixnum-bit 2) (ash 7 (- fixnum-bit 2))) - (list fixnum-min 2 (+ fixnum-bit 3) (ash 15 (- fixnum-bit 3))) - (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) (- (ash 1 (+ fixnum-bit 1)) 2)) - (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0) (- (ash 1 (+ fixnum-bit 1)) 1)) - (list fixnum-min (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1) (- (ash 1 (+ fixnum-bit 1)) 1)) - (list fixnum-min (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2) (- (ash 1 (+ fixnum-bit 1)) 1))))) - - (with-test-prefix "extract from fixnum-min - 1" - - (run-tests - (lambda (a b c d) - (string-append "single bit " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list (- fixnum-min 1) 0 1 1) - (list (- fixnum-min 1) 1 2 1) - (list (- fixnum-min 1) (+ fixnum-bit -2) (+ fixnum-bit -1) 1) - (list (- fixnum-min 1) (+ fixnum-bit -1) (+ fixnum-bit 0) 0) - (list (- fixnum-min 1) (+ fixnum-bit 0) (+ fixnum-bit 1) 1) - (list (- fixnum-min 1) (+ fixnum-bit 1) (+ fixnum-bit 2) 1))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit - 1 bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list (- fixnum-min 1) 0 (+ fixnum-bit -1) (- (ash 1 (- fixnum-bit 1)) 1 (ash 0 (- fixnum-bit 1)))) - (list (- fixnum-min 1) 1 (+ fixnum-bit 0) (- (ash 1 (- fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 2)))) - (list (- fixnum-min 1) 2 (+ fixnum-bit 1) (- (ash 1 (- fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 3)))) - (list (- fixnum-min 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) (- (ash 1 (- fixnum-bit 1)) 3)) - (list (- fixnum-min 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) (- (ash 1 (- fixnum-bit 1)) 2)) - (list (- fixnum-min 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1) (- (ash 1 (- fixnum-bit 1)) 1)) - (list (- fixnum-min 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0) (- (ash 1 (- fixnum-bit 1)) 1)))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list (- fixnum-min 1) 0 (+ fixnum-bit 0) (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 1)))) - (list (- fixnum-min 1) 1 (+ fixnum-bit 1) (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 2)))) - (list (- fixnum-min 1) 2 (+ fixnum-bit 2) (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 3)))) - (list (- fixnum-min 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) (- (ash 1 fixnum-bit) 3)) - (list (- fixnum-min 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) (- (ash 1 fixnum-bit) 2)) - (list (- fixnum-min 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0) (- (ash 1 fixnum-bit) 1)) - (list (- fixnum-min 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1) (- (ash 1 fixnum-bit) 1)))) - - (run-tests - (lambda (a b c d) - (string-append "fixnum-bit + 1 bits starting at " (number->string b))) - (lambda (a b c d) - (= (bit-extract a b c) d)) - (list - (list (- fixnum-min 1) 0 (+ fixnum-bit 1) (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 1)))) - (list (- fixnum-min 1) 1 (+ fixnum-bit 2) (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 2)))) - (list (- fixnum-min 1) 2 (+ fixnum-bit 3) (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 3)))) - (list (- fixnum-min 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) (- (ash 1 (+ fixnum-bit 1)) 3)) - (list (- fixnum-min 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0) (- (ash 1 (+ fixnum-bit 1)) 2)) - (list (- fixnum-min 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1) (- (ash 1 (+ fixnum-bit 1)) 1)) - (list (- fixnum-min 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2) (- (ash 1 (+ fixnum-bit 1)) 1)))))) diff --git a/test-suite/tests/c-api.test b/test-suite/tests/c-api.test deleted file mode 100644 index 97146ea8a..000000000 --- a/test-suite/tests/c-api.test +++ /dev/null @@ -1,46 +0,0 @@ -;;;; c-api.test --- complementary test suite for the c-api -*- scheme -*- -;;;; MDJ 990915 <djurfeldt@nada.kth.se> -;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(define srcdir (cdr (assq 'srcdir %guile-build-info))) - -(define (egrep string filename) - (zero? (system (string-append "egrep '" string "' " filename " >/dev/null")))) - -(define (seek-offset-test dirname) - (let ((dir (opendir dirname))) - (do ((filename (readdir dir) (readdir dir))) - ((eof-object? filename)) - (if (and - (eqv? (string-ref filename (- (string-length filename) 1)) #\c) - (eqv? (string-ref filename (- (string-length filename) 2)) #\.)) - (let ((file (string-append dirname "/" filename))) - (if (and (file-exists? file) - (egrep "SEEK_(SET|CUR|END)" file) - (not (egrep "unistd.h" file))) - (fail file))))))) - -;;; A rough conservative test to check that all source files -;;; which use SEEK_SET, SEEK_CUR, and SEEK_END include unistd.h. -;;; -;;; If this test start to trigger without reason, we just modify it -;;; to be more precise. -(with-test-prefix "SEEK_XXX => #include <unistd.h>" - (if (file-exists? srcdir) - (seek-offset-test srcdir))) diff --git a/test-suite/tests/c-api/Makefile b/test-suite/tests/c-api/Makefile deleted file mode 100644 index 44488af50..000000000 --- a/test-suite/tests/c-api/Makefile +++ /dev/null @@ -1,16 +0,0 @@ -CC = gcc -CFLAGS = -g `guile-config compile` - -all: strings - -strings: strings.o testlib.o - ${CC} ${CFLAGS} ${LDFLAGS} -o strings strings.o testlib.o \ - `guile-config link` - -strings.o: strings.c testlib.h -testlib.o: testlib.c testlib.h - - -clean: - rm -f strings - rm -f *.o diff --git a/test-suite/tests/c-api/README b/test-suite/tests/c-api/README deleted file mode 100644 index f041346ad..000000000 --- a/test-suite/tests/c-api/README +++ /dev/null @@ -1,7 +0,0 @@ -This directory contains tests for Guile's C API. At the moment, the -test suite doesn't have any way to run these automatically --- we need -to 1) figure out how to run the compiler, and 2) figure out how to -integrate results from C tests into the test suite statistics. - -Nonetheless, it's better to have this code accumulating here than -someplace else where nobody can find it. diff --git a/test-suite/tests/c-api/strings.c b/test-suite/tests/c-api/strings.c deleted file mode 100644 index 13cfcf0ef..000000000 --- a/test-suite/tests/c-api/strings.c +++ /dev/null @@ -1,70 +0,0 @@ -/* strings.c --- test the Guile C API's string handling functions - Jim Blandy <jimb@red-bean.com> --- August 1999 */ - -#include <guile/gh.h> - -#include "testlib.h" - -static int -string_equal (SCM str, char *lit) -{ - int len = strlen (lit); - - return (SCM_LENGTH (str) == len - && ! memcmp (SCM_ROCHARS (str), lit, len)); -} - -void -test_gh_set_substr () -{ - test_context_t cx = test_enter_context ("gh_set_substr"); - SCM string; - - string = gh_str02scm ("Free, darnit!"); - test_pass_if ("make a string", gh_string_p (string)); - - gh_set_substr ("dammit", string, 6, 6); - test_pass_if ("gh_set_substr from literal", - string_equal (string, "Free, dammit!")); - - /* Make sure that we can use the string itself as a source. - - I guess this behavior isn't really visible, since the GH API - doesn't provide any direct access to the string contents. But I - think it should, eventually. You can't write efficient string - code if you have to copy the string just to look at it. */ - - /* Copy a substring to an overlapping region to its right. */ - gh_set_substr (SCM_CHARS (string), string, 4, 6); - test_pass_if ("gh_set_substr shifting right", - string_equal (string, "FreeFree, it!")); - - string = gh_str02scm ("Free, darnit!"); - test_pass_if ("make another string", gh_string_p (string)); - - /* Copy a substring to an overlapping region to its left. */ - gh_set_substr (SCM_CHARS (string) + 6, string, 2, 6); - test_pass_if ("gh_set_substr shifting right", - string_equal (string, "Frdarnitrnit!")); - - test_restore_context (cx); -} - -void -main_prog (int argc, char *argv[]) -{ - test_context_t strings = test_enter_context ("strings.c"); - - test_gh_set_substr (); - - test_restore_context (strings); - - exit (test_summarize ()); -} - -int -main (int argc, char *argv[]) -{ - gh_enter (argc, argv, main_prog); - return 0; -} diff --git a/test-suite/tests/c-api/testlib.c b/test-suite/tests/c-api/testlib.c deleted file mode 100644 index 21fff2492..000000000 --- a/test-suite/tests/c-api/testlib.c +++ /dev/null @@ -1,121 +0,0 @@ -/* testlib.c --- reporting test results - Jim Blandy <jimb@red-bean.com> --- August 1999 */ - -#include <stdlib.h> -#include <stdio.h> - -#include "testlib.h" - - - -/* Dying. */ - -static void -fatal (char *message) -{ - fprintf (stderr, "%s\n", message); - exit (1); -} - - -/* Contexts. */ - -/* If it gets deeper than this, that's probably an error, right? */ -#define MAX_NESTING 10 - -int depth = 0; -char *context_name_stack[MAX_NESTING]; -int marker; -int context_marker_stack[MAX_NESTING]; - -test_context_t -test_enter_context (char *name) -{ - if (depth >= MAX_NESTING) - fatal ("test contexts nested too deeply"); - - /* Generate a unique marker value for this context. */ - marker++; - - context_name_stack[depth] = name; - context_marker_stack[depth] = marker; - - depth++; - - return marker; -} - -void -test_restore_context (test_context_t context) -{ - if (depth <= 0) - fatal ("attempt to leave outermost context"); - - depth--; - - /* Make sure that we're exiting the same context we last entered. */ - if (context_marker_stack[depth] != context) - fatal ("contexts not nested properly"); -} - - -/* Reporting results. */ - -int count_passes, count_fails; - -static void -print_test_name (char *name) -{ - int i; - - for (i = 0; i < depth; i++) - printf ("%s: ", context_name_stack[i]); - - printf ("%s", name); -} - -static void -print_result (char *result, char *name) -{ - printf ("%s: ", result); - print_test_name (name); - putchar ('\n'); -} - -void -test_pass (char *name) -{ - print_result ("PASS", name); - count_passes++; -} - -void -test_fail (char *name) -{ - print_result ("FAIL", name); - count_fails++; -} - -void -test_pass_if (char *name, int condition) -{ - (condition ? test_pass : test_fail) (name); -} - - -/* Printing a summary. */ - -/* Print a summary of the reported test results. Return zero if - no failures occurred, one otherwise. */ - -int -test_summarize () -{ - putchar ('\n'); - - printf ("passes: %d\n", count_passes); - printf ("failures: %d\n", count_fails); - printf ("total tests: %d\n", count_passes + count_fails); - - return (count_fails != 0); -} diff --git a/test-suite/tests/c-api/testlib.h b/test-suite/tests/c-api/testlib.h deleted file mode 100644 index 3adaf7fc2..000000000 --- a/test-suite/tests/c-api/testlib.h +++ /dev/null @@ -1,28 +0,0 @@ -/* testlib.h --- reporting test results - Jim Blandy <jimb@red-bean.com> --- August 1999 */ - -#ifndef TESTLIB_H -#define TESTLIB_H - -extern void test_pass (char *name); -extern void test_fail (char *name); -extern void test_pass_if (char *name, int condition); - -/* We need a way to keep track of what groups of tests we're currently - within. A call to test_enter_context assures that future tests - will be reported with a name prefixed by NAME, until we call - test_restore_context with the value it returned. - - Calls to test_enter_context and test_restore_context should be - properly nested; passing the context around allows them to detect - mismatches. - - It is the caller's responsibility to free NAME after exiting the - context. (This is trivial if you're passing string literals to - test_enter_context.) */ - -typedef int test_context_t; -extern test_context_t test_enter_context (char *name); -extern void test_restore_context (test_context_t context); - -#endif /* TESTLIB_H */ diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test deleted file mode 100644 index de75d85eb..000000000 --- a/test-suite/tests/chars.test +++ /dev/null @@ -1,31 +0,0 @@ -;;;; chars.test --- test suite for Guile's char functions -*- scheme -*- -;;;; Greg J. Badros <gjb@cs.washington.edu> -;;;; -;;;; Copyright (C) 2000 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - - -(use-modules (test-suite lib)) - -(pass-if "char-is-both? works" - (and - (not (char-is-both? #\?)) - (not (char-is-both? #\newline)) - (char-is-both? #\a) - (char-is-both? #\Z) - (not (char-is-both? #\1)))) - diff --git a/test-suite/tests/common-list.test b/test-suite/tests/common-list.test deleted file mode 100644 index 8d675da9d..000000000 --- a/test-suite/tests/common-list.test +++ /dev/null @@ -1,242 +0,0 @@ -;;;; common-list.test --- tests guile's common list functions -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - -(use-modules (ice-9 documentation) - (ice-9 common-list)) - - -;;; -;;; miscellaneous -;;; - - -(define (documented? object) - (not (not (object-documentation object)))) - - -;;; -;;; intersection -;;; - -(with-test-prefix "intersection" - - (pass-if "documented?" - (documented? intersection)) - - (pass-if "both arguments empty" - (eq? (intersection '() '()) '())) - - (pass-if "first argument empty" - (eq? (intersection '() '(1)) '())) - - (pass-if "second argument empty" - (eq? (intersection '(1) '()) '())) - - (pass-if "disjoint arguments" - (eq? (intersection '(1) '(2)) '())) - - (pass-if "equal arguments" - (equal? (intersection '(1) '(1)) '(1))) - - (pass-if "reverse argument order" - (equal? (intersection '(1 2 3) '(3 2 1)) '(1 2 3))) - - (pass-if "multiple matches in first list" - (equal? (intersection '(1 1 2 2 3) '(3 2 1)) '(1 1 2 2 3))) - - (pass-if "multiple matches in second list" - (equal? (intersection '(1 2 3) '(3 3 2 2 1)) '(1 2 3))) - - (pass-if "mixed arguments" - (equal? (intersection '(1 2 3 5 7 8 10) '(1 3 4 7 8 9)) '(1 3 7 8))) - - ) - - -;;; -;;; set-difference -;;; - -(with-test-prefix "set-difference" - - (pass-if "documented?" - (documented? set-difference)) - - (pass-if "both arguments empty" - (eq? (set-difference '() '()) '())) - - (pass-if "first argument empty" - (eq? (set-difference '() '(1)) '())) - - (pass-if "second argument empty" - (equal? (set-difference '(1) '()) '(1))) - - (pass-if "disjoint arguments" - (equal? (set-difference '(1) '(2)) '(1))) - - (pass-if "equal arguments" - (eq? (set-difference '(1) '(1)) '())) - - (pass-if "reverse argument order" - (eq? (set-difference '(1 2 3) '(3 2 1)) '())) - - (pass-if "multiple matches in first list" - (eq? (set-difference '(1 1 2 2 3) '(3 2 1)) '())) - - (pass-if "multiple matches in second list" - (eq? (set-difference '(1 2 3) '(3 3 2 2 1)) '())) - - (pass-if "mixed arguments" - (equal? (set-difference '(1 2 3 5 7 8 10) '(1 3 4 7 8 9)) '(2 5 10))) - - ) - - -;;; -;;; remove-if -;;; - -(with-test-prefix "remove-if" - - (pass-if "documented?" - (documented? remove-if)) - - (pass-if "empty list, remove all" - (eq? (remove-if (lambda (x) #t) '()) '())) - - (pass-if "empty list, remove none" - (eq? (remove-if (lambda (x) #f) '()) '())) - - (pass-if "non-empty list, remove all" - (eq? (remove-if (lambda (x) #t) '(1 2 3 4)) '())) - - (pass-if "non-empty list, remove none" - (equal? (remove-if (lambda (x) #f) '(1 2 3 4)) '(1 2 3 4))) - - (pass-if "non-empty list, remove some" - (equal? (remove-if odd? '(1 2 3 4)) '(2 4))) - - ) - - -;;; -;;; remove-if-not -;;; - - -(with-test-prefix "remove-if-not" - - (pass-if "documented?" - (documented? remove-if-not)) - - (pass-if "empty list, remove all" - (eq? (remove-if-not (lambda (x) #f) '()) '())) - - (pass-if "empty list, remove none" - (eq? (remove-if-not (lambda (x) #t) '()) '())) - - (pass-if "non-empty list, remove all" - (eq? (remove-if-not (lambda (x) #f) '(1 2 3 4)) '())) - - (pass-if "non-empty list, remove none" - (equal? (remove-if-not (lambda (x) #t) '(1 2 3 4)) '(1 2 3 4))) - - (pass-if "non-empty list, remove some" - (equal? (remove-if-not odd? '(1 2 3 4)) '(1 3))) - - ) - - -;;; -;;; delete-if! -;;; - - -(with-test-prefix "delete-if!" - - (pass-if "documented?" - (documented? delete-if!)) - - (pass-if "empty list, remove all" - (eq? (delete-if! (lambda (x) #t) '()) '())) - - (pass-if "empty list, remove none" - (eq? (delete-if! (lambda (x) #f) '()) '())) - - (pass-if "non-empty list, remove all" - (eq? (delete-if! (lambda (x) #t) '(1 2 3 4)) '())) - - (pass-if "non-empty list, remove none" - (equal? (delete-if! (lambda (x) #f) '(1 2 3 4)) '(1 2 3 4))) - - (pass-if "non-empty list, remove some" - (equal? (delete-if! odd? '(1 2 3 4)) '(2 4))) - - ) - - -;;; -;;; delete-if-not! -;;; - - -(with-test-prefix "delete-if-not!" - - (pass-if "documented?" - (documented? delete-if-not!)) - - (pass-if "empty list, remove all" - (eq? (delete-if-not! (lambda (x) #f) '()) '())) - - (pass-if "empty list, remove none" - (eq? (delete-if-not! (lambda (x) #t) '()) '())) - - (pass-if "non-empty list, remove all" - (eq? (delete-if-not! (lambda (x) #f) '(1 2 3 4)) '())) - - (pass-if "non-empty list, remove none" - (equal? (delete-if-not! (lambda (x) #t) '(1 2 3 4)) '(1 2 3 4))) - - (pass-if "non-empty list, remove some" - (equal? (delete-if-not! odd? '(1 2 3 4)) '(1 3))) - - ) diff --git a/test-suite/tests/dynamic-scope.test b/test-suite/tests/dynamic-scope.test deleted file mode 100644 index bb7e1adda..000000000 --- a/test-suite/tests/dynamic-scope.test +++ /dev/null @@ -1,78 +0,0 @@ -;;;; -*- scheme -*- -;;;; dynamic-scop.test --- test suite for dynamic scoping constructs -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (test-suite lib)) - -(define global-a 0) -(define (fetch-global-a) global-a) - -(with-test-prefix "dynamic scope" - - (pass-if "@bind binds" - (= (@bind ((global-a 1)) (fetch-global-a)) 1)) - - (pass-if "@bind unbinds" - (begin - (set! global-a 0) - (@bind ((global-a 1)) (fetch-global-a)) - (= global-a 0))) - - (pass-if-exception "duplicate @binds" - (cons 'misc-error "^duplicate bindings") - (@bind ((a 1) (a 2)) (+ a a))) - - (pass-if-exception "@bind missing expression" - (cons 'misc-error "^missing or extra expression") - (@bind ((global-a 1)))) - - (pass-if-exception "@bind bad bindings" - (cons 'misc-error "^bad bindings") - (@bind (a) #f)) - - (pass-if-exception "@bind bad bindings" - (cons 'misc-error "^bad bindings") - (@bind ((a)) #f)) - - (pass-if "@bind and dynamic-wind" - (letrec ((co-routine #f) - (spawn (lambda (proc) - (set! co-routine proc))) - (yield (lambda (val) - (call-with-current-continuation - (lambda (k) - (let ((next co-routine)) - (set! co-routine k) - (next val))))))) - - (spawn (lambda (val) - (@bind ((global-a 'inside)) - (yield global-a) - (yield global-a)))) - - (set! global-a 'outside) - (let ((inside-a (yield #f))) - (let ((outside-a global-a)) - (let ((inside-a2 (yield #f))) - (and (eq? inside-a 'inside) - (eq? outside-a 'outside) - (eq? inside-a2 'inside)))))))) - - - diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test deleted file mode 100644 index ab0039332..000000000 --- a/test-suite/tests/elisp.test +++ /dev/null @@ -1,355 +0,0 @@ -;;;; elisp.test --- tests guile's elisp support -*- scheme -*- -;;;; Copyright (C) 2002 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - -;;; -;;; elisp -;;; - -(if (defined? '%nil) - - (with-test-prefix "scheme" - - (with-test-prefix "nil value is a boolean" - - (pass-if "boolean?" - (boolean? %nil)) - - ) - - (with-test-prefix "nil value is false" - - (pass-if "not" - (eq? (not %nil) #t)) - - (pass-if "if" - (if %nil #f #t)) - - (pass-if "and" - (eq? (and %nil #t) #f)) - - (pass-if "or" - (eq? (or %nil #f) #f)) - - (pass-if "cond" - (cond (%nil #f) (else #t))) - - (pass-if "do" - (call-with-current-continuation - (lambda (exit) - (do ((i 0 (+ i 1))) - (%nil (exit #f)) - (if (> i 10) - (exit #t)))))) - - ) - - (with-test-prefix "nil value as an empty list" - - (pass-if "list?" - (list? %nil)) - - (pass-if "null?" - (null? %nil)) - - (pass-if "sort" - (eq? (sort %nil <) %nil)) - - ) - - (with-test-prefix "lists formed using nil value" - - (pass-if "list?" - (list? (cons 'a %nil))) - - (pass-if "length of %nil" - (= (length %nil) 0)) - - (pass-if "length" - (= (length (cons 'a (cons 'b (cons 'c %nil)))) 3)) - - (pass-if "length (with backquoted list)" - (= (length `(a b c . ,%nil)) 3)) - - (pass-if "write (%nil)" - (string=? (with-output-to-string - (lambda () (write %nil))) - "#nil")) ; Hmmm... should be "()" ? - - (pass-if "display (%nil)" - (string=? (with-output-to-string - (lambda () (display %nil))) - "#nil")) ; Ditto. - - (pass-if "write (list)" - (string=? (with-output-to-string - (lambda () (write (cons 'a %nil)))) - "(a)")) - - (pass-if "display (list)" - (string=? (with-output-to-string - (lambda () (display (cons 'a %nil)))) - "(a)")) - - (pass-if "assq" - (and (equal? (assq 1 `((1 one) (2 two) . ,%nil)) - '(1 one)) - (equal? (assq 3 `((1 one) (2 two) . ,%nil)) - #f))) - - (pass-if "assv" - (and (equal? (assv 1 `((1 one) (2 two) . ,%nil)) - '(1 one)) - (equal? (assv 3 `((1 one) (2 two) . ,%nil)) - #f))) - - (pass-if "assoc" - (and (equal? (assoc 1 `((1 one) (2 two) . ,%nil)) - '(1 one)) - (equal? (assoc 3 `((1 one) (2 two) . ,%nil)) - #f))) - - (pass-if "with-fluids*" - (let ((f (make-fluid)) - (g (make-fluid))) - (with-fluids* (cons f (cons g %nil)) - '(3 4) - (lambda () - (and (eq? (fluid-ref f) 3) - (eq? (fluid-ref g) 4)))))) - - (pass-if "append!" - (let ((a (copy-tree '(1 2 3))) - (b (copy-tree `(4 5 6 . ,%nil))) - (c (copy-tree '(7 8 9))) - (d (copy-tree `(a b c . ,%nil)))) - (equal? (append! a b c d) - `(1 2 3 4 5 6 7 8 9 a b c . ,%nil)))) - - (pass-if "last-pair" - (equal? (last-pair `(1 2 3 4 5 . ,%nil)) - (cons 5 %nil))) - - (pass-if "reverse" - (equal? (reverse `(1 2 3 4 5 . ,%nil)) - '(5 4 3 2 1))) ; Hmmm... is this OK, or - ; should it be - ; `(5 4 3 2 1 . ,%nil) ? - - (pass-if "reverse!" - (equal? (reverse! (copy-tree `(1 2 3 4 5 . ,%nil))) - '(5 4 3 2 1))) ; Ditto. - - (pass-if "list-ref" - (eq? (list-ref `(0 1 2 3 4 . ,%nil) 4) 4)) - - (pass-if-exception "list-ref" - exception:out-of-range - (eq? (list-ref `(0 1 2 3 4 . ,%nil) 6) 6)) - - (pass-if "list-set!" - (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) - (list-set! l 4 44) - (= (list-ref l 4) 44))) - - (pass-if-exception "list-set!" - exception:out-of-range - (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) - (list-set! l 6 44) - (= (list-ref l 6) 44))) - - (pass-if "list-cdr-set!" - (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) - (and (begin - (list-cdr-set! l 4 44) - (equal? l '(0 1 2 3 4 . 44))) - (begin - (list-cdr-set! l 3 `(new . ,%nil)) - (equal? l `(0 1 2 3 new . ,%nil)))))) - - (pass-if-exception "list-cdr-set!" - exception:out-of-range - (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) - (list-cdr-set! l 6 44))) - - (pass-if "memq" - (equal? (memq 'c `(a b c d . ,%nil)) `(c d . ,%nil))) - - (pass-if "memv" - (equal? (memv 'c `(a b c d . ,%nil)) `(c d . ,%nil))) - - (pass-if "member" - (equal? (member "c" `("a" "b" "c" "d" . ,%nil)) `("c" "d" . ,%nil))) - - (pass-if "list->vector" - (equal? #(1 2 3) (list->vector `(1 2 3 . ,%nil)))) - - (pass-if "list->vector" - (equal? #(1 2 3) (list->vector `(1 2 3 . ,%nil)))) - - (pass-if "list->weak-vector" - (equal? (weak-vector 1 2 3) (list->weak-vector `(1 2 3 . ,%nil)))) - - (pass-if "sorted?" - (and (sorted? `(1 2 3 . ,%nil) <) - (not (sorted? `(1 6 3 . ,%nil) <)))) - - (pass-if "merge" - (equal? (merge '(1 4 7 10) - (merge `(2 5 8 11 . ,%nil) - `(3 6 9 12 . ,%nil) - <) - <) - `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil))) - - (pass-if "merge!" - (equal? (merge! (copy-tree '(1 4 7 10)) - (merge! (copy-tree `(2 5 8 11 . ,%nil)) - (copy-tree `(3 6 9 12 . ,%nil)) - <) - <) - `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil))) - - (pass-if "sort" - (equal? (sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8))) - - (pass-if "stable-sort" - (equal? (stable-sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8))) - - (pass-if "sort!" - (equal? (sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <) - '(1 3 4 5 8))) - - (pass-if "stable-sort!" - (equal? (stable-sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <) - '(1 3 4 5 8))) - - ) - - (with-test-prefix "value preservation" - - (pass-if "car" - (eq? (car (cons %nil 'a)) %nil)) - - (pass-if "cdr" - (eq? (cdr (cons 'a %nil)) %nil)) - - (pass-if "vector-ref" - (eq? (vector-ref (vector %nil) 0) %nil)) - - ) - - )) - -(if (defined? '%nil) - (use-modules (lang elisp interface))) - -(if (defined? '%nil) - - (with-test-prefix "elisp" - - (define (elisp-pass-if expr expected) - (pass-if (with-output-to-string - (lambda () - (write expr))) - (let ((calc (with-output-to-string - (lambda () - (write (eval-elisp expr)))))) - (string=? calc expected)))) - - (elisp-pass-if '(and #f) "#f") - (elisp-pass-if '(and #t) "#t") - (elisp-pass-if '(and nil) "#nil") - (elisp-pass-if '(and t) "#t") - (elisp-pass-if '(and) "#t") - (elisp-pass-if '(cond (nil t) (t 3)) "3") - (elisp-pass-if '(cond (nil t) (t)) "#t") - (elisp-pass-if '(cond (nil)) "#nil") - (elisp-pass-if '(cond) "#nil") - (elisp-pass-if '(if #f 'a 'b) "b") - (elisp-pass-if '(if #t 'a 'b) "a") - (elisp-pass-if '(if '() 'a 'b) "b") - (elisp-pass-if '(if nil 'a 'b) "b") - (elisp-pass-if '(if nil 1 2 3 4) "4") - (elisp-pass-if '(if nil 1 2) "2") - (elisp-pass-if '(if nil 1) "#nil") - (elisp-pass-if '(if t 1 2) "1") - (elisp-pass-if '(if t 1) "1") - (elisp-pass-if '(let (a) a) "#nil") - (elisp-pass-if '(let* (a) a) "#nil") - (elisp-pass-if '(let* ((a 1) (b (* a 2))) b) "2") - (elisp-pass-if '(memq '() '(())) "(())") - (elisp-pass-if '(memq '() '(nil)) "(#nil)") - (elisp-pass-if '(memq '() '(t)) "#nil") - (elisp-pass-if '(memq nil '(())) "(())") - (elisp-pass-if '(memq nil '(nil)) "(#nil)") - (elisp-pass-if '(memq nil (list nil)) "(#nil)") - (elisp-pass-if '(null '#f) "#t") - (elisp-pass-if '(null '()) "#t") - (elisp-pass-if '(null 'nil) "#t") - (elisp-pass-if '(null nil) "#t") - (elisp-pass-if '(or 1 2 3) "1") - (elisp-pass-if '(or nil t nil) "#t") - (elisp-pass-if '(or nil) "#nil") - (elisp-pass-if '(or t nil t) "#t") - (elisp-pass-if '(or t) "#t") - (elisp-pass-if '(or) "#nil") - (elisp-pass-if '(prog1 1 2 3) "1") - (elisp-pass-if '(prog2 1 2 3) "2") - (elisp-pass-if '(progn 1 2 3) "3") - (elisp-pass-if '(while nil 1) "#nil") - - (elisp-pass-if '(defun testf (x y &optional o &rest r) (list x y o r)) "testf") - (elisp-pass-if '(testf 1 2) "(1 2 #nil #nil)") - (elisp-pass-if '(testf 1 2 3 4 5 56) "(1 2 3 (4 5 56))") - ;; NB `lambda' in Emacs is self-quoting, but that's only after - ;; loading the macro definition of lambda in subr.el. - (elisp-pass-if '(function (lambda (x y &optional o &rest r) (list x y o r))) "(lambda (x y &optional o &rest r) (list x y o r))") - (elisp-pass-if '(funcall (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 4) "(1 2 3 (4))") - (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 nil) "(1 2 3 #nil)") - - (elisp-pass-if '(setq x 3) "3") - (elisp-pass-if '(defvar x 4) "x") - (elisp-pass-if 'x "3") - - )) - -;;; elisp.test ends here diff --git a/test-suite/tests/environments.test b/test-suite/tests/environments.test deleted file mode 100644 index 507dff7fe..000000000 --- a/test-suite/tests/environments.test +++ /dev/null @@ -1,1070 +0,0 @@ -;;;; environments.test -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - -(use-modules (ice-9 documentation)) - - -;;; -;;; miscellaneous -;;; - -(define exception:unbound-symbol - (cons 'misc-error "^Symbol .* not bound in environment")) - -(define (documented? object) - (not (not (object-documentation object)))) - -(define (folder sym val res) - (cons (cons sym val) res)) - -(define (make-observer-func) - (let* ((counter 0)) - (lambda args - (if (null? args) - counter - (set! counter (+ counter 1)))))) - -(define (make-erroneous-observer-func) - (let* ((func (make-observer-func))) - (lambda args - (if (null? args) - (func) - (begin - (func args) - (error)))))) - -;;; -;;; leaf-environments -;;; - -(with-test-prefix "leaf-environments" - - (with-test-prefix "leaf-environment?" - - (pass-if "documented?" - (documented? leaf-environment?)) - - (pass-if "non-environment-object" - (not (leaf-environment? #f)))) - - - (with-test-prefix "make-leaf-environment" - - (pass-if "documented?" - (documented? make-leaf-environment)) - - (pass-if "produces an environment" - (environment? (make-leaf-environment))) - - (pass-if "produces a leaf-environment" - (leaf-environment? (make-leaf-environment))) - - (pass-if "produces always a new environment" - (not (eq? (make-leaf-environment) (make-leaf-environment))))) - - - (with-test-prefix "bound, define, ref, set!, cell" - - (pass-if "symbols are unbound by default" - (let* ((env (make-leaf-environment))) - (and (not (environment-bound? env 'a)) - (not (environment-bound? env 'b)) - (not (environment-bound? env 'c))))) - - (pass-if "symbol is bound after define" - (let* ((env (make-leaf-environment))) - (environment-bound? env 'a) - (environment-define env 'a #t) - (environment-bound? env 'a))) - - (pass-if "ref a defined symbol" - (let* ((env (make-leaf-environment))) - (environment-bound? env 'a) - (environment-bound? env 'b) - (environment-define env 'a #t) - (environment-define env 'b #f) - (and (environment-ref env 'a) - (not (environment-ref env 'b))))) - - (pass-if "set! a defined symbol" - (let* ((env (make-leaf-environment))) - (environment-define env 'a #t) - (environment-define env 'b #f) - (environment-ref env 'a) - (environment-ref env 'b) - (environment-set! env 'a #f) - (environment-set! env 'b #t) - (and (not (environment-ref env 'a)) - (environment-ref env 'b)))) - - (pass-if "get a read-only cell" - (let* ((env (make-leaf-environment))) - (environment-define env 'a #t) - (let* ((cell (environment-cell env 'a #f))) - (and (cdr cell) - (begin - (environment-set! env 'a #f) - (not (cdr cell))))))) - - (pass-if "a read-only cell gets rebound after define" - (let* ((env (make-leaf-environment))) - (environment-define env 'a #t) - (let* ((cell (environment-cell env 'a #f))) - (environment-define env 'a #f) - (not (eq? (environment-cell env 'a #f) cell))))) - - (pass-if "get a writable cell" - (let* ((env (make-leaf-environment))) - (environment-define env 'a #t) - (let* ((readable (environment-cell env 'a #f)) - (writable (environment-cell env 'a #t))) - (and (eq? readable writable) - (begin - (environment-set! env 'a #f) - (not (cdr writable))) - (begin - (set-cdr! writable #t) - (environment-ref env 'a)) - (begin - (set-cdr! (environment-cell env 'a #t) #f) - (not (cdr writable))))))) - - (pass-if "a writable cell gets rebound after define" - (let* ((env (make-leaf-environment))) - (environment-define env 'a #t) - (let* ((cell (environment-cell env 'a #t))) - (environment-define env 'a #f) - (not (eq? (environment-cell env 'a #t) cell))))) - - (pass-if-exception "reference an unbound symbol" - exception:unbound-symbol - (environment-ref (make-leaf-environment) 'a)) - - (pass-if-exception "set! an unbound symbol" - exception:unbound-symbol - (environment-set! (make-leaf-environment) 'a #f)) - - (pass-if-exception "get a readable cell for an unbound symbol" - exception:unbound-symbol - (environment-cell (make-leaf-environment) 'a #f)) - - (pass-if-exception "get a writable cell for an unbound symbol" - exception:unbound-symbol - (environment-cell (make-leaf-environment) 'a #t))) - - - (with-test-prefix "undefine" - - (pass-if "undefine a defined symbol" - (let* ((env (make-leaf-environment))) - (environment-define env 'a 1) - (environment-ref env 'a) - (environment-undefine env 'a) - (not (environment-bound? env 'a)))) - - (pass-if "undefine an already undefined symbol" - (environment-undefine (make-leaf-environment) 'a) - #t)) - - - (with-test-prefix "fold" - - (pass-if "empty environment" - (let* ((env (make-leaf-environment))) - (eq? 'success (environment-fold env folder 'success)))) - - (pass-if "one symbol" - (let* ((env (make-leaf-environment))) - (environment-define env 'a #t) - (equal? '((a . #t)) (environment-fold env folder '())))) - - (pass-if "two symbols" - (let* ((env (make-leaf-environment))) - (environment-define env 'a #t) - (environment-define env 'b #f) - (let ((folded (environment-fold env folder '()))) - (or (equal? folded '((a . #t) (b . #f))) - (equal? folded '((b . #f) (a . #t)))))))) - - - (with-test-prefix "observe" - - (pass-if "observe an environment" - (let* ((env (make-leaf-environment))) - (environment-observe env (make-observer-func)) - #t)) - - (pass-if "observe an environment twice" - (let* ((env (make-leaf-environment)) - (observer-1 (environment-observe env (make-observer-func))) - (observer-2 (environment-observe env (make-observer-func)))) - (not (eq? observer-1 observer-2)))) - - (pass-if "definition of an undefined symbol" - (let* ((env (make-leaf-environment)) - (func (make-observer-func))) - (environment-observe env func) - (environment-define env 'a 1) - (eqv? (func) 1))) - - (pass-if "definition of an already defined symbol" - (let* ((env (make-leaf-environment))) - (environment-define env 'a 1) - (let* ((func (make-observer-func))) - (environment-observe env func) - (environment-define env 'a 1) - (eqv? (func) 1)))) - - (pass-if "set!ing of a defined symbol" - (let* ((env (make-leaf-environment))) - (environment-define env 'a 1) - (let* ((func (make-observer-func))) - (environment-observe env func) - (environment-set! env 'a 1) - (eqv? (func) 0)))) - - (pass-if "undefining a defined symbol" - (let* ((env (make-leaf-environment))) - (environment-define env 'a 1) - (let* ((func (make-observer-func))) - (environment-observe env func) - (environment-undefine env 'a) - (eqv? (func) 1)))) - - (pass-if "undefining an already undefined symbol" - (let* ((env (make-leaf-environment)) - (func (make-observer-func))) - (environment-observe env func) - (environment-undefine env 'a) - (eqv? (func) 0))) - - (pass-if "unobserve an active observer" - (let* ((env (make-leaf-environment)) - (func (make-observer-func)) - (observer (environment-observe env func))) - (environment-unobserve observer) - (environment-define env 'a 1) - (eqv? (func) 0))) - - (pass-if "unobserve an inactive observer" - (let* ((env (make-leaf-environment)) - (func (make-observer-func)) - (observer (environment-observe env func))) - (environment-unobserve observer) - (environment-unobserve observer) - #t))) - - - (with-test-prefix "observe-weak" - - (pass-if "observe an environment" - (let* ((env (make-leaf-environment))) - (environment-observe-weak env (make-observer-func)) - #t)) - - (pass-if "observe an environment twice" - (let* ((env (make-leaf-environment)) - (observer-1 (environment-observe-weak env (make-observer-func))) - (observer-2 (environment-observe-weak env (make-observer-func)))) - (not (eq? observer-1 observer-2)))) - - (pass-if "definition of an undefined symbol" - (let* ((env (make-leaf-environment)) - (func (make-observer-func))) - (environment-observe-weak env func) - (environment-define env 'a 1) - (eqv? (func) 1))) - - (pass-if "definition of an already defined symbol" - (let* ((env (make-leaf-environment))) - (environment-define env 'a 1) - (let* ((func (make-observer-func))) - (environment-observe-weak env func) - (environment-define env 'a 1) - (eqv? (func) 1)))) - - (pass-if "set!ing of a defined symbol" - (let* ((env (make-leaf-environment))) - (environment-define env 'a 1) - (let* ((func (make-observer-func))) - (environment-observe-weak env func) - (environment-set! env 'a 1) - (eqv? (func) 0)))) - - (pass-if "undefining a defined symbol" - (let* ((env (make-leaf-environment))) - (environment-define env 'a 1) - (let* ((func (make-observer-func))) - (environment-observe-weak env func) - (environment-undefine env 'a) - (eqv? (func) 1)))) - - (pass-if "undefining an already undefined symbol" - (let* ((env (make-leaf-environment)) - (func (make-observer-func))) - (environment-observe-weak env func) - (environment-undefine env 'a) - (eqv? (func) 0))) - - (pass-if "unobserve an active observer" - (let* ((env (make-leaf-environment)) - (func (make-observer-func)) - (observer (environment-observe-weak env func))) - (environment-unobserve observer) - (environment-define env 'a 1) - (eqv? (func) 0))) - - (pass-if "unobserve an inactive observer" - (let* ((env (make-leaf-environment)) - (func (make-observer-func)) - (observer (environment-observe-weak env func))) - (environment-unobserve observer) - (environment-unobserve observer) - #t)) - - (pass-if "weak observer gets collected" - (gc) - (let* ((env (make-leaf-environment)) - (func (make-observer-func))) - (environment-observe-weak env func) - (gc) - (environment-define env 'a 1) - (if (not (eqv? (func) 0)) - (throw 'unresolved) ; note: conservative scanning - #t)))) - - - (with-test-prefix "erroneous observers" - - (pass-if "update continues after error" - (let* ((env (make-leaf-environment)) - (func-1 (make-erroneous-observer-func)) - (func-2 (make-erroneous-observer-func))) - (environment-observe env func-1) - (environment-observe env func-2) - (catch #t - (lambda () - (environment-define env 'a 1) - #f) - (lambda args - (and (eq? (func-1) 1) - (eq? (func-2) 1)))))))) - - -;;; -;;; leaf-environment based eval-environments -;;; - -(with-test-prefix "leaf-environment based eval-environments" - - (with-test-prefix "eval-environment?" - - (pass-if "documented?" - (documented? eval-environment?)) - - (pass-if "non-environment-object" - (not (eval-environment? #f))) - - (pass-if "leaf-environment-object" - (not (eval-environment? (make-leaf-environment))))) - - - (with-test-prefix "make-eval-environment" - - (pass-if "documented?" - (documented? make-eval-environment)) - - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment))) - - (pass-if "produces an environment" - (environment? (make-eval-environment local imported))) - - (pass-if "produces an eval-environment" - (eval-environment? (make-eval-environment local imported))) - - (pass-if "produces always a new environment" - (not (eq? (make-eval-environment local imported) - (make-eval-environment local imported)))))) - - - (with-test-prefix "eval-environment-local" - - (pass-if "documented?" - (documented? eval-environment-local)) - - (pass-if "returns local" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (eq? (eval-environment-local env) local)))) - - - (with-test-prefix "eval-environment-imported" - - (pass-if "documented?" - (documented? eval-environment-imported)) - - (pass-if "returns imported" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (eq? (eval-environment-imported env) imported)))) - - - (with-test-prefix "bound, define, ref, set!, cell" - - (pass-if "symbols are unbound by default" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (and (not (environment-bound? env 'a)) - (not (environment-bound? env 'b)) - (not (environment-bound? env 'c))))) - - (with-test-prefix "symbols bound in imported" - - (pass-if "binding is visible" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-bound? env 'a) - (environment-define imported 'a #t) - (environment-bound? env 'a))) - - (pass-if "ref works" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-bound? env 'a) - (environment-define imported 'a #t) - (environment-ref env 'a))) - - (pass-if "set! works" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define imported 'a #f) - (environment-set! env 'a #t) - (environment-ref imported 'a))) - - (pass-if "cells are passed through" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define imported 'a #t) - (let* ((imported-cell (environment-cell imported 'a #f)) - (env-cell (environment-cell env 'a #f))) - (eq? env-cell imported-cell))))) - - (with-test-prefix "symbols bound in local" - - (pass-if "binding is visible" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-bound? env 'a) - (environment-define local 'a #t) - (environment-bound? env 'a))) - - (pass-if "ref works" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define local 'a #t) - (environment-ref env 'a))) - - (pass-if "set! works" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define local 'a #f) - (environment-set! env 'a #t) - (environment-ref local 'a))) - - (pass-if "cells are passed through" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define local 'a #t) - (let* ((local-cell (environment-cell local 'a #f)) - (env-cell (environment-cell env 'a #f))) - (eq? env-cell local-cell))))) - - (with-test-prefix "symbols bound in local and imported" - - (pass-if "binding is visible" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-bound? env 'a) - (environment-define imported 'a #t) - (environment-define local 'a #f) - (environment-bound? env 'a))) - - (pass-if "ref works" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define imported 'a #f) - (environment-define local 'a #t) - (environment-ref env 'a))) - - (pass-if "set! changes local" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define imported 'a #f) - (environment-define local 'a #f) - (environment-set! env 'a #t) - (environment-ref local 'a))) - - (pass-if "set! does not touch imported" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define imported 'a #t) - (environment-define local 'a #t) - (environment-set! env 'a #f) - (environment-ref imported 'a))) - - (pass-if "cells from local are passed through" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define local 'a #t) - (let* ((local-cell (environment-cell local 'a #f)) - (env-cell (environment-cell env 'a #f))) - (eq? env-cell local-cell))))) - - (with-test-prefix "defining symbols" - - (pass-if "symbols are bound in local after define" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define env 'a #t) - (environment-bound? local 'a))) - - (pass-if "cells in local get rebound after define" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define env 'a #f) - (let* ((old-cell (environment-cell local 'a #f))) - (environment-define env 'a #f) - (let* ((new-cell (environment-cell local 'a #f))) - (not (eq? new-cell old-cell)))))) - - (pass-if "cells in imported get shadowed after define" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define imported 'a #f) - (environment-define env 'a #t) - (environment-ref local 'a)))) - - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - - (pass-if-exception "reference an unbound symbol" - exception:unbound-symbol - (environment-ref env 'b)) - - (pass-if-exception "set! an unbound symbol" - exception:unbound-symbol - (environment-set! env 'b #f)) - - (pass-if-exception "get a readable cell for an unbound symbol" - exception:unbound-symbol - (environment-cell env 'b #f)) - - (pass-if-exception "get a writable cell for an unbound symbol" - exception:unbound-symbol - (environment-cell env 'b #t)))) - - (with-test-prefix "eval-environment-set-local!" - - (pass-if "documented?" - (documented? eval-environment-set-local!)) - - (pass-if "new binding becomes visible" - (let* ((old-local (make-leaf-environment)) - (new-local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment old-local imported))) - (environment-bound? env 'a) - (environment-define new-local 'a #t) - (eval-environment-set-local! env new-local) - (environment-bound? env 'a))) - - (pass-if "existing binding is replaced" - (let* ((old-local (make-leaf-environment)) - (new-local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment old-local imported))) - (environment-define old-local 'a #f) - (environment-ref env 'a) - (environment-define new-local 'a #t) - (eval-environment-set-local! env new-local) - (environment-ref env 'a))) - - (pass-if "undefined binding is removed" - (let* ((old-local (make-leaf-environment)) - (new-local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment old-local imported))) - (environment-define old-local 'a #f) - (environment-ref env 'a) - (eval-environment-set-local! env new-local) - (not (environment-bound? env 'a)))) - - (pass-if "binding in imported remains shadowed" - (let* ((old-local (make-leaf-environment)) - (new-local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment old-local imported))) - (environment-define imported 'a #f) - (environment-define old-local 'a #f) - (environment-ref env 'a) - (environment-define new-local 'a #t) - (eval-environment-set-local! env new-local) - (environment-ref env 'a))) - - (pass-if "binding in imported gets shadowed" - (let* ((old-local (make-leaf-environment)) - (new-local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment old-local imported))) - (environment-define imported 'a #f) - (environment-ref env 'a) - (environment-define new-local 'a #t) - (eval-environment-set-local! env new-local) - (environment-ref env 'a))) - - (pass-if "binding in imported becomes visible" - (let* ((old-local (make-leaf-environment)) - (new-local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment old-local imported))) - (environment-define imported 'a #t) - (environment-define old-local 'a #f) - (environment-ref env 'a) - (eval-environment-set-local! env new-local) - (environment-ref env 'a)))) - - (with-test-prefix "eval-environment-set-imported!" - - (pass-if "documented?" - (documented? eval-environment-set-imported!)) - - (pass-if "new binding becomes visible" - (let* ((local (make-leaf-environment)) - (old-imported (make-leaf-environment)) - (new-imported (make-leaf-environment)) - (env (make-eval-environment local old-imported))) - (environment-bound? env 'a) - (environment-define new-imported 'a #t) - (eval-environment-set-imported! env new-imported) - (environment-bound? env 'a))) - - (pass-if "existing binding is replaced" - (let* ((local (make-leaf-environment)) - (old-imported (make-leaf-environment)) - (new-imported (make-leaf-environment)) - (env (make-eval-environment local old-imported))) - (environment-define old-imported 'a #f) - (environment-ref env 'a) - (environment-define new-imported 'a #t) - (eval-environment-set-imported! env new-imported) - (environment-ref env 'a))) - - (pass-if "undefined binding is removed" - (let* ((local (make-leaf-environment)) - (old-imported (make-leaf-environment)) - (new-imported (make-leaf-environment)) - (env (make-eval-environment local old-imported))) - (environment-define old-imported 'a #f) - (environment-ref env 'a) - (eval-environment-set-imported! env new-imported) - (not (environment-bound? env 'a)))) - - (pass-if "binding in imported remains shadowed" - (let* ((local (make-leaf-environment)) - (old-imported (make-leaf-environment)) - (new-imported (make-leaf-environment)) - (env (make-eval-environment local old-imported))) - (environment-define local 'a #t) - (environment-define old-imported 'a #f) - (environment-ref env 'a) - (environment-define new-imported 'a #t) - (eval-environment-set-imported! env new-imported) - (environment-ref env 'a))) - - (pass-if "binding in imported gets shadowed" - (let* ((local (make-leaf-environment)) - (old-imported (make-leaf-environment)) - (new-imported (make-leaf-environment)) - (env (make-eval-environment local old-imported))) - (environment-define local 'a #t) - (environment-ref env 'a) - (environment-define new-imported 'a #f) - (eval-environment-set-imported! env new-imported) - (environment-ref env 'a)))) - - (with-test-prefix "undefine" - - (pass-if "undefine an already undefined symbol" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-undefine env 'a) - #t)) - - (pass-if "undefine removes a binding from local" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define local 'a #t) - (environment-undefine env 'a) - (not (environment-bound? local 'a)))) - - (pass-if "undefine does not influence imported" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define imported 'a #t) - (environment-undefine env 'a) - (environment-bound? imported 'a))) - - (pass-if "undefine an imported symbol does not undefine it" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define imported 'a #t) - (environment-undefine env 'a) - (environment-bound? env 'a))) - - (pass-if "undefine unshadows an imported symbol" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define imported 'a #t) - (environment-define local 'a #f) - (environment-undefine env 'a) - (environment-ref env 'a)))) - - (with-test-prefix "fold" - - (pass-if "empty environment" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (eq? 'success (environment-fold env folder 'success)))) - - (pass-if "one symbol in local" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define local 'a #t) - (equal? '((a . #t)) (environment-fold env folder '())))) - - (pass-if "one symbol in imported" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define imported 'a #t) - (equal? '((a . #t)) (environment-fold env folder '())))) - - (pass-if "shadowed symbol" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define local 'a #t) - (environment-define imported 'a #f) - (equal? '((a . #t)) (environment-fold env folder '())))) - - (pass-if "one symbol each" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define local 'a #t) - (environment-define imported 'b #f) - (let ((folded (environment-fold env folder '()))) - (or (equal? folded '((a . #t) (b . #f))) - (equal? folded '((b . #f) (a . #t)))))))) - - - (with-test-prefix "observe" - - (pass-if "observe an environment" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-observe env (make-observer-func)) - #t)) - - (pass-if "observe an environment twice" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported)) - (observer-1 (environment-observe env (make-observer-func))) - (observer-2 (environment-observe env (make-observer-func)))) - (not (eq? observer-1 observer-2)))) - - (pass-if "definition of an undefined symbol" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported)) - (func (make-observer-func))) - (environment-observe env func) - (environment-define env 'a 1) - (eqv? (func) 1))) - - (pass-if "definition of an already defined symbol" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define env 'a 1) - (let* ((func (make-observer-func))) - (environment-observe env func) - (environment-define env 'a 1) - (eqv? (func) 1)))) - - (pass-if "set!ing of a defined symbol" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define env 'a 1) - (let* ((func (make-observer-func))) - (environment-observe env func) - (environment-set! env 'a 1) - (eqv? (func) 0)))) - - (pass-if "undefining a defined symbol" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define env 'a 1) - (let* ((func (make-observer-func))) - (environment-observe env func) - (environment-undefine env 'a) - (eqv? (func) 1)))) - - (pass-if "undefining an already undefined symbol" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported)) - (func (make-observer-func))) - (environment-observe env func) - (environment-undefine env 'a) - (eqv? (func) 0))) - - (pass-if "unobserve an active observer" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported)) - (func (make-observer-func)) - (observer (environment-observe env func))) - (environment-unobserve observer) - (environment-define env 'a 1) - (eqv? (func) 0))) - - (pass-if "unobserve an inactive observer" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported)) - (func (make-observer-func)) - (observer (environment-observe env func))) - (environment-unobserve observer) - (environment-unobserve observer) - #t))) - - - (with-test-prefix "observe-weak" - - (pass-if "observe an environment" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-observe-weak env (make-observer-func)) - #t)) - - (pass-if "observe an environment twice" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported)) - (observer-1 (environment-observe-weak env (make-observer-func))) - (observer-2 (environment-observe-weak env (make-observer-func)))) - (not (eq? observer-1 observer-2)))) - - (pass-if "definition of an undefined symbol" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported)) - (func (make-observer-func))) - (environment-observe-weak env func) - (environment-define env 'a 1) - (eqv? (func) 1))) - - (pass-if "definition of an already defined symbol" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define env 'a 1) - (let* ((func (make-observer-func))) - (environment-observe-weak env func) - (environment-define env 'a 1) - (eqv? (func) 1)))) - - (pass-if "set!ing of a defined symbol" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define env 'a 1) - (let* ((func (make-observer-func))) - (environment-observe-weak env func) - (environment-set! env 'a 1) - (eqv? (func) 0)))) - - (pass-if "undefining a defined symbol" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (environment-define env 'a 1) - (let* ((func (make-observer-func))) - (environment-observe-weak env func) - (environment-undefine env 'a) - (eqv? (func) 1)))) - - (pass-if "undefining an already undefined symbol" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported)) - (func (make-observer-func))) - (environment-observe-weak env func) - (environment-undefine env 'a) - (eqv? (func) 0))) - - (pass-if "unobserve an active observer" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported)) - (func (make-observer-func)) - (observer (environment-observe-weak env func))) - (environment-unobserve observer) - (environment-define env 'a 1) - (eqv? (func) 0))) - - (pass-if "unobserve an inactive observer" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported)) - (func (make-observer-func)) - (observer (environment-observe-weak env func))) - (environment-unobserve observer) - (environment-unobserve observer) - #t)) - - (pass-if "weak observer gets collected" - (gc) - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported)) - (func (make-observer-func))) - (environment-observe-weak env func) - (gc) - (environment-define env 'a 1) - (if (not (eqv? (func) 0)) - (throw 'unresolved) ; note: conservative scanning - #t)))) - - - (with-test-prefix "erroneous observers" - - (pass-if "update continues after error" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported)) - (func-1 (make-erroneous-observer-func)) - (func-2 (make-erroneous-observer-func))) - (environment-observe env func-1) - (environment-observe env func-2) - (catch #t - (lambda () - (environment-define env 'a 1) - #f) - (lambda args - (and (eq? (func-1) 1) - (eq? (func-2) 1)))))))) - - -;;; -;;; leaf-environment based import-environments -;;; - -(with-test-prefix "leaf-environment based import-environments" - - (with-test-prefix "import-environment?" - - (pass-if "documented?" - (documented? import-environment?)) - - (pass-if "non-environment-object" - (not (import-environment? #f))) - - (pass-if "leaf-environment-object" - (not (import-environment? (make-leaf-environment)))) - - (pass-if "eval-environment-object" - (let* ((local (make-leaf-environment)) - (imported (make-leaf-environment)) - (env (make-eval-environment local imported))) - (not (import-environment? (make-leaf-environment)))))) - - - (with-test-prefix "make-import-environment" - - (pass-if "documented?" - (documented? make-import-environment)))) - diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test deleted file mode 100644 index fc97fa5a9..000000000 --- a/test-suite/tests/eval.test +++ /dev/null @@ -1,248 +0,0 @@ -;;;; eval.test --- tests guile's evaluator -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - -(use-modules (ice-9 documentation)) - - -;;; -;;; miscellaneous -;;; - -(define (documented? object) - (not (not (object-documentation object)))) - - -;;; -;;; eval -;;; - -(with-test-prefix "evaluator" - - (with-test-prefix "memoization" - - (pass-if "transparency" - (let ((x '(begin 1))) - (eval x (current-module)) - (equal? '(begin 1) x)))) - - (with-test-prefix "symbol lookup" - - (with-test-prefix "top level" - - (with-test-prefix "unbound" - - (pass-if-exception "variable reference" - exception:unbound-var - x) - - (pass-if-exception "procedure" - exception:unbound-var - (x))))) - - (with-test-prefix "parameter error" - - ;; This is currently a bug in guile: - ;; Macros are accepted as function parameters. - ;; Functions that 'apply' macros are rewritten!!! - - (expect-fail-exception "macro as argument" - exception:wrong-type-arg - (let ((f (lambda (p a b) (p a b)))) - (f and #t #t))) - - (expect-fail-exception "passing macro as parameter" - exception:wrong-type-arg - (let* ((f (lambda (p a b) (p a b))) - (foo (procedure-source f))) - (f and #t #t) - (equal? (procedure-source f) foo))) - - )) - -;;; -;;; apply -;;; - -(with-test-prefix "application" - - (with-test-prefix "wrong number of arguments" - - (pass-if-exception "((lambda () #f) 1)" - exception:wrong-num-args - ((lambda () #f) 1)) - - (pass-if-exception "((lambda (x) #f))" - exception:wrong-num-args - ((lambda (x) #f))) - - (pass-if-exception "((lambda (x) #f) 1 2)" - exception:wrong-num-args - ((lambda (x) #f) 1 2)) - - (pass-if-exception "((lambda (x y) #f))" - exception:wrong-num-args - ((lambda (x y) #f))) - - (pass-if-exception "((lambda (x y) #f) 1)" - exception:wrong-num-args - ((lambda (x y) #f) 1)) - - (pass-if-exception "((lambda (x y) #f) 1 2 3)" - exception:wrong-num-args - ((lambda (x y) #f) 1 2 3)) - - (pass-if-exception "((lambda (x . rest) #f))" - exception:wrong-num-args - ((lambda (x . rest) #f))) - - (pass-if-exception "((lambda (x y . rest) #f))" - exception:wrong-num-args - ((lambda (x y . rest) #f))) - - (pass-if-exception "((lambda (x y . rest) #f) 1)" - exception:wrong-num-args - ((lambda (x y . rest) #f) 1)))) - -;;; -;;; map -;;; - -(with-test-prefix "map" - - ;; Is documentation available? - - (expect-fail "documented?" - (documented? map)) - - (with-test-prefix "argument error" - - (with-test-prefix "non list argument" - #t) - - (with-test-prefix "different length lists" - - (pass-if-exception "first list empty" - exception:out-of-range - (map + '() '(1))) - - (pass-if-exception "second list empty" - exception:out-of-range - (map + '(1) '())) - - (pass-if-exception "first list shorter" - exception:out-of-range - (map + '(1) '(2 3))) - - (pass-if-exception "second list shorter" - exception:out-of-range - (map + '(1 2) '(3))) - ))) - -;;; -;;; promises -;;; - -(with-test-prefix "promises" - - (with-test-prefix "basic promise behaviour" - - (pass-if "delay gives a promise" - (promise? (delay 1))) - - (pass-if "force evaluates a promise" - (eqv? (force (delay (+ 1 2))) 3)) - - (pass-if "a forced promise is a promise" - (let ((p (delay (+ 1 2)))) - (force p) - (promise? p))) - - (pass-if "forcing a forced promise works" - (let ((p (delay (+ 1 2)))) - (force p) - (eqv? (force p) 3))) - - (pass-if "a promise is evaluated once" - (let* ((x 1) - (p (delay (+ x 1)))) - (force p) - (set! x (+ x 1)) - (eqv? (force p) 2))) - - (pass-if "a promise may call itself" - (define p - (let ((x 0)) - (delay - (begin - (set! x (+ x 1)) - (if (> x 1) x (force p)))))) - (eqv? (force p) 2)) - - (pass-if "a promise carries its environment" - (let* ((x 1) (p #f)) - (let* ((x 2)) - (set! p (delay (+ x 1)))) - (eqv? (force p) 3))) - - (pass-if "a forced promise does not reference its environment" - (let* ((g (make-guardian)) - (p #f)) - (let* ((x (cons #f #f))) - (g x) - (set! p (delay (car x)))) - (force p) - (gc) - (if (not (equal? (g) (cons #f #f))) - (throw 'unresolved) - #t)))) - - (with-test-prefix "extended promise behaviour" - - (pass-if-exception "forcing a non-promise object is not supported" - exception:wrong-type-arg - (force 1)) - - (pass-if-exception "implicit forcing is not supported" - exception:wrong-type-arg - (+ (delay (* 3 7)) 13)))) - -;;; eval.test ends here diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test deleted file mode 100644 index 6e3c0d9cd..000000000 --- a/test-suite/tests/exceptions.test +++ /dev/null @@ -1,86 +0,0 @@ -;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*- -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - - -(with-test-prefix "throw/catch" - - (with-test-prefix "wrong type argument" - - (pass-if-exception "(throw 1)" - exception:wrong-type-arg - (throw 1))) - - (with-test-prefix "wrong number of arguments" - - (pass-if-exception "(throw)" - exception:wrong-num-args - (throw)) - - (pass-if-exception "throw 1 / catch 0" - exception:wrong-num-args - (catch 'a - (lambda () (throw 'a)) - (lambda () #f))) - - (pass-if-exception "throw 2 / catch 1" - exception:wrong-num-args - (catch 'a - (lambda () (throw 'a 2)) - (lambda (x) #f))) - - (pass-if-exception "throw 1 / catch 2" - exception:wrong-num-args - (catch 'a - (lambda () (throw 'a)) - (lambda (x y) #f))) - - (pass-if-exception "throw 3 / catch 2" - exception:wrong-num-args - (catch 'a - (lambda () (throw 'a 2 3)) - (lambda (y x) #f))) - - (pass-if-exception "throw 1 / catch 2+" - exception:wrong-num-args - (catch 'a - (lambda () (throw 'a)) - (lambda (x y . rest) #f))))) diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test deleted file mode 100644 index dd740579b..000000000 --- a/test-suite/tests/format.test +++ /dev/null @@ -1,39 +0,0 @@ -;;;; format.test --- test suite for Guile's CL-ish format -*- scheme -*- -;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001 -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (test-suite lib) - (ice-9 format)) - -;;; FORMAT Basic Output - -(with-test-prefix "format basic output" - (pass-if "format ~% produces a new line" - (string=? (format "~%") "\n")) - (pass-if "format ~& starts a fresh line" - (string=? (format "~&abc~&~&") "abc\n")) - (pass-if "format ~& is stateless but works properly across outputs via port-column" - (string=? - (with-output-to-string - (lambda () - (display "xyz") - (format #t "~&abc") - (format #f "~&") ; shall have no effect - (format #t "~&~&"))) - "xyz\nabc\n"))) diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test deleted file mode 100644 index 2617eff69..000000000 --- a/test-suite/tests/gc.test +++ /dev/null @@ -1,67 +0,0 @@ -;;;; gc.test --- test guile's garbage collection -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - -(use-modules (ice-9 documentation)) - - -;;; -;;; miscellaneous -;;; - - -(define (documented? object) - (not (not (object-documentation object)))) - - -;;; -;;; -;;; - -(with-test-prefix "gc" - - (pass-if "after-gc-hook gets called" - (let* ((foo #f) - (thunk (lambda () (set! foo #t)))) - (add-hook! after-gc-hook thunk) - (gc) - (remove-hook! after-gc-hook thunk) - foo))) diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test deleted file mode 100644 index fcfe8905f..000000000 --- a/test-suite/tests/getopt-long.test +++ /dev/null @@ -1,274 +0,0 @@ -;;;; getopt-long.test --- long options processing -*- scheme -*- -;;;; Thien-Thi Nguyen <ttn@gnu.org> --- August 2001 -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (test-suite lib) - (ice-9 getopt-long) - (ice-9 regex)) - -(defmacro deferr (name-frag re) - (let ((name (symbol-append 'exception: name-frag))) - `(define ,name (cons 'misc-error ,re)))) - -(deferr no-such-option "^no such option") -(deferr option-predicate-failed "^option predicate failed") -(deferr option-does-not-support-arg "^option does not support argument") -(deferr option-must-be-specified "^option must be specified") -(deferr option-must-have-arg "^option must be specified with argument") - -(with-test-prefix "exported procs" - (pass-if "`option-ref' defined" (defined? 'option-ref)) - (pass-if "`getopt-long' defined" (defined? 'getopt-long))) - -(with-test-prefix "specifying predicate" - - (define (test1 . args) - (getopt-long args - `((test (value #t) - (predicate ,(lambda (x) - (string-match "^[0-9]+$" x))))))) - - (pass-if "valid arg" - (equal? (test1 "foo" "bar" "--test=123") - '((() "bar") (test . "123")))) - - (pass-if-exception "invalid arg" - exception:option-predicate-failed - (test1 "foo" "bar" "--test=foo")) - - (pass-if-exception "option has no arg" - exception:option-must-have-arg - (test1 "foo" "bar" "--test")) - - ) - -(with-test-prefix "not specifying predicate" - - (define (test2 . args) - (getopt-long args `((test (value #t))))) - - (pass-if "option has arg" - (equal? (test2 "foo" "bar" "--test=foo") - '((() "bar") (test . "foo")))) - - (pass-if "option has no arg" - (equal? (test2 "foo" "bar") - '((() "bar")))) - - ) - -(with-test-prefix "value optional" - - (define (test3 . args) - (getopt-long args '((foo (value optional) (single-char #\f)) - (bar)))) - - (pass-if "long option `foo' w/ arg, long option `bar'" - (equal? (test3 "prg" "--foo" "fooval" "--bar") - '((()) (bar . #t) (foo . "fooval")))) - - (pass-if "short option `foo' w/ arg, long option `bar'" - (equal? (test3 "prg" "-f" "fooval" "--bar") - '((()) (bar . #t) (foo . "fooval")))) - - (pass-if "short option `foo', long option `bar', no args" - (equal? (test3 "prg" "-f" "--bar") - '((()) (bar . #t) (foo . #t)))) - - (pass-if "long option `foo', long option `bar', no args" - (equal? (test3 "prg" "--foo" "--bar") - '((()) (bar . #t) (foo . #t)))) - - (pass-if "long option `bar', short option `foo', no args" - (equal? (test3 "prg" "--bar" "-f") - '((()) (foo . #t) (bar . #t)))) - - (pass-if "long option `bar', long option `foo', no args" - (equal? (test3 "prg" "--bar" "--foo") - '((()) (foo . #t) (bar . #t)))) - - ) - -(with-test-prefix "option-ref" - - (define (test4 option-arg . args) - (equal? option-arg (option-ref (getopt-long - (cons "prog" args) - '((foo - (value optional) - (single-char #\f)) - (bar))) - 'foo #f))) - - (pass-if "option-ref `--foo 4'" - (test4 "4" "--foo" "4")) - - (pass-if "option-ref `-f 4'" - (test4 "4" "-f" "4")) - - (pass-if "option-ref `-f4'" - (test4 "4" "-f4")) - - (pass-if "option-ref `--foo=4'" - (test4 "4" "--foo=4")) - - ) - -(with-test-prefix "required" - - (define (test5 args specs) - (getopt-long (cons "foo" args) specs)) - - (pass-if "not mentioned, not given" - (equal? (test5 '() '()) - '((())))) - - (pass-if-exception "not mentioned, given" - exception:no-such-option - (test5 '("--req") '((something)))) - - (pass-if "not specified required, not given" - (equal? (test5 '() '((req (required? #f)))) - '((())))) - - (pass-if "not specified required, given anyway" - (equal? (test5 '("--req") '((req (required? #f)))) - '((()) (req . #t)))) - - (pass-if "not specified required, but w/ value, given anyway w/ \"=\" val" - (equal? (test5 '("--req=7") '((req (required? #f) (value #t)))) - '((()) (req . "7")))) - - (pass-if "not specified required, but w/ value, given anyway w/ non-\"=\" val" - (equal? (test5 '("--req" "7") '((req (required? #f) (value #t)))) - '((()) (req . "7")))) - - (pass-if-exception "specified required, not given" - exception:option-must-be-specified - (test5 '() '((req (required? #t))))) - - ) - -(with-test-prefix "specified no-value, given anyway" - - (define (test6 args specs) - (getopt-long (cons "foo" args) specs)) - - (pass-if-exception "using \"=\" syntax" - exception:option-does-not-support-arg - (test6 '("--maybe=yes") '((maybe)))) - - ) - -(with-test-prefix "specified arg required" - - (define (test7 args) - (getopt-long (cons "foo" args) '((hmm (value #t) (single-char #\H)) - (ignore)))) - - (pass-if "short opt, arg given" - (equal? (test7 '("-H" "99")) - '((()) (hmm . "99")))) - - (pass-if "long non-\"=\" opt, arg given" - (equal? (test7 '("--hmm" "100")) - '((()) (hmm . "100")))) - - (pass-if "long \"=\" opt, arg given" - (equal? (test7 '("--hmm=101")) - '((()) (hmm . "101")))) - - (pass-if-exception "short opt, arg not given" - exception:option-must-have-arg - (test7 '("-H"))) - - (pass-if-exception "long non-\"=\" opt, arg not given (next arg an option)" - exception:option-must-have-arg - (test7 '("--hmm" "--ignore"))) - - (pass-if-exception "long \"=\" opt, arg not given" - exception:option-must-have-arg - (test7 '("--hmm"))) - - ) - -(with-test-prefix "apples-blimps-catalexis example" - - (define (test8 . args) - (equal? (sort (getopt-long (cons "foo" args) - '((apples (single-char #\a)) - (blimps (single-char #\b) (value #t)) - (catalexis (single-char #\c) (value #t)))) - (lambda (a b) - (cond ((null? (car a)) #t) - ((null? (car b)) #f) - (else (string<? (symbol->string (car a)) - (symbol->string (car b))))))) - '((()) - (apples . #t) - (blimps . "bang") - (catalexis . "couth")))) - - (pass-if "normal 1" (test8 "-a" "-b" "bang" "-c" "couth")) - (pass-if "normal 2" (test8 "-ab" "bang" "-c" "couth")) - (pass-if "normal 3" (test8 "-ac" "couth" "-b" "bang")) - - (pass-if-exception "bad ordering causes missing option" - exception:option-must-have-arg - (test8 "-abc" "couth" "bang")) - - ) - -(with-test-prefix "multiple occurrances" - - (define (test9 . args) - (equal? (getopt-long (cons "foo" args) - '((inc (single-char #\I) (value #t)) - (foo (single-char #\f)))) - '((()) (inc . "2") (foo . #t) (inc . "1")))) - - ;; terminology: - ;; sf -- single-char free - ;; sa -- single-char abutted - ;; lf -- long free - ;; la -- long abutted (using "=") - - (pass-if "sf/sf" (test9 "-I" "1" "-f" "-I" "2")) - (pass-if "sa/sa" (test9 "-I1" "-f" "-I2")) - (pass-if "sf/sa" (test9 "-I" "1" "-f" "-I2")) - (pass-if "sa/sf" (test9 "-I1" "-f" "-I" "2")) - - (pass-if "lf/lf" (test9 "--inc" "1" "-f" "--inc" "2")) - (pass-if "la/la" (test9 "--inc=1" "-f" "--inc=2")) - (pass-if "lf/la" (test9 "--inc" "1" "-f" "--inc=2")) - (pass-if "la/lf" (test9 "--inc=1" "-f" "--inc" "2")) - - (pass-if "sf/lf" (test9 "-I" "1" "-f" "--inc" "2")) - (pass-if "lf/sf" (test9 "--inc" "1" "-f" "-I" "2")) - (pass-if "sf/la" (test9 "-I" "1" "-f" "--inc=2")) - (pass-if "la/sf" (test9 "--inc=1" "-f" "-I" "2")) - - (pass-if "sa/lf" (test9 "-I1" "-f" "--inc" "2")) - (pass-if "lf/sa" (test9 "--inc" "1" "-f" "-I2")) - (pass-if "sa/la" (test9 "-I1" "-f" "--inc=2")) - (pass-if "la/sa" (test9 "--inc=1" "-f" "-I2")) - - ) - -;;; getopt-long.test ends here diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test deleted file mode 100644 index 08f1f58ac..000000000 --- a/test-suite/tests/goops.test +++ /dev/null @@ -1,169 +0,0 @@ -;;;; goops.test --- test suite for GOOPS -*- scheme -*- -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (test-suite lib)) - -(pass-if "GOOPS loads" - (false-if-exception - (begin (resolve-module '(oop goops)) - #t))) - -(use-modules (oop goops)) - -;;; more tests here... - -(with-test-prefix "basic classes" - - (with-test-prefix "<top>" - - (pass-if "instance?" - (instance? <top>)) - - (pass-if "class-of" - (eq? (class-of <top>) <class>)) - - (pass-if "is a class?" - (is-a? <top> <class>)) - - (pass-if "class-name" - (eq? (class-name <top>) '<top>)) - - (pass-if "direct superclasses" - (equal? (class-direct-supers <top>) '())) - - (pass-if "superclasses" - (equal? (class-precedence-list <top>) (list <top>))) - - (pass-if "direct slots" - (equal? (class-direct-slots <top>) '())) - - (pass-if "slots" - (equal? (class-slots <top>) '()))) - - (with-test-prefix "<object>" - - (pass-if "instance?" - (instance? <object>)) - - (pass-if "class-of" - (eq? (class-of <object>) <class>)) - - (pass-if "is a class?" - (is-a? <object> <class>)) - - (pass-if "class-name" - (eq? (class-name <object>) '<object>)) - - (pass-if "direct superclasses" - (equal? (class-direct-supers <object>) (list <top>))) - - (pass-if "superclasses" - (equal? (class-precedence-list <object>) (list <object> <top>))) - - (pass-if "direct slots" - (equal? (class-direct-slots <object>) '())) - - (pass-if "slots" - (equal? (class-slots <object>) '()))) - - (with-test-prefix "<class>" - - (pass-if "instance?" - (instance? <class>)) - - (pass-if "class-of" - (eq? (class-of <class>) <class>)) - - (pass-if "is a class?" - (is-a? <class> <class>)) - - (pass-if "class-name" - (eq? (class-name <class>) '<class>)) - - (pass-if "direct superclass" - (equal? (class-direct-supers <class>) (list <object>))))) - -(with-test-prefix "defining classes" - - (with-test-prefix "define-class" - - (pass-if "creating a new binding" - (eval '(define <foo> #f) (current-module)) - (eval '(undefine <foo>) (current-module)) - (eval '(define-class <foo> ()) (current-module)) - (eval '(is-a? <foo> <class>) (current-module))) - - (pass-if "overwriting a binding to a non-class" - (eval '(define <foo> #f) (current-module)) - (eval '(define-class <foo> ()) (current-module)) - (eval '(is-a? <foo> <class>) (current-module))))) - -(with-test-prefix "defining generics" - - (with-test-prefix "define-generic" - - (pass-if "creating a new top-level binding" - (eval '(define foo #f) (current-module)) - (eval '(undefine foo) (current-module)) - (eval '(define-generic foo) (current-module)) - (eval '(and (is-a? foo <generic>) - (null? (generic-function-methods foo))) - (current-module))) - - (pass-if "overwriting a top-level binding to a non-generic" - (eval '(define (foo) #f) (current-module)) - (eval '(define-generic foo) (current-module)) - (eval '(and (is-a? foo <generic>) - (= 1 (length (generic-function-methods foo)))) - (current-module))) - - (pass-if "overwriting a top-level binding to a generic" - (eval '(define (foo) #f) (current-module)) - (eval '(define-generic foo) (current-module)) - (eval '(define-generic foo) (current-module)) - (eval '(and (is-a? foo <generic>) - (null? (generic-function-methods foo))) - (current-module))))) - -(with-test-prefix "defining accessors" - - (with-test-prefix "define-accessor" - - (pass-if "creating a new top-level binding" - (eval '(define foo #f) (current-module)) - (eval '(undefine foo) (current-module)) - (eval '(define-accessor foo) (current-module)) - (eval '(and (is-a? foo <generic-with-setter>) - (null? (generic-function-methods foo))) - (current-module))) - - (pass-if "overwriting a top-level binding to a non-accessor" - (eval '(define (foo) #f) (current-module)) - (eval '(define-accessor foo) (current-module)) - (eval '(and (is-a? foo <generic-with-setter>) - (= 1 (length (generic-function-methods foo)))) - (current-module))) - - (pass-if "overwriting a top-level binding to an accessor" - (eval '(define (foo) #f) (current-module)) - (eval '(define-accessor foo) (current-module)) - (eval '(define-accessor foo) (current-module)) - (eval '(and (is-a? foo <generic-with-setter>) - (null? (generic-function-methods foo))) - (current-module))))) diff --git a/test-suite/tests/guardians.test b/test-suite/tests/guardians.test deleted file mode 100644 index 8fc42c2f6..000000000 --- a/test-suite/tests/guardians.test +++ /dev/null @@ -1,65 +0,0 @@ -;;;; guardians.test --- test suite for Guile Guardians -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- July 1999 -;;;; -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -;;; These tests make some questionable assumptions. -;;; - They assume that a GC will find all dead objects, so they -;;; will become flaky if we have a generational GC. -;;; - They assume that objects won't be saved by the guardian until -;;; they explicitly invoke GC --- in other words, they assume that GC -;;; won't happen too often. - -(gc) - -(define g1 (make-guardian)) -(define not-g1-garbage (list 'not-g1-garbage)) -(g1 not-g1-garbage) -(g1 (list 'g1-garbage)) -(pass-if "g1-garbage not collected yet" (equal? (g1) #f)) -(gc) -(pass-if "g1-garbage saved" (equal? (g1) '(g1-garbage))) - -;;; Who guards the guardian? -(gc) -(define g2 (make-guardian)) -(g2 (list 'g2-garbage)) -(define g3 (make-guardian)) -(g3 (list 'g3-garbage)) -(g3 g2) -(pass-if "g2-garbage not collected yet" (equal? (g2) #f)) -(pass-if "g3-garbage not collected yet" (equal? (g3) #f)) -(set! g2 #f) -(gc) -(let ((seen-g3-garbage #f) - (seen-g2 #f) - (seen-something-else #f)) - (let loop () - (let ((saved (g3))) - (if saved - (begin - (cond - ((equal? saved '(g3-garbage)) (set! seen-g3-garbage #t)) - ((procedure? saved) (set! seen-g2 saved)) - (else (set! seen-something-else #t))) - (loop))))) - (pass-if "g3-garbage saved" seen-g3-garbage) - (pass-if "g2-saved" (procedure? seen-g2)) - (pass-if "nothing else saved" (not seen-something-else)) - (pass-if "g2-garbage saved" (and (procedure? seen-g2) - (equal? (seen-g2) '(g2-garbage))))) diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test deleted file mode 100644 index 45398d9ff..000000000 --- a/test-suite/tests/hooks.test +++ /dev/null @@ -1,149 +0,0 @@ -;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*- -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - -;;; -;;; miscellaneous -;;; - -;; FIXME: Maybe a standard wrong-num-arg exception should be thrown instead -;; of a misc-error? If so, the tests should be changed to expect failure. -(define exception:wrong-num-hook-args - (cons 'misc-error "Hook .* requires .* arguments")) - -;;; -;;; {The tests} -;;; - -(let ((proc1 (lambda (x) (+ x 1))) - (proc2 (lambda (x) (- x 1))) - (bad-proc (lambda (x y) #t))) - (with-test-prefix "hooks" - (pass-if "make-hook" - (make-hook 1) - #t) - - (pass-if "add-hook!" - (let ((x (make-hook 1))) - (add-hook! x proc1) - (add-hook! x proc2) - #t)) - - (with-test-prefix "add-hook!" - (pass-if "append" - (let ((x (make-hook 1))) - (add-hook! x proc1) - (add-hook! x proc2 #t) - (eq? (cadr (hook->list x)) - proc2))) - (pass-if-exception "illegal proc" - exception:wrong-type-arg - (let ((x (make-hook 1))) - (add-hook! x bad-proc))) - (pass-if-exception "illegal hook" - exception:wrong-type-arg - (add-hook! '(foo) proc1))) - (pass-if "run-hook" - (let ((x (make-hook 1))) - (add-hook! x proc1) - (add-hook! x proc2) - (run-hook x 1) - #t)) - (with-test-prefix "run-hook" - (pass-if-exception "bad hook" - exception:wrong-type-arg - (let ((x (cons 'a 'b))) - (run-hook x 1))) - (pass-if-exception "too many args" - exception:wrong-num-hook-args - (let ((x (make-hook 1))) - (add-hook! x proc1) - (add-hook! x proc2) - (run-hook x 1 2))) - - (pass-if - "destructive procs" - (let ((x (make-hook 1)) - (dest-proc1 (lambda (x) - (set-car! x - 'i-sunk-your-battleship))) - (dest-proc2 (lambda (x) (set-cdr! x 'no-way!))) - (val '(a-game-of battleship))) - (add-hook! x dest-proc1) - (add-hook! x dest-proc2 #t) - (run-hook x val) - (and (eq? (car val) 'i-sunk-your-battleship) - (eq? (cdr val) 'no-way!))))) - - (with-test-prefix "remove-hook!" - (pass-if "" - (let ((x (make-hook 1))) - (add-hook! x proc1) - (add-hook! x proc2) - (remove-hook! x proc1) - (not (memq proc1 (hook->list x))))) - ; Maybe it should error, but this is probably - ; more convienient - (pass-if "empty hook" - (let ((x (make-hook 1))) - (remove-hook! x proc1) - #t))) - (pass-if "hook->list" - (let ((x (make-hook 1))) - (add-hook! x proc1) - (add-hook! x proc2) - (and (memq proc1 (hook->list x)) - (memq proc2 (hook->list x)) - #t))) - (pass-if "reset-hook!" - (let ((x (make-hook 1))) - (add-hook! x proc1) - (add-hook! x proc2) - (reset-hook! x) - (null? (hook->list x)))) - (with-test-prefix "reset-hook!" - (pass-if "empty hook" - (let ((x (make-hook 1))) - (reset-hook! x) - #t)) - (pass-if-exception "bad hook" - exception:wrong-type-arg - (reset-hook! '(a b)))))) diff --git a/test-suite/tests/import.test b/test-suite/tests/import.test deleted file mode 100644 index f22522f8d..000000000 --- a/test-suite/tests/import.test +++ /dev/null @@ -1,76 +0,0 @@ -;;;; import.test --- test selective and renaming imports -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - -(define-module (exporter) - :export (foo bar)) - -(define foo 1) -(define bar 2) - -(define-module (importer) - :use-module (test-suite lib)) - -(use-modules ((exporter) - :select (foo (bar . baz)))) - -(pass-if-exception "selective non-import" (cons 'unbound-variable - "^Unbound variable") - (= bar 2)) - -(pass-if "selective import" - (= foo 1)) - -(pass-if "renaming import" - (= baz 2)) - -(use-modules ((exporter) :renamer (symbol-prefix-proc 'external:))) - -(pass-if "symbol-prefic-proc import" - (and (= external:foo 1) - (= external:bar 2))) - -(use-modules ((exporter) :renamer (lambda (sym) - (symbol-append sym ':external)))) - -(pass-if "renamer import" - (and (= foo:external 1) - (= bar:external 2))) diff --git a/test-suite/tests/interp.test b/test-suite/tests/interp.test deleted file mode 100644 index 5d872759b..000000000 --- a/test-suite/tests/interp.test +++ /dev/null @@ -1,53 +0,0 @@ -;;;; interp.test --- tests for bugs in the Guile interpreter -*- scheme -*- -;;;; -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(pass-if "Internal defines 1" - (letrec ((foo (lambda (arg) - (or arg (and (procedure? foo) - (foo 99)))))) - (define bar (foo #f)) - (= (foo #f) 99))) - -(pass-if "Internal defines 2" - (letrec ((foo 77) - (bar #f) - (retfoo (lambda () foo))) - (define baz (retfoo)) - (= (retfoo) 77))) - -;; Test that evaluation of closure bodies works as it should - -(with-test-prefix "closure bodies" - (with-test-prefix "eval" - (pass-if "expansion" - ;; we really want exactly #f back from the closure - (not ((lambda () (define ret #f) ret)))) - (pass-if "iloc escape" - (not (let* ((x #f) - (foo (lambda () x))) - (foo) ; causes memoization of x - (foo))))) - (with-test-prefix "apply" - (pass-if "expansion" - (not (catch #t (lambda () (define ret #f) ret) (lambda a #t)))) - (pass-if "iloc escape" - (not (let* ((x #f) - (foo (lambda () x))) - (foo) - (catch #t foo (lambda a #t))))))) diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test deleted file mode 100644 index 04929a2cc..000000000 --- a/test-suite/tests/list.test +++ /dev/null @@ -1,628 +0,0 @@ -;;;; list.test --- tests guile's lists -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - -(use-modules (ice-9 documentation)) - - -;;; -;;; miscellaneous -;;; - -(define (documented? object) - (not (not (object-documentation object)))) - -;; -;; This unique tag is reserved for the unroll and diff-unrolled functions. -;; - -(define circle-indicator - (cons 'circle 'indicator)) - -;; -;; Extract every single scheme object that is contained within OBJ into a new -;; data structure. That means, if OBJ somewhere contains a pair, the newly -;; created structure holds a reference to the pair as well as references to -;; the car and cdr of that pair. For vectors, the newly created structure -;; holds a reference to that vector as well as references to every element of -;; that vector. Since this is done recursively, the original data structure -;; is deeply unrolled. If there are circles within the original data -;; structures, every reference that points backwards into the data structure -;; is denoted by storing the circle-indicator tag as well as the object the -;; circular reference points to. -;; - -(define (unroll obj) - (let unroll* ((objct obj) - (hist '())) - (reverse! - (let loop ((object objct) - (histry hist) - (result '())) - (if (memq object histry) - (cons (cons circle-indicator object) result) - (let ((history (cons object histry))) - (cond ((pair? object) - (loop (cdr object) history - (cons (cons object (unroll* (car object) history)) - result))) - ((vector? object) - (cons (cons object - (map (lambda (x) - (unroll* x history)) - (vector->list object))) - result)) - (else (cons object result))))))))) - -;; -;; Compare two data-structures that were generated with unroll. If any of the -;; elements found not to be eq?, return a pair that holds the position of the -;; first found differences of the two data structures. If all elements are -;; found to be eq?, #f is returned. -;; - -(define (diff-unrolled a b) - (cond ;; has everything been compared already? - ((and (null? a) (null? b)) - #f) - ;; do both structures still contain elements? - ((and (pair? a) (pair? b)) - (cond ;; are the next elements both plain objects? - ((and (not (pair? (car a))) (not (pair? (car b)))) - (if (eq? (car a) (car b)) - (diff-unrolled (cdr a) (cdr b)) - (cons a b))) - ;; are the next elements both container objects? - ((and (pair? (car a)) (pair? (car b))) - (if (eq? (caar a) (caar b)) - (cond ;; do both objects close a circular structure? - ((eq? circle-indicator (caar a)) - (if (eq? (cdar a) (cdar b)) - (diff-unrolled (cdr a) (cdr b)) - (cons a b))) - ;; do both objects hold a vector? - ((vector? (caar a)) - (or (let loop ((a1 (cdar a)) (b1 (cdar b))) - (cond - ((and (null? a1) (null? b1)) - #f) - ((and (pair? a1) (pair? b1)) - (or (diff-unrolled (car a1) (car b1)) - (loop (cdr a1) (cdr b1)))) - (else - (cons a1 b1)))) - (diff-unrolled (cdr a) (cdr b)))) - ;; do both objects hold a pair? - (else - (or (diff-unrolled (cdar a) (cdar b)) - (diff-unrolled (cdr a) (cdr b))))) - (cons a b))) - (else - (cons a b)))) - (else - (cons a b)))) - -;;; list - - -;;; cons* - - -;;; null? - - -;;; list? - - -;;; length - - -;;; append - - -;;; -;;; append! -;;; - -(with-test-prefix "append!" - - (pass-if "documented?" - (documented? append!)) - - ;; Is the handling of empty lists as arguments correct? - - (pass-if "no arguments" - (eq? (append!) - '())) - - (pass-if "empty list argument" - (eq? (append! '()) - '())) - - (pass-if "some empty list arguments" - (eq? (append! '() '() '()) - '())) - - ;; Does the last non-empty-list argument remain unchanged? - - (pass-if "some empty lists with non-empty list" - (let* ((foo (list 1 2)) - (foo-unrolled (unroll foo)) - (tst (append! '() '() '() foo)) - (tst-unrolled (unroll tst))) - (and (eq? tst foo) - (not (diff-unrolled foo-unrolled tst-unrolled))))) - - (pass-if "some empty lists with improper list" - (let* ((foo (cons 1 2)) - (foo-unrolled (unroll foo)) - (tst (append! '() '() '() foo)) - (tst-unrolled (unroll tst))) - (and (eq? tst foo) - (not (diff-unrolled foo-unrolled tst-unrolled))))) - - (pass-if "some empty lists with circular list" - (let ((foo (list 1 2))) - (set-cdr! (cdr foo) (cdr foo)) - (let* ((foo-unrolled (unroll foo)) - (tst (append! '() '() '() foo)) - (tst-unrolled (unroll tst))) - (and (eq? tst foo) - (not (diff-unrolled foo-unrolled tst-unrolled)))))) - - (pass-if "some empty lists with non list object" - (let* ((foo (vector 1 2 3)) - (foo-unrolled (unroll foo)) - (tst (append! '() '() '() foo)) - (tst-unrolled (unroll tst))) - (and (eq? tst foo) - (not (diff-unrolled foo-unrolled tst-unrolled))))) - - (pass-if "non-empty list between empty lists" - (let* ((foo (list 1 2)) - (foo-unrolled (unroll foo)) - (tst (append! '() '() '() foo '() '() '())) - (tst-unrolled (unroll tst))) - (and (eq? tst foo) - (not (diff-unrolled foo-unrolled tst-unrolled))))) - - ;; Are arbitrary lists append!ed correctly? - - (pass-if "two one-element lists" - (let* ((foo (list 1)) - (foo-unrolled (unroll foo)) - (bar (list 2)) - (bar-unrolled (unroll bar)) - (tst (append! foo bar)) - (tst-unrolled (unroll tst)) - (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) - (and (equal? tst '(1 2)) - (not (diff-unrolled (car diff-foo-tst) (unroll '()))) - (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))) - - (pass-if "three one-element lists" - (let* ((foo (list 1)) - (foo-unrolled (unroll foo)) - (bar (list 2)) - (bar-unrolled (unroll bar)) - (baz (list 3)) - (baz-unrolled (unroll baz)) - (tst (append! foo bar baz)) - (tst-unrolled (unroll tst)) - (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) - (and (equal? tst '(1 2 3)) - (not (diff-unrolled (car diff-foo-tst) (unroll '()))) - (let* ((tst-unrolled-2 (cdr diff-foo-tst)) - (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2))) - (and (not (diff-unrolled (car diff-foo-bar) (unroll '()))) - (not (diff-unrolled baz-unrolled (cdr diff-foo-bar)))))))) - - (pass-if "two two-element lists" - (let* ((foo (list 1 2)) - (foo-unrolled (unroll foo)) - (bar (list 3 4)) - (bar-unrolled (unroll bar)) - (tst (append! foo bar)) - (tst-unrolled (unroll tst)) - (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) - (and (equal? tst '(1 2 3 4)) - (not (diff-unrolled (car diff-foo-tst) (unroll '()))) - (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))) - - (pass-if "three two-element lists" - (let* ((foo (list 1 2)) - (foo-unrolled (unroll foo)) - (bar (list 3 4)) - (bar-unrolled (unroll bar)) - (baz (list 5 6)) - (baz-unrolled (unroll baz)) - (tst (append! foo bar baz)) - (tst-unrolled (unroll tst)) - (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) - (and (equal? tst '(1 2 3 4 5 6)) - (not (diff-unrolled (car diff-foo-tst) (unroll '()))) - (let* ((tst-unrolled-2 (cdr diff-foo-tst)) - (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2))) - (and (not (diff-unrolled (car diff-foo-bar) (unroll '()))) - (not (diff-unrolled baz-unrolled (cdr diff-foo-bar)))))))) - - (pass-if "empty list between non-empty lists" - (let* ((foo (list 1 2)) - (foo-unrolled (unroll foo)) - (bar (list 3 4)) - (bar-unrolled (unroll bar)) - (baz (list 5 6)) - (baz-unrolled (unroll baz)) - (tst (append! foo '() bar '() '() baz '() '() '())) - (tst-unrolled (unroll tst)) - (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) - (and (equal? tst '(1 2 3 4 5 6)) - (not (diff-unrolled (car diff-foo-tst) (unroll '()))) - (let* ((tst-unrolled-2 (cdr diff-foo-tst)) - (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2))) - (and (not (diff-unrolled (car diff-foo-bar) (unroll '()))) - (not (diff-unrolled baz-unrolled (cdr diff-foo-bar)))))))) - - (pass-if "list and improper list" - (let* ((foo (list 1 2)) - (foo-unrolled (unroll foo)) - (bar (cons 3 4)) - (bar-unrolled (unroll bar)) - (tst (append! foo bar)) - (tst-unrolled (unroll tst)) - (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) - (and (equal? tst '(1 2 3 . 4)) - (not (diff-unrolled (car diff-foo-tst) (unroll '()))) - (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))) - - (pass-if "list and circular list" - (let* ((foo (list 1 2)) - (foo-unrolled (unroll foo)) - (bar (list 3 4 5))) - (set-cdr! (cddr bar) (cdr bar)) - (let* ((bar-unrolled (unroll bar)) - (tst (append! foo bar)) - (tst-unrolled (unroll tst)) - (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) - (and (equal? (map (lambda (n x) (eqv? (list-ref tst n) x)) - (iota 9) - '(1 2 3 4 5 4 5 4 5)) - '(#t #t #t #t #t #t #t #t #t)) - (not (diff-unrolled (car diff-foo-tst) (unroll '()))) - (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))) - - (pass-if "list and non list object" - (let* ((foo (list 1 2)) - (foo-unrolled (unroll foo)) - (bar (vector 3 4)) - (bar-unrolled (unroll bar)) - (tst (append! foo bar)) - (tst-unrolled (unroll tst)) - (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) - (and (equal? tst '(1 2 . #(3 4))) - (not (diff-unrolled (car diff-foo-tst) (unroll '()))) - (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))) - - (pass-if "several arbitrary lists" - (equal? (append! (list 1 2) - (list (list 3) 4) - (list (list 5) (list 6)) - (list 7 (cons 8 9)) - (list 10 11) - (list (cons 12 13) 14) - (list (list))) - (list 1 2 - (list 3) 4 - (list 5) (list 6) - 7 (cons 8 9) - 10 11 - (cons 12 13) - 14 (list)))) - - (pass-if "list to itself" - (let* ((foo (list 1 2)) - (foo-unrolled (unroll foo)) - (tst (append! foo foo)) - (tst-unrolled (unroll tst)) - (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) - (and (equal? (map (lambda (n x) (eqv? (list-ref tst n) x)) - (iota 6) - '(1 2 1 2 1 2)) - '(#t #t #t #t #t #t)) - (not (diff-unrolled (car diff-foo-tst) (unroll '()))) - (eq? (caar (cdr diff-foo-tst)) circle-indicator) - (eq? (cdar (cdr diff-foo-tst)) foo)))) - - ;; Are wrong type arguments detected correctly? - - (with-test-prefix "wrong argument" - - (expect-fail-exception "improper list and empty list" - exception:wrong-type-arg - (append! (cons 1 2) '())) - - (expect-fail-exception "improper list and list" - exception:wrong-type-arg - (append! (cons 1 2) (list 3 4))) - - (expect-fail-exception "list, improper list and list" - exception:wrong-type-arg - (append! (list 1 2) (cons 3 4) (list 5 6))) - - (expect-fail "circular list and empty list" - (let ((foo (list 1 2 3))) - (set-cdr! (cddr foo) (cdr foo)) - (catch #t - (lambda () - (catch 'wrong-type-arg - (lambda () - (append! foo '()) - #f) - (lambda (key . args) - #t))) - (lambda (key . args) - #f)))) - - (expect-fail "circular list and list" - (let ((foo (list 1 2 3))) - (set-cdr! (cddr foo) (cdr foo)) - (catch #t - (lambda () - (catch 'wrong-type-arg - (lambda () - (append! foo (list 4 5)) - #f) - (lambda (key . args) - #t))) - (lambda (key . args) - #f)))) - - (expect-fail "list, circular list and list" - (let ((foo (list 3 4 5))) - (set-cdr! (cddr foo) (cdr foo)) - (catch #t - (lambda () - (catch 'wrong-type-arg - (lambda () - (append! (list 1 2) foo (list 6 7)) - #f) - (lambda (key . args) - #t))) - (lambda (key . args) - #f)))))) - - -;;; last-pair - - -;;; reverse - - -;;; reverse! - - -;;; list-ref - -(with-test-prefix "list-ref" - - (pass-if "documented?" - (documented? list-ref)) - - (with-test-prefix "argument error" - - (with-test-prefix "non list argument" - #t) - - (with-test-prefix "improper list argument" - #t) - - (with-test-prefix "non integer index" - #t) - - (with-test-prefix "index out of range" - - (with-test-prefix "empty list" - - (pass-if-exception "index 0" - exception:out-of-range - (list-ref '() 0)) - - (pass-if-exception "index > 0" - exception:out-of-range - (list-ref '() 1)) - - (pass-if-exception "index < 0" - exception:out-of-range - (list-ref '() -1))) - - (with-test-prefix "non-empty list" - - (pass-if-exception "index > length" - exception:out-of-range - (list-ref '(1) 1)) - - (pass-if-exception "index < 0" - exception:out-of-range - (list-ref '(1) -1)))))) - - -;;; list-set! - -(with-test-prefix "list-set!" - - (pass-if "documented?" - (documented? list-set!)) - - (with-test-prefix "argument error" - - (with-test-prefix "non list argument" - #t) - - (with-test-prefix "improper list argument" - #t) - - (with-test-prefix "read-only list argument" - #t) - - (with-test-prefix "non integer index" - #t) - - (with-test-prefix "index out of range" - - (with-test-prefix "empty list" - - (pass-if-exception "index 0" - exception:out-of-range - (list-set! (list) 0 #t)) - - (pass-if-exception "index > 0" - exception:out-of-range - (list-set! (list) 1 #t)) - - (pass-if-exception "index < 0" - exception:out-of-range - (list-set! (list) -1 #t))) - - (with-test-prefix "non-empty list" - - (pass-if-exception "index > length" - exception:out-of-range - (list-set! (list 1) 1 #t)) - - (pass-if-exception "index < 0" - exception:out-of-range - (list-set! (list 1) -1 #t)))))) - - -;;; list-cdr-ref - - -;;; list-tail - - -;;; list-cdr-set! - -(with-test-prefix "list-cdr-set!" - - (pass-if "documented?" - (documented? list-cdr-set!)) - - (with-test-prefix "argument error" - - (with-test-prefix "non list argument" - #t) - - (with-test-prefix "improper list argument" - #t) - - (with-test-prefix "read-only list argument" - #t) - - (with-test-prefix "non integer index" - #t) - - (with-test-prefix "index out of range" - - (with-test-prefix "empty list" - - (pass-if-exception "index 0" - exception:out-of-range - (list-cdr-set! (list) 0 #t)) - - (pass-if-exception "index > 0" - exception:out-of-range - (list-cdr-set! (list) 1 #t)) - - (pass-if-exception "index < 0" - exception:out-of-range - (list-cdr-set! (list) -1 #t))) - - (with-test-prefix "non-empty list" - - (pass-if-exception "index > length" - exception:out-of-range - (list-cdr-set! (list 1) 1 #t)) - - (pass-if-exception "index < 0" - exception:out-of-range - (list-cdr-set! (list 1) -1 #t)))))) - - -;;; list-head - - -;;; list-copy - - -;;; memq - - -;;; memv - - -;;; member - - -;;; delq! - - -;;; delv! - - -;;; delete! - - -;;; delq - - -;;; delv - - -;;; delete - - -;;; delq1! - - -;;; delv1! - - -;;; delete1! diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test deleted file mode 100644 index 6b0de7612..000000000 --- a/test-suite/tests/load.test +++ /dev/null @@ -1,126 +0,0 @@ -;;;; load.test --- test LOAD and path searching functions -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 -;;;; -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (test-suite lib)) - -(define temp-dir (data-file-name "load-test.dir")) - -(define (create-tree parent tree) - (let loop ((parent parent) - (tree tree)) - (if (pair? tree) - (let ((elt (car tree))) - (cond - - ;; A string means to create an empty file with that name. - ((string? elt) - (close-port (open-file (string-append parent "/" elt) "w"))) - - ;; A list means to create a directory, and then create files - ;; within it. - ((pair? elt) - (let ((dirname (string-append parent "/" (car elt)))) - (mkdir dirname) - (loop dirname (cdr elt)))) - - (else - (error "create-tree: bad tree structure"))) - - (loop parent (cdr tree)))))) - -(define (delete-tree tree) - (cond - ((file-is-directory? tree) - (let ((dir (opendir tree))) - (let loop () - (let ((entry (readdir dir))) - (cond - ((member entry '("." "..")) - (loop)) - ((not (eof-object? entry)) - (let ((name (string-append tree "/" entry))) - (delete-tree name) - (loop)))))) - (closedir dir) - (rmdir tree))) - ((file-exists? tree) - (delete-file tree)) - (else - (error "delete-tree: can't delete " tree)))) - -(define (try-search-with-extensions path input extensions expected) - (let ((test-name (call-with-output-string - (lambda (port) - (display "search-path for " port) - (write input port) - (if (pair? extensions) - (begin - (display " with extensions " port) - (write extensions port))) - (display " yields " port) - (write expected port))))) - (let ((result (search-path path input extensions))) - (pass-if test-name - (equal? (if (string? expected) - (string-append temp-dir "/" expected) - expected) - result))))) - -(define (try-search path input expected) - (try-search-with-extensions path input '() expected)) - -;; Create a bunch of files for use in testing. -(mkdir temp-dir) -(create-tree temp-dir - '(("dir1" "foo.scm" "bar.scm" "ugly.scm.scm" - ("subdir1")) - ("dir2" "foo.scm" "baz.scm" "baz.ss" "ugly.scm.ss") - ("dir3" "ugly.scm" "ugly.ss.scm"))) - -;; Try some searches without extensions. -(define path (list - (string-append temp-dir "/dir1") - (string-append temp-dir "/dir2") - (string-append temp-dir "/dir3"))) - -(try-search path "foo.scm" "dir1/foo.scm") -(try-search path "bar.scm" "dir1/bar.scm") -(try-search path "baz.scm" "dir2/baz.scm") -(try-search path "baz.ss" "dir2/baz.ss") -(try-search path "ugly.scm" "dir3/ugly.scm") -(try-search path "subdir1" #f) - -(define extensions '(".ss" ".scm" "")) -(try-search-with-extensions path "foo" extensions "dir1/foo.scm") -(try-search-with-extensions path "bar" extensions "dir1/bar.scm") -(try-search-with-extensions path "baz" extensions "dir2/baz.ss") -(try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm") -(try-search-with-extensions path "ugly.ss" extensions #f) - -(if (defined? '%nil) - ;; Check that search-path accepts Elisp nil-terminated lists for - ;; PATH and EXTENSIONS. - (with-test-prefix "elisp-nil" - (set-cdr! (last-pair path) %nil) - (set-cdr! (last-pair extensions) %nil) - (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm") - (try-search-with-extensions path "ugly.ss" extensions #f))) - -(delete-tree temp-dir) diff --git a/test-suite/tests/multilingual.nottest b/test-suite/tests/multilingual.nottest deleted file mode 100644 index 468acd924..000000000 --- a/test-suite/tests/multilingual.nottest +++ /dev/null @@ -1,81 +0,0 @@ -;;;; multilingual.nottest --- tests of multilingual support -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 -;;;; This isn't a test yet, because we don't have multilingual support yet. -;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (test-suite lib)) - - -;;; Tests of Emacs 20.4 character encoding. - -;;; Check that characters are being encoded correctly. - -;;; These tests are specific to the Emacs 20.4 encoding; they'll need -;;; to be replaced when Guile switches to UTF-8. See mb.c for a -;;; description of this encoding. - -(define (check-encoding char-number encoding) - (let ((singleton (string (integer->char char-number)))) - (pass-if (string-append "encoding character " - (number->string char-number)) - (equal? (string->bytes singleton) encoding)) - (pass-if (string-append "decoding character " - (number->string char-number)) - (catch #t - (lambda () - (equal? (bytes->string encoding) singleton)) - (lambda dummy #f))))) - - -;; Check some ASCII characters. -(check-encoding 0 #y(0)) -(check-encoding 127 #y(127)) -(check-encoding 31 #y(31)) -(check-encoding 32 #y(32)) -(check-encoding 42 #y(42)) - -;;; Sometimes we mark something as an "end of range", when it's not -;;; actually the last character that would use that encoding form. -;;; This is because not all character set numbers are assigned, and we -;;; can't use unassigned character set numbers. So the value given is -;;; the last value which actually corresponds to something in a real -;;; character set. - -;; Check some characters encoded in two bytes. -(check-encoding 2208 #y(#x81 #xA0)) ; beginning of range -(check-encoding 3839 #y(#x8d #xFF)) ; end of range -(check-encoding 2273 #y(#x81 #xE1)) - -;; Check some big characters encoded in three bytes. -(check-encoding 20512 #y(#x90 #xA0 #xA0)) ; beginning of range -(check-encoding 180223 #y(#x99 #xFF #xFF)) ; end of range -(check-encoding 53931 #y(#x92 #xA5 #xAB)) - -;; Check some small characters encoded in three bytes --- some from -;; the #x9A prefix range, and some from the #x9B prefix range. -(check-encoding 6176 #y(#x9A #xA0 #xA0)) ; start of the #9A prefix range -(check-encoding 7167 #y(#x9A #xA7 #xFF)) ; end of the #9A prefix range -(check-encoding 14368 #y(#x9B #xE0 #xA0)) ; start of the #9B prefix range -(check-encoding 14591 #y(#x9B #xE1 #xFF)) ; end of the #9B prefix range - -;; Check some characters encoded in four bytes. -(check-encoding 266272 #y(#x9C #xF0 #xA0 #xA0)) ; start of the #9C prefix range -(check-encoding 294911 #y(#x9C #xF1 #xFF #xFF)) ; end of the #9C prefix range -(check-encoding 348192 #y(#x9D #xF5 #xA0 #xA0)) ; start of the #9D prefix range -(check-encoding 475135 #y(#x9D #xFC #xFF #xFF)) ; start of the #9D prefix range diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test deleted file mode 100644 index 951325f71..000000000 --- a/test-suite/tests/numbers.test +++ /dev/null @@ -1,1490 +0,0 @@ -;;;; numbers.test --- tests guile's numbers -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - -(use-modules (ice-9 documentation)) - - -;;; -;;; miscellaneous -;;; - -(define exception:numerical-overflow - (cons 'numerical-overflow "^Numerical overflow")) - -(define (documented? object) - (not (not (object-documentation object)))) - -(define fixnum-bit - (inexact->exact (+ (/ (log (+ most-positive-fixnum 1)) (log 2)) 1))) - -(define fixnum-min most-negative-fixnum) -(define fixnum-max most-positive-fixnum) - - -;;; -;;; exact? -;;; - -(with-test-prefix "exact?" - - (pass-if "documented?" - (documented? exact?)) - - (with-test-prefix "integers" - - (pass-if "0" - (exact? 0)) - - (pass-if "fixnum-max" - (exact? fixnum-max)) - - (pass-if "fixnum-max + 1" - (exact? (+ fixnum-max 1))) - - (pass-if "fixnum-min" - (exact? fixnum-min)) - - (pass-if "fixnum-min - 1" - (exact? (- fixnum-min 1)))) - - (with-test-prefix "reals" - - ;; (FIXME: need better examples.) - - (pass-if "sqrt (fixnum-max^2 - 1)" - (eq? #f (exact? (sqrt (- (expt fixnum-max 2) 1))))) - - (pass-if "sqrt ((fixnum-max+1)^2 - 1)" - (eq? #f (exact? (sqrt (- (expt (+ fixnum-max 1) 2) 1))))))) - -;;; -;;; odd? -;;; - - -;;; -;;; even? -;;; - - -;;; -;;; abs -;;; - - -;;; -;;; quotient -;;; - -(with-test-prefix "quotient" - - (expect-fail "documented?" - (documented? quotient)) - - (with-test-prefix "0 / n" - - (pass-if "n = 1" - (eqv? 0 (quotient 0 1))) - - (pass-if "n = -1" - (eqv? 0 (quotient 0 -1))) - - (pass-if "n = 2" - (eqv? 0 (quotient 0 2))) - - (pass-if "n = fixnum-max" - (eqv? 0 (quotient 0 fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 0 (quotient 0 (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 0 (quotient 0 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 0 (quotient 0 (- fixnum-min 1))))) - - (with-test-prefix "1 / n" - - (pass-if "n = 1" - (eqv? 1 (quotient 1 1))) - - (pass-if "n = -1" - (eqv? -1 (quotient 1 -1))) - - (pass-if "n = 2" - (eqv? 0 (quotient 1 2))) - - (pass-if "n = fixnum-max" - (eqv? 0 (quotient 1 fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 0 (quotient 1 (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 0 (quotient 1 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 0 (quotient 1 (- fixnum-min 1))))) - - (with-test-prefix "-1 / n" - - (pass-if "n = 1" - (eqv? -1 (quotient -1 1))) - - (pass-if "n = -1" - (eqv? 1 (quotient -1 -1))) - - (pass-if "n = 2" - (eqv? 0 (quotient -1 2))) - - (pass-if "n = fixnum-max" - (eqv? 0 (quotient -1 fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 0 (quotient -1 (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 0 (quotient -1 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 0 (quotient -1 (- fixnum-min 1))))) - - (with-test-prefix "fixnum-max / n" - - (pass-if "n = 1" - (eqv? fixnum-max (quotient fixnum-max 1))) - - (pass-if "n = -1" - (eqv? (- fixnum-max) (quotient fixnum-max -1))) - - (pass-if "n = 2" - (eqv? fixnum-max (+ (* (quotient fixnum-max 2) 2) 1))) - - (pass-if "n = fixnum-max" - (eqv? 1 (quotient fixnum-max fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 0 (quotient fixnum-max (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 0 (quotient fixnum-max fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 0 (quotient fixnum-max (- fixnum-min 1))))) - - (with-test-prefix "(fixnum-max + 1) / n" - - (pass-if "n = 1" - (eqv? (+ fixnum-max 1) (quotient (+ fixnum-max 1) 1))) - - (pass-if "n = -1" - (eqv? (- (+ fixnum-max 1)) (quotient (+ fixnum-max 1) -1))) - - (pass-if "n = 2" - (eqv? (+ fixnum-max 1) (* (quotient (+ fixnum-max 1) 2) 2))) - - (pass-if "n = fixnum-max" - (eqv? 1 (quotient (+ fixnum-max 1) fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 1 (quotient (+ fixnum-max 1) (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? -1 (quotient (+ fixnum-max 1) fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 0 (quotient (+ fixnum-max 1) (- fixnum-min 1))))) - - (with-test-prefix "fixnum-min / n" - - (pass-if "n = 1" - (eqv? fixnum-min (quotient fixnum-min 1))) - - (pass-if "n = -1" - (eqv? (- fixnum-min) (quotient fixnum-min -1))) - - (pass-if "n = 2" - (eqv? fixnum-min (* (quotient fixnum-min 2) 2))) - - (pass-if "n = fixnum-max" - (eqv? -1 (quotient fixnum-min fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? -1 (quotient fixnum-min (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 1 (quotient fixnum-min fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 0 (quotient fixnum-min (- fixnum-min 1))))) - - (with-test-prefix "(fixnum-min - 1) / n" - - (pass-if "n = 1" - (eqv? (- fixnum-min 1) (quotient (- fixnum-min 1) 1))) - - (pass-if "n = -1" - (eqv? (- (- fixnum-min 1)) (quotient (- fixnum-min 1) -1))) - - (pass-if "n = 2" - (eqv? fixnum-min (* (quotient (- fixnum-min 1) 2) 2))) - - (pass-if "n = fixnum-max" - (eqv? -1 (quotient (- fixnum-min 1) fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? -1 (quotient (- fixnum-min 1) (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 1 (quotient (- fixnum-min 1) fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 1 (quotient (- fixnum-min 1) (- fixnum-min 1))))) - - ;; Positive dividend and divisor - - (pass-if "35 / 7" - (eqv? 5 (quotient 35 7))) - - ;; Negative dividend, positive divisor - - (pass-if "-35 / 7" - (eqv? -5 (quotient -35 7))) - - ;; Positive dividend, negative divisor - - (pass-if "35 / -7" - (eqv? -5 (quotient 35 -7))) - - ;; Negative dividend and divisor - - (pass-if "-35 / -7" - (eqv? 5 (quotient -35 -7))) - - ;; Are numerical overflows detected correctly? - - (with-test-prefix "division by zero" - - (pass-if-exception "(quotient 1 0)" - exception:numerical-overflow - (quotient 1 0)) - - (pass-if-exception "(quotient bignum 0)" - exception:numerical-overflow - (quotient (+ fixnum-max 1) 0))) - - ;; Are wrong type arguments detected correctly? - - ) - -;;; -;;; remainder -;;; - -(with-test-prefix "remainder" - - (expect-fail "documented?" - (documented? remainder)) - - (with-test-prefix "0 / n" - - (pass-if "n = 1" - (eqv? 0 (remainder 0 1))) - - (pass-if "n = -1" - (eqv? 0 (remainder 0 -1))) - - (pass-if "n = fixnum-max" - (eqv? 0 (remainder 0 fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 0 (remainder 0 (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 0 (remainder 0 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 0 (remainder 0 (- fixnum-min 1))))) - - (with-test-prefix "1 / n" - - (pass-if "n = 1" - (eqv? 0 (remainder 1 1))) - - (pass-if "n = -1" - (eqv? 0 (remainder 1 -1))) - - (pass-if "n = fixnum-max" - (eqv? 1 (remainder 1 fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 1 (remainder 1 (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 1 (remainder 1 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 1 (remainder 1 (- fixnum-min 1))))) - - (with-test-prefix "-1 / n" - - (pass-if "n = 1" - (eqv? 0 (remainder -1 1))) - - (pass-if "n = -1" - (eqv? 0 (remainder -1 -1))) - - (pass-if "n = fixnum-max" - (eqv? -1 (remainder -1 fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? -1 (remainder -1 (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? -1 (remainder -1 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? -1 (remainder -1 (- fixnum-min 1))))) - - (with-test-prefix "fixnum-max / n" - - (pass-if "n = 1" - (eqv? 0 (remainder fixnum-max 1))) - - (pass-if "n = -1" - (eqv? 0 (remainder fixnum-max -1))) - - (pass-if "n = fixnum-max" - (eqv? 0 (remainder fixnum-max fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? fixnum-max (remainder fixnum-max (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? fixnum-max (remainder fixnum-max fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? fixnum-max (remainder fixnum-max (- fixnum-min 1))))) - - (with-test-prefix "(fixnum-max + 1) / n" - - (pass-if "n = 1" - (eqv? 0 (remainder (+ fixnum-max 1) 1))) - - (pass-if "n = -1" - (eqv? 0 (remainder (+ fixnum-max 1) -1))) - - (pass-if "n = fixnum-max" - (eqv? 1 (remainder (+ fixnum-max 1) fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 0 (remainder (+ fixnum-max 1) (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 0 (remainder (+ fixnum-max 1) fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? (+ fixnum-max 1) (remainder (+ fixnum-max 1) (- fixnum-min 1))))) - - (with-test-prefix "fixnum-min / n" - - (pass-if "n = 1" - (eqv? 0 (remainder fixnum-min 1))) - - (pass-if "n = -1" - (eqv? 0 (remainder fixnum-min -1))) - - (pass-if "n = fixnum-max" - (eqv? -1 (remainder fixnum-min fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 0 (remainder fixnum-min (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 0 (remainder fixnum-min fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? fixnum-min (remainder fixnum-min (- fixnum-min 1))))) - - (with-test-prefix "(fixnum-min - 1) / n" - - (pass-if "n = 1" - (eqv? 0 (remainder (- fixnum-min 1) 1))) - - (pass-if "n = -1" - (eqv? 0 (remainder (- fixnum-min 1) -1))) - - (pass-if "n = fixnum-max" - (eqv? -2 (remainder (- fixnum-min 1) fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? -1 (remainder (- fixnum-min 1) (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? -1 (remainder (- fixnum-min 1) fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 0 (remainder (- fixnum-min 1) (- fixnum-min 1))))) - - ;; Positive dividend and divisor - - (pass-if "35 / 7" - (eqv? 0 (remainder 35 7))) - - ;; Negative dividend, positive divisor - - (pass-if "-35 / 7" - (eqv? 0 (remainder -35 7))) - - ;; Positive dividend, negative divisor - - (pass-if "35 / -7" - (eqv? 0 (remainder 35 -7))) - - ;; Negative dividend and divisor - - (pass-if "-35 / -7" - (eqv? 0 (remainder -35 -7))) - - ;; Are numerical overflows detected correctly? - - (with-test-prefix "division by zero" - - (pass-if-exception "(remainder 1 0)" - exception:numerical-overflow - (remainder 1 0)) - - (pass-if-exception "(remainder bignum 0)" - exception:numerical-overflow - (remainder (+ fixnum-max 1) 0))) - - ;; Are wrong type arguments detected correctly? - - ) - -;;; -;;; modulo -;;; - -(with-test-prefix "modulo" - - (expect-fail "documented?" - (documented? modulo)) - - (with-test-prefix "0 % n" - - (pass-if "n = 1" - (eqv? 0 (modulo 0 1))) - - (pass-if "n = -1" - (eqv? 0 (modulo 0 -1))) - - (pass-if "n = fixnum-max" - (eqv? 0 (modulo 0 fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 0 (modulo 0 (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 0 (modulo 0 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 0 (modulo 0 (- fixnum-min 1))))) - - (with-test-prefix "1 % n" - - (pass-if "n = 1" - (eqv? 0 (modulo 1 1))) - - (pass-if "n = -1" - (eqv? 0 (modulo 1 -1))) - - (pass-if "n = fixnum-max" - (eqv? 1 (modulo 1 fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 1 (modulo 1 (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? (+ fixnum-min 1) (modulo 1 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? fixnum-min (modulo 1 (- fixnum-min 1))))) - - (with-test-prefix "-1 % n" - - (pass-if "n = 1" - (eqv? 0 (modulo -1 1))) - - (pass-if "n = -1" - (eqv? 0 (modulo -1 -1))) - - (pass-if "n = fixnum-max" - (eqv? (- fixnum-max 1) (modulo -1 fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? fixnum-max (modulo -1 (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? -1 (modulo -1 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? -1 (modulo -1 (- fixnum-min 1))))) - - (with-test-prefix "fixnum-max % n" - - (pass-if "n = 1" - (eqv? 0 (modulo fixnum-max 1))) - - (pass-if "n = -1" - (eqv? 0 (modulo fixnum-max -1))) - - (pass-if "n = fixnum-max" - (eqv? 0 (modulo fixnum-max fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? fixnum-max (modulo fixnum-max (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? -1 (modulo fixnum-max fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? -2 (modulo fixnum-max (- fixnum-min 1))))) - - (with-test-prefix "(fixnum-max + 1) % n" - - (pass-if "n = 1" - (eqv? 0 (modulo (+ fixnum-max 1) 1))) - - (pass-if "n = -1" - (eqv? 0 (modulo (+ fixnum-max 1) -1))) - - (pass-if "n = fixnum-max" - (eqv? 1 (modulo (+ fixnum-max 1) fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 0 (modulo (+ fixnum-max 1) (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 0 (modulo (+ fixnum-max 1) fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? -1 (modulo (+ fixnum-max 1) (- fixnum-min 1))))) - - (with-test-prefix "fixnum-min % n" - - (pass-if "n = 1" - (eqv? 0 (modulo fixnum-min 1))) - - (pass-if "n = -1" - (eqv? 0 (modulo fixnum-min -1))) - - (pass-if "n = fixnum-max" - (eqv? (- fixnum-max 1) (modulo fixnum-min fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 0 (modulo fixnum-min (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 0 (modulo fixnum-min fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? fixnum-min (modulo fixnum-min (- fixnum-min 1))))) - - (with-test-prefix "(fixnum-min - 1) % n" - - (pass-if "n = 1" - (eqv? 0 (modulo (- fixnum-min 1) 1))) - - (pass-if "n = -1" - (eqv? 0 (modulo (- fixnum-min 1) -1))) - - (pass-if "n = fixnum-max" - (eqv? (- fixnum-max 2) (modulo (- fixnum-min 1) fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? fixnum-max (modulo (- fixnum-min 1) (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? -1 (modulo (- fixnum-min 1) fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 0 (modulo (- fixnum-min 1) (- fixnum-min 1))))) - - ;; Positive dividend and divisor - - (pass-if "13 % 4" - (eqv? 1 (modulo 13 4))) - - (pass-if "2177452800 % 86400" - (eqv? 0 (modulo 2177452800 86400))) - - ;; Negative dividend, positive divisor - - (pass-if "-13 % 4" - (eqv? 3 (modulo -13 4))) - - (pass-if "-2177452800 % 86400" - (eqv? 0 (modulo -2177452800 86400))) - - ;; Positive dividend, negative divisor - - (pass-if "13 % -4" - (eqv? -3 (modulo 13 -4))) - - (pass-if "2177452800 % -86400" - (eqv? 0 (modulo 2177452800 -86400))) - - ;; Negative dividend and divisor - - (pass-if "-13 % -4" - (eqv? -1 (modulo -13 -4))) - - (pass-if "-2177452800 % -86400" - (eqv? 0 (modulo -2177452800 -86400))) - - ;; Are numerical overflows detected correctly? - - (with-test-prefix "division by zero" - - (pass-if-exception "(modulo 1 0)" - exception:numerical-overflow - (modulo 1 0)) - - (pass-if-exception "(modulo bignum 0)" - exception:numerical-overflow - (modulo (+ fixnum-max 1) 0))) - - ;; Are wrong type arguments detected correctly? - - ) - -;;; -;;; gcd -;;; - -(with-test-prefix "gcd" - - (expect-fail "documented?" - (documented? gcd)) - - (with-test-prefix "(0 n)" - - (pass-if "n = 0" - (eqv? 0 (gcd 0 0))) - - (pass-if "n = 1" - (eqv? 1 (gcd 0 1))) - - (pass-if "n = -1" - (eqv? 1 (gcd 0 -1))) - - (pass-if "n = fixnum-max" - (eqv? fixnum-max (gcd 0 fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? (+ fixnum-max 1) (gcd 0 (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? (- fixnum-min) (gcd 0 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? (- (- fixnum-min 1)) (gcd 0 (- fixnum-min 1))))) - - (with-test-prefix "(1 n)" - - (pass-if "n = 0" - (eqv? 1 (gcd 1 0))) - - (pass-if "n = 1" - (eqv? 1 (gcd 1 1))) - - (pass-if "n = -1" - (eqv? 1 (gcd 1 -1))) - - (pass-if "n = fixnum-max" - (eqv? 1 (gcd 1 fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 1 (gcd 1 (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 1 (gcd 1 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 1 (gcd 1 (- fixnum-min 1))))) - - (with-test-prefix "(-1 n)" - - (pass-if "n = 0" - (eqv? 1 (gcd -1 0))) - - (pass-if "n = 1" - (eqv? 1 (gcd -1 1))) - - (pass-if "n = -1" - (eqv? 1 (gcd -1 -1))) - - (pass-if "n = fixnum-max" - (eqv? 1 (gcd -1 fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 1 (gcd -1 (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 1 (gcd -1 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 1 (gcd -1 (- fixnum-min 1))))) - - (with-test-prefix "(fixnum-max n)" - - (pass-if "n = 0" - (eqv? fixnum-max (gcd fixnum-max 0))) - - (pass-if "n = 1" - (eqv? 1 (gcd fixnum-max 1))) - - (pass-if "n = -1" - (eqv? 1 (gcd fixnum-max -1))) - - (pass-if "n = fixnum-max" - (eqv? fixnum-max (gcd fixnum-max fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 1 (gcd fixnum-max (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 1 (gcd fixnum-max fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 1 (gcd fixnum-max (- fixnum-min 1))))) - - (with-test-prefix "((+ fixnum-max 1) n)" - - (pass-if "n = 0" - (eqv? (+ fixnum-max 1) (gcd (+ fixnum-max 1) 0))) - - (pass-if "n = 1" - (eqv? 1 (gcd (+ fixnum-max 1) 1))) - - (pass-if "n = -1" - (eqv? 1 (gcd (+ fixnum-max 1) -1))) - - (pass-if "n = fixnum-max" - (eqv? 1 (gcd (+ fixnum-max 1) fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? (+ fixnum-max 1) (gcd (+ fixnum-max 1) (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? (+ fixnum-max 1) (gcd (+ fixnum-max 1) fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 1 (gcd (+ fixnum-max 1) (- fixnum-min 1))))) - - (with-test-prefix "(fixnum-min n)" - - (pass-if "n = 0" - (eqv? (- fixnum-min) (gcd fixnum-min 0))) - - (pass-if "n = 1" - (eqv? 1 (gcd fixnum-min 1))) - - (pass-if "n = -1" - (eqv? 1 (gcd fixnum-min -1))) - - (pass-if "n = fixnum-max" - (eqv? 1 (gcd fixnum-min fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? (+ fixnum-max 1) (gcd fixnum-min (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? (- fixnum-min) (gcd fixnum-min fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? 1 (gcd fixnum-min (- fixnum-min 1))))) - - (with-test-prefix "((- fixnum-min 1) n)" - - (pass-if "n = 0" - (eqv? (- (- fixnum-min 1)) (gcd (- fixnum-min 1) 0))) - - (pass-if "n = 1" - (eqv? 1 (gcd (- fixnum-min 1) 1))) - - (pass-if "n = -1" - (eqv? 1 (gcd (- fixnum-min 1) -1))) - - (pass-if "n = fixnum-max" - (eqv? 1 (gcd (- fixnum-min 1) fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (eqv? 1 (gcd (- fixnum-min 1) (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (eqv? 1 (gcd (- fixnum-min 1) fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (eqv? (- (- fixnum-min 1)) (gcd (- fixnum-min 1) (- fixnum-min 1))))) - - ;; Are wrong type arguments detected correctly? - - ) - -;;; -;;; lcm -;;; - -;;; -;;; number->string -;;; - -;;; -;;; string->number -;;; - -(with-test-prefix "string->number" - - (pass-if "string->number" - (documented? string->number)) - - (pass-if "non number strings" - (for-each (lambda (x) (if (string->number x) (throw 'fail))) - '("" "q" "1q" "6+7iq" "8+9q" "10+11" "13+" "18@19q" "20@q" "23@" - "+25iq" "26i" "-q" "-iq" "i" "5#.0" "8/" "10#11" ".#" "." - "#o.2" "3.4q" "15.16e17q" "18.19e+q" ".q" ".17#18" "10q" "#b2" - "#b3" "#b4" "#b5" "#b6" "#b7" "#b8" "#b9" "#ba" "#bb" "#bc" - "#bd" "#be" "#bf" "#q" "#b#b1" "#o#o1" "#d#d1" "#x#x1" "#e#e1" - "#i#i1" "12@12+0i")) - #t) - - (pass-if "valid number strings" - (for-each (lambda (couple) - (apply - (lambda (x y) - (let ((x (string->number x))) - (if (or (eq? x #f) (not (eqv? x y))) (throw 'fail)))) - couple)) - `(;; Radix: - ("#b0" 0) ("#B0" 0) ("#b1" 1) ("#B1" 1) ("#o0" 0) ("#O0" 0) - ("#o1" 1) ("#O1" 1) ("#o2" 2) ("#O2" 2) ("#o3" 3) ("#O3" 3) - ("#o4" 4) ("#O4" 4) ("#o5" 5) ("#O5" 5) ("#o6" 6) ("#O6" 6) - ("#o7" 7) ("#O7" 7) ("#d0" 0) ("#D0" 0) ("#d1" 1) ("#D1" 1) - ("#d2" 2) ("#D2" 2) ("#d3" 3) ("#D3" 3) ("#d4" 4) ("#D4" 4) - ("#d5" 5) ("#D5" 5) ("#d6" 6) ("#D6" 6) ("#d7" 7) ("#D7" 7) - ("#d8" 8) ("#D8" 8) ("#d9" 9) ("#D9" 9) - ("#xa" 10) ("#Xa" 10) ("#xb" 11) ("#Xb" 11) - ("#xc" 12) ("#Xc" 12) ("#xd" 13) ("#Xd" 13) - ("#xe" 14) ("#Xe" 14) ("#xf" 15) ("#Xf" 15) - ("#b1010" 10) - ("#o12345670" 2739128) - ("#d1234567890" 1234567890) - ("#x1234567890abcdef" 1311768467294899695) - ;; Exactness: - ("#e1" 1) ("#e1.2" 1) ("#i1.1" 1.1) ("#i1" 1.0) - ;; Integers: - ("1" ,(1+ 0)) ("23" ,(+ 9 9 5)) ("-1" ,(- 0 1)) - ("-45" ,(- 0 45)) ("2#" 20.0) ("2##" 200.0) ("12##" 1200.0) - ("#b#i100" 4.0) - ;; Rationals: - ("1/1" 1) ("1/2" 0.5) ("-1/2" -0.5) ("1#/1" 10.0) - ("10/1#" 1.0) ("1#/1#" 1.0) ("#e9/10" 1) ("#e10/1#" 1) - ("#i6/8" 0.75) ("#i1/1" 1.0) - ;; Decimal numbers: - ;; * <uinteger 10> <suffix> - ("1e2" 100.0) ("1E2" 100.0) ("1s2" 100.0) ("1S2" 100.0) - ("1f2" 100.0) ("1F2" 100.0) ("1d2" 100.0) ("1D2" 100.0) - ("1l2" 100.0) ("1L2" 100.0) ("1e+2" 100.0) ("1e-2" 0.01) - ;; * . <digit 10>+ #* <suffix> - (".1" .1) (".0123456789" 123456789e-10) (".16#" 0.16) - (".0123456789e10" 123456789.0) (".16#e3" 160.0) ("#d.3" 0.3) - ;; * <digit 10>+ . <digit 10>* #* <suffix> - ("3." ,(exact->inexact 3)) ("3.e0" ,(exact->inexact 3)) - ("3.1" ,(exact->inexact 31/10)) ("3.1e0" 3.1) ("3.1#" 3.1) - ("3.1#e0" 3.1) - ;; * <digit 10>+ #+ . #* <suffix> - ("3#." 30.0) ("3#.e0" 30.0) ("3#.#" 30.0) ("3#.#e0" 30.0) - ;; Complex: - ("1@0" 1.0) ("1@+0" 1.0) ("1@-0" 1.0) - ("2+3i" ,(+ 2 (* 3 +i))) ("4-5i" ,(- 4 (* 5 +i))) - ("1+i" 1+1i) ("1-i" 1-1i) ("+1i" 0+1i) ("-1i" 0-1i) - ("+i" +1i) ("-i" -1i))) - #t) - - (pass-if-exception "exponent too big" - exception:out-of-range - (string->number "12.13e141414"))) - -;;; -;;; number? -;;; - -;;; -;;; complex? -;;; - -;;; -;;; real? -;;; - -;;; -;;; rational? -;;; - -;;; -;;; integer? -;;; - -;;; -;;; inexact? -;;; - -;;; -;;; = -;;; - -;;; -;;; < -;;; - -(with-test-prefix "<" - - (expect-fail "documented?" - (documented? <)) - - (with-test-prefix "(< 0 n)" - - (pass-if "n = 0" - (not (< 0 0))) - - (pass-if "n = 0.0" - (not (< 0 0.0))) - - (pass-if "n = 1" - (< 0 1)) - - (pass-if "n = 1.0" - (< 0 1.0)) - - (pass-if "n = -1" - (not (< 0 -1))) - - (pass-if "n = -1.0" - (not (< 0 -1.0))) - - (pass-if "n = fixnum-max" - (< 0 fixnum-max)) - - (pass-if "n = fixnum-max + 1" - (< 0 (+ fixnum-max 1))) - - (pass-if "n = fixnum-min" - (not (< 0 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (not (< 0 (- fixnum-min 1))))) - - (with-test-prefix "(< 0.0 n)" - - (pass-if "n = 0" - (not (< 0.0 0))) - - (pass-if "n = 0.0" - (not (< 0.0 0.0))) - - (pass-if "n = 1" - (< 0.0 1)) - - (pass-if "n = 1.0" - (< 0.0 1.0)) - - (pass-if "n = -1" - (not (< 0.0 -1))) - - (pass-if "n = -1.0" - (not (< 0.0 -1.0))) - - (pass-if "n = fixnum-max" - (< 0.0 fixnum-max)) - - (pass-if "n = fixnum-max + 1" - (< 0.0 (+ fixnum-max 1))) - - (pass-if "n = fixnum-min" - (not (< 0.0 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (not (< 0.0 (- fixnum-min 1))))) - - (with-test-prefix "(< 1 n)" - - (pass-if "n = 0" - (not (< 1 0))) - - (pass-if "n = 0.0" - (not (< 1 0.0))) - - (pass-if "n = 1" - (not (< 1 1))) - - (pass-if "n = 1.0" - (not (< 1 1.0))) - - (pass-if "n = -1" - (not (< 1 -1))) - - (pass-if "n = -1.0" - (not (< 1 -1.0))) - - (pass-if "n = fixnum-max" - (< 1 fixnum-max)) - - (pass-if "n = fixnum-max + 1" - (< 1 (+ fixnum-max 1))) - - (pass-if "n = fixnum-min" - (not (< 1 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (not (< 1 (- fixnum-min 1))))) - - (with-test-prefix "(< 1.0 n)" - - (pass-if "n = 0" - (not (< 1.0 0))) - - (pass-if "n = 0.0" - (not (< 1.0 0.0))) - - (pass-if "n = 1" - (not (< 1.0 1))) - - (pass-if "n = 1.0" - (not (< 1.0 1.0))) - - (pass-if "n = -1" - (not (< 1.0 -1))) - - (pass-if "n = -1.0" - (not (< 1.0 -1.0))) - - (pass-if "n = fixnum-max" - (< 1.0 fixnum-max)) - - (pass-if "n = fixnum-max + 1" - (< 1.0 (+ fixnum-max 1))) - - (pass-if "n = fixnum-min" - (not (< 1.0 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (not (< 1.0 (- fixnum-min 1))))) - - (with-test-prefix "(< -1 n)" - - (pass-if "n = 0" - (< -1 0)) - - (pass-if "n = 0.0" - (< -1 0.0)) - - (pass-if "n = 1" - (< -1 1)) - - (pass-if "n = 1.0" - (< -1 1.0)) - - (pass-if "n = -1" - (not (< -1 -1))) - - (pass-if "n = -1.0" - (not (< -1 -1.0))) - - (pass-if "n = fixnum-max" - (< -1 fixnum-max)) - - (pass-if "n = fixnum-max + 1" - (< -1 (+ fixnum-max 1))) - - (pass-if "n = fixnum-min" - (not (< -1 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (not (< -1 (- fixnum-min 1))))) - - (with-test-prefix "(< -1.0 n)" - - (pass-if "n = 0" - (< -1.0 0)) - - (pass-if "n = 0.0" - (< -1.0 0.0)) - - (pass-if "n = 1" - (< -1.0 1)) - - (pass-if "n = 1.0" - (< -1.0 1.0)) - - (pass-if "n = -1" - (not (< -1.0 -1))) - - (pass-if "n = -1.0" - (not (< -1.0 -1.0))) - - (pass-if "n = fixnum-max" - (< -1.0 fixnum-max)) - - (pass-if "n = fixnum-max + 1" - (< -1.0 (+ fixnum-max 1))) - - (pass-if "n = fixnum-min" - (not (< -1.0 fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (not (< -1.0 (- fixnum-min 1))))) - - (with-test-prefix "(< fixnum-max n)" - - (pass-if "n = 0" - (not (< fixnum-max 0))) - - (pass-if "n = 0.0" - (not (< fixnum-max 0.0))) - - (pass-if "n = 1" - (not (< fixnum-max 1))) - - (pass-if "n = 1.0" - (not (< fixnum-max 1.0))) - - (pass-if "n = -1" - (not (< fixnum-max -1))) - - (pass-if "n = -1.0" - (not (< fixnum-max -1.0))) - - (pass-if "n = fixnum-max" - (not (< fixnum-max fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (< fixnum-max (+ fixnum-max 1))) - - (pass-if "n = fixnum-min" - (not (< fixnum-max fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (not (< fixnum-max (- fixnum-min 1))))) - - (with-test-prefix "(< (+ fixnum-max 1) n)" - - (pass-if "n = 0" - (not (< (+ fixnum-max 1) 0))) - - (pass-if "n = 0.0" - (not (< (+ fixnum-max 1) 0.0))) - - (pass-if "n = 1" - (not (< (+ fixnum-max 1) 1))) - - (pass-if "n = 1.0" - (not (< (+ fixnum-max 1) 1.0))) - - (pass-if "n = -1" - (not (< (+ fixnum-max 1) -1))) - - (pass-if "n = -1.0" - (not (< (+ fixnum-max 1) -1.0))) - - (pass-if "n = fixnum-max" - (not (< (+ fixnum-max 1) fixnum-max))) - - (pass-if "n = fixnum-max + 1" - (not (< (+ fixnum-max 1) (+ fixnum-max 1)))) - - (pass-if "n = fixnum-min" - (not (< (+ fixnum-max 1) fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (not (< (+ fixnum-max 1) (- fixnum-min 1))))) - - (with-test-prefix "(< fixnum-min n)" - - (pass-if "n = 0" - (< fixnum-min 0)) - - (pass-if "n = 0.0" - (< fixnum-min 0.0)) - - (pass-if "n = 1" - (< fixnum-min 1)) - - (pass-if "n = 1.0" - (< fixnum-min 1.0)) - - (pass-if "n = -1" - (< fixnum-min -1)) - - (pass-if "n = -1.0" - (< fixnum-min -1.0)) - - (pass-if "n = fixnum-max" - (< fixnum-min fixnum-max)) - - (pass-if "n = fixnum-max + 1" - (< fixnum-min (+ fixnum-max 1))) - - (pass-if "n = fixnum-min" - (not (< fixnum-min fixnum-min))) - - (pass-if "n = fixnum-min - 1" - (not (< fixnum-min (- fixnum-min 1))))) - - (with-test-prefix "(< (- fixnum-min 1) n)" - - (pass-if "n = 0" - (< (- fixnum-min 1) 0)) - - (pass-if "n = 0.0" - (< (- fixnum-min 1) 0.0)) - - (pass-if "n = 1" - (< (- fixnum-min 1) 1)) - - (pass-if "n = 1.0" - (< (- fixnum-min 1) 1.0)) - - (pass-if "n = -1" - (< (- fixnum-min 1) -1)) - - (pass-if "n = -1.0" - (< (- fixnum-min 1) -1.0)) - - (pass-if "n = fixnum-max" - (< (- fixnum-min 1) fixnum-max)) - - (pass-if "n = fixnum-max + 1" - (< (- fixnum-min 1) (+ fixnum-max 1))) - - (pass-if "n = fixnum-min" - (< (- fixnum-min 1) fixnum-min)) - - (pass-if "n = fixnum-min - 1" - (not (< (- fixnum-min 1) (- fixnum-min 1)))))) - -;;; -;;; > -;;; - -;;; -;;; <= -;;; - -;;; -;;; >= -;;; - -;;; -;;; zero? -;;; - -;;; -;;; positive? -;;; - -;;; -;;; negative? -;;; - -;;; -;;; max -;;; - -;;; -;;; min -;;; - -;;; -;;; + -;;; - -(with-test-prefix "+" - - (expect-fail "documented?" - (documented? +)) - - (with-test-prefix "wrong type argument" - - (pass-if-exception "1st argument string" - exception:wrong-type-arg - (+ "1" 2)) - - (pass-if-exception "2nd argument bool" - exception:wrong-type-arg - (+ 1 #f)))) -;;; -;;; - -;;; - -;;; -;;; * -;;; - -;;; -;;; / -;;; - -(with-test-prefix "/" - - (expect-fail "documented?" - (documented? /)) - - (with-test-prefix "division by zero" - - (pass-if-exception "(/ 0)" - exception:numerical-overflow - (/ 0)) - - (pass-if "(/ 0.0)" - (= +inf.0 (/ 0.0))) - - (pass-if-exception "(/ 1 0)" - exception:numerical-overflow - (/ 1 0)) - - (pass-if "(/ 1 0.0)" - (= +inf.0 (/ 1 0.0))) - - (pass-if-exception "(/ bignum 0)" - exception:numerical-overflow - (/ (+ fixnum-max 1) 0)) - - (pass-if "(/ bignum 0.0)" - (= +inf.0 (/ (+ fixnum-max 1) 0.0))) - - (pass-if-exception "(/ 1.0 0)" - exception:numerical-overflow - (/ 1.0 0)) - - (pass-if "(/ 1.0 0.0)" - (= +inf.0 (/ 1.0 0.0))) - - (pass-if-exception "(/ +i 0)" - exception:numerical-overflow - (/ +i 0)) - - (pass-if "(/ +i 0.0)" - (= +inf.0 (imag-part (/ +i 0.0))))) - - (with-test-prefix "complex division" - - (pass-if "(/ 3+4i)" - (= (/ 3+4i) 0.12-0.16i)) - - (pass-if "(/ 4+3i)" - (= (/ 4+3i) 0.16-0.12i)) - - (pass-if "(/ 25+125i 3+4i)" - (= (/ 25+125i 3+4i) 23.0+11.0i)) - - (pass-if "(/ 25+125i 4+3i)" - (= (/ 25+125i 4+3i) 19.0+17.0i)) - - (pass-if "(/ 25 3+4i)" - (= (/ 25 3+4i) 3.0-4.0i)) - - (pass-if "(/ 25 4+3i)" - (= (/ 25 4+3i) 4.0-3.0i)) - - (pass-if "(/ 1e200+1e200i)" - (= (/ 1e200+1e200i) 5.0e-201-5.0e-201i)))) - -;;; -;;; truncate -;;; - -;;; -;;; round -;;; - -;;; -;;; exact->inexact -;;; - -;;; -;;; floor -;;; - -;;; -;;; ceiling -;;; - -;;; -;;; make-rectangular -;;; - -;;; -;;; make-polar -;;; - -;;; -;;; real-part -;;; - -;;; -;;; imag-part -;;; - -;;; -;;; magnitude -;;; - -;;; -;;; angle -;;; - -;;; -;;; inexact->exact -;;; diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test deleted file mode 100644 index 4f356b020..000000000 --- a/test-suite/tests/optargs.test +++ /dev/null @@ -1,29 +0,0 @@ -;;;; optargs.test --- test suite for optional arg processing -*- scheme -*- -;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001 -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (test-suite lib) - (ice-9 optargs)) - -(with-test-prefix "optional argument processing" - (define* (test-1 #:optional (x 0)) - (define d 1) ; local define - #t) - (pass-if "local defines work with optional arguments" - (false-if-exception (test-1)))) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test deleted file mode 100644 index cc46ee855..000000000 --- a/test-suite/tests/ports.test +++ /dev/null @@ -1,466 +0,0 @@ -;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 -;;;; -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (test-suite lib) - (ice-9 popen) - (ice-9 rdelim)) - -(define (display-line . args) - (for-each display args) - (newline)) - -(define (test-file) - (data-file-name "ports-test.tmp")) - - -;;;; Some general utilities for testing ports. - -;;; Read from PORT until EOF, and return the result as a string. -(define (read-all port) - (let loop ((chars '())) - (let ((char (read-char port))) - (if (eof-object? char) - (list->string (reverse! chars)) - (loop (cons char chars)))))) - -(define (read-file filename) - (let* ((port (open-input-file filename)) - (string (read-all port))) - (close-port port) - string)) - - -;;;; Normal file ports. - -;;; Write out an s-expression, and read it back. -(let ((string '("From fairest creatures we desire increase," - "That thereby beauty's rose might never die,")) - (filename (test-file))) - (let ((port (open-output-file filename))) - (write string port) - (close-port port)) - (let ((port (open-input-file filename))) - (let ((in-string (read port))) - (pass-if "file: write and read back list of strings" - (equal? string in-string))) - (close-port port)) - (delete-file filename)) - -;;; Write out a string, and read it back a character at a time. -(let ((string "This is a test string\nwith no newline at the end") - (filename (test-file))) - (let ((port (open-output-file filename))) - (display string port) - (close-port port)) - (let ((in-string (read-file filename))) - (pass-if "file: write and read back characters" - (equal? string in-string))) - (delete-file filename)) - -;;; Buffered input/output port with seeking. -(let* ((filename (test-file)) - (port (open-file filename "w+"))) - (display "J'Accuse" port) - (seek port -1 SEEK_CUR) - (pass-if "file: r/w 1" - (char=? (read-char port) #\e)) - (pass-if "file: r/w 2" - (eof-object? (read-char port))) - (seek port -1 SEEK_CUR) - (write-char #\x port) - (seek port 7 SEEK_SET) - (pass-if "file: r/w 3" - (char=? (read-char port) #\x)) - (seek port -2 SEEK_END) - (pass-if "file: r/w 4" - (char=? (read-char port) #\s)) - (close-port port) - (delete-file filename)) - -;;; Unbuffered input/output port with seeking. -(let* ((filename (test-file)) - (port (open-file filename "w+0"))) - (display "J'Accuse" port) - (seek port -1 SEEK_CUR) - (pass-if "file: ub r/w 1" - (char=? (read-char port) #\e)) - (pass-if "file: ub r/w 2" - (eof-object? (read-char port))) - (seek port -1 SEEK_CUR) - (write-char #\x port) - (seek port 7 SEEK_SET) - (pass-if "file: ub r/w 3" - (char=? (read-char port) #\x)) - (seek port -2 SEEK_END) - (pass-if "file: ub r/w 4" - (char=? (read-char port) #\s)) - (close-port port) - (delete-file filename)) - -;;; Buffered output-only and input-only ports with seeking. -(let* ((filename (test-file)) - (port (open-output-file filename))) - (display "J'Accuse" port) - (pass-if "file: out tell" - (= (seek port 0 SEEK_CUR) 8)) - (seek port -1 SEEK_CUR) - (write-char #\x port) - (close-port port) - (let ((iport (open-input-file filename))) - (pass-if "file: in tell 0" - (= (seek iport 0 SEEK_CUR) 0)) - (read-char iport) - (pass-if "file: in tell 1" - (= (seek iport 0 SEEK_CUR) 1)) - (unread-char #\z iport) - (pass-if "file: in tell 0 after unread" - (= (seek iport 0 SEEK_CUR) 0)) - (pass-if "file: unread char still there" - (char=? (read-char iport) #\z)) - (seek iport 7 SEEK_SET) - (pass-if "file: in last char" - (char=? (read-char iport) #\x)) - (close-port iport)) - (delete-file filename)) - -;;; unusual characters. -(let* ((filename (test-file)) - (port (open-output-file filename))) - (display (string #\nul (integer->char 255) (integer->char 128) - #\nul) port) - (close-port port) - (let* ((port (open-input-file filename)) - (line (read-line port))) - (pass-if "file: read back NUL 1" - (char=? (string-ref line 0) #\nul)) - (pass-if "file: read back 255" - (char=? (string-ref line 1) (integer->char 255))) - (pass-if "file: read back 128" - (char=? (string-ref line 2) (integer->char 128))) - (pass-if "file: read back NUL 2" - (char=? (string-ref line 3) #\nul)) - (pass-if "file: EOF" - (eof-object? (read-char port))) - (close-port port)) - (delete-file filename)) - -;;; line buffering mode. -(let* ((filename (test-file)) - (port (open-file filename "wl")) - (test-string "one line more or less")) - (write-line test-string port) - (let* ((in-port (open-input-file filename)) - (line (read-line in-port))) - (close-port in-port) - (close-port port) - (pass-if "file: line buffering" - (string=? line test-string))) - (delete-file filename)) - -;;; ungetting characters and strings. -(with-input-from-string "walk on the moon\nmoon" - (lambda () - (read-char) - (unread-char #\a (current-input-port)) - (pass-if "unread-char" - (char=? (read-char) #\a)) - (read-line) - (let ((replacenoid "chicken enchilada")) - (unread-char #\newline (current-input-port)) - (unread-string replacenoid (current-input-port)) - (pass-if "unread-string" - (string=? (read-line) replacenoid))) - (pass-if "unread residue" - (string=? (read-line) "moon")))) - -;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on -;;; the reading end. try to read a byte: should get EAGAIN or -;;; EWOULDBLOCK error. -(let* ((p (pipe)) - (r (car p))) - (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK)) - (pass-if "non-blocking-I/O" - (catch 'system-error - (lambda () (read-char r) #f) - (lambda (key . args) - (and (eq? key 'system-error) - (let ((errno (car (list-ref args 3)))) - (or (= errno EAGAIN) - (= errno EWOULDBLOCK)))))))) - - -;;;; Pipe (popen) ports. - -;;; Run a command, and read its output. -(let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r")) - (in-string (read-all pipe))) - (close-pipe pipe) - (pass-if "pipe: read" - (equal? in-string "Howdy there, partner!\n"))) - -;;; Run a command, send some output to it, and see if it worked. -(let* ((filename (test-file)) - (pipe (open-pipe (string-append "grep Mommy > " filename) "w"))) - (display "Now Jimmy lives on a mushroom cloud\n" pipe) - (display "Mommy, why does everybody have a bomb?\n" pipe) - (close-pipe pipe) - (let ((in-string (read-file filename))) - (pass-if "pipe: write" - (equal? in-string "Mommy, why does everybody have a bomb?\n"))) - (delete-file filename)) - - -;;;; Void ports. These are so trivial we don't test them. - - -;;;; String ports. - -(with-test-prefix "string ports" - - ;; Write text to a string port. - (let* ((string "Howdy there, partner!") - (in-string (call-with-output-string - (lambda (port) - (display string port) - (newline port))))) - (pass-if "display text" - (equal? in-string (string-append string "\n")))) - - ;; Write an s-expression to a string port. - (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926)) - (in-sexpr - (call-with-input-string (call-with-output-string - (lambda (port) - (write sexpr port))) - read))) - (pass-if "write/read sexpr" - (equal? in-sexpr sexpr))) - - ;; seeking and unreading from an input string. - (let ((text "that text didn't look random to me")) - (call-with-input-string text - (lambda (p) - (pass-if "input tell 0" - (= (seek p 0 SEEK_CUR) 0)) - (read-char p) - (pass-if "input tell 1" - (= (seek p 0 SEEK_CUR) 1)) - (unread-char #\x p) - (pass-if "input tell back to 0" - (= (seek p 0 SEEK_CUR) 0)) - (pass-if "input ungetted char" - (char=? (read-char p) #\x)) - (seek p 0 SEEK_END) - (pass-if "input seek to end" - (= (seek p 0 SEEK_CUR) - (string-length text))) - (unread-char #\x p) - (pass-if "input seek to beginning" - (= (seek p 0 SEEK_SET) 0)) - (pass-if "input reread first char" - (char=? (read-char p) - (string-ref text 0)))))) - - ;; seeking an output string. - (let* ((text "123456789") - (len (string-length text)) - (result (call-with-output-string - (lambda (p) - (pass-if "output tell 0" - (= (seek p 0 SEEK_CUR) 0)) - (display text p) - (pass-if "output tell end" - (= (seek p 0 SEEK_CUR) len)) - (pass-if "output seek to beginning" - (= (seek p 0 SEEK_SET) 0)) - (write-char #\a p) - (seek p -1 SEEK_END) - (pass-if "output seek to last char" - (= (seek p 0 SEEK_CUR) - (- len 1))) - (write-char #\b p))))) - (string-set! text 0 #\a) - (string-set! text (- len 1) #\b) - (pass-if "output check" - (string=? text result)))) - - - -;;;; Soft ports. No tests implemented yet. - - -;;;; Generic operations across all port types. - -(let ((port-loop-temp (test-file))) - - ;; Return a list of input ports that all return the same text. - ;; We map tests over this list. - (define (input-port-list text) - - ;; Create a text file some of the ports will use. - (let ((out-port (open-output-file port-loop-temp))) - (display text out-port) - (close-port out-port)) - - (list (open-input-file port-loop-temp) - (open-input-pipe (string-append "cat " port-loop-temp)) - (call-with-input-string text (lambda (x) x)) - ;; We don't test soft ports at the moment. - )) - - (define port-list-names '("file" "pipe" "string")) - - ;; Test the line counter. - (define (test-line-counter text second-line final-column) - (with-test-prefix "line counter" - (let ((ports (input-port-list text))) - (for-each - (lambda (port port-name) - (with-test-prefix port-name - (pass-if "at beginning of input" - (= (port-line port) 0)) - (pass-if "read first character" - (eqv? (read-char port) #\x)) - (pass-if "after reading one character" - (= (port-line port) 0)) - (pass-if "read first newline" - (eqv? (read-char port) #\newline)) - (pass-if "after reading first newline char" - (= (port-line port) 1)) - (pass-if "second line read correctly" - (equal? (read-line port) second-line)) - (pass-if "read-line increments line number" - (= (port-line port) 2)) - (pass-if "read-line returns EOF" - (let loop ((i 0)) - (cond - ((eof-object? (read-line port)) #t) - ((> i 20) #f) - (else (loop (+ i 1)))))) - (pass-if "line count is 5 at EOF" - (= (port-line port) 5)) - (pass-if "column is correct at EOF" - (= (port-column port) final-column)))) - ports port-list-names) - (for-each close-port ports) - (delete-file port-loop-temp)))) - - (with-test-prefix "newline" - (test-line-counter - (string-append "x\n" - "He who receives an idea from me, receives instruction\n" - "himself without lessening mine; as he who lights his\n" - "taper at mine, receives light without darkening me.\n" - " --- Thomas Jefferson\n") - "He who receives an idea from me, receives instruction" - 0)) - - (with-test-prefix "no newline" - (test-line-counter - (string-append "x\n" - "He who receives an idea from me, receives instruction\n" - "himself without lessening mine; as he who lights his\n" - "taper at mine, receives light without darkening me.\n" - " --- Thomas Jefferson\n" - "no newline here") - "He who receives an idea from me, receives instruction" - 15))) - -;; Test port-line and port-column for output ports - -(define (test-output-line-counter text final-column) - (with-test-prefix "port-line and port-column for output ports" - (let ((port (open-output-string))) - (pass-if "at beginning of input" - (and (= (port-line port) 0) - (= (port-column port) 0))) - (write-char #\x port) - (pass-if "after writing one character" - (and (= (port-line port) 0) - (= (port-column port) 1))) - (write-char #\newline port) - (pass-if "after writing first newline char" - (and (= (port-line port) 1) - (= (port-column port) 0))) - (display text port) - (pass-if "line count is 5 at end" - (= (port-line port) 5)) - (pass-if "column is correct at end" - (= (port-column port) final-column))))) - -(test-output-line-counter - (string-append "He who receives an idea from me, receives instruction\n" - "himself without lessening mine; as he who lights his\n" - "taper at mine, receives light without darkening me.\n" - " --- Thomas Jefferson\n" - "no newline here") - 15) - -;;;; testing read-delimited and friends - -(with-test-prefix "read-delimited!" - (let ((c (make-string 20 #\!))) - (call-with-input-string - "defdef\nghighi\n" - (lambda (port) - - (read-delimited! "\n" c port 'concat) - (pass-if "read-delimited! reads a first line" - (string=? c "defdef\n!!!!!!!!!!!!!")) - - (read-delimited! "\n" c port 'concat 3) - (pass-if "read-delimited! reads a first line" - (string=? c "defghighi\n!!!!!!!!!!")))))) - - -;;;; char-ready? - -(call-with-input-string - "howdy" - (lambda (port) - (pass-if "char-ready? returns true on string port" - (char-ready? port)))) - -;;; This segfaults on some versions of Guile. We really should run -;;; the tests in a subprocess... - -(call-with-input-string - "howdy" - (lambda (port) - (with-input-from-port - port - (lambda () - (pass-if "char-ready? returns true on string port as default port" - (char-ready?)))))) - - -;;;; Close current-input-port, and make sure everyone can handle it. - -(with-test-prefix "closing current-input-port" - (for-each (lambda (procedure name) - (with-input-from-port - (call-with-input-string "foo" (lambda (p) p)) - (lambda () - (close-port (current-input-port)) - (pass-if-exception name - exception:wrong-type-arg - (procedure))))) - (list read read-char read-line) - '("read" "read-char" "read-line"))) diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test deleted file mode 100644 index c9fbb1525..000000000 --- a/test-suite/tests/r4rs.test +++ /dev/null @@ -1,1024 +0,0 @@ -;;;; r4rs.test --- tests for R4RS compliance -*- scheme -*- -;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - - -;;;; ============= NOTE ============= - -;;;; This file is a quick-and-dirty adaptation of Aubrey's test suite -;;;; to Guile's testing framework. As such, it's not as clean as one -;;;; might hope. (In particular, it uses with-test-prefix oddly.) -;;;; -;;;; If you're looking for an example of a test suite to imitate, you -;;;; might do better by looking at ports.test, which uses the -;;;; (test-suite lib) functions much more idiomatically. - - -;;;; "test.scm" Test correctness of scheme implementations. -;;;; Author: Aubrey Jaffer -;;;; Modified: Mikael Djurfeldt -;;;; Removed tests which Guile deliberately -;;;; won't pass. Made the the tests (test-cont), (test-sc4), and -;;;; (test-delay) start to run automatically. -;;;; Modified: Jim Blandy -;;;; adapted to new Guile test suite framework - -;;; This includes examples from -;;; William Clinger and Jonathan Rees, editors. -;;; Revised^4 Report on the Algorithmic Language Scheme -;;; and the IEEE specification. - -;;; The input tests read this file expecting it to be named -;;; "test.scm", so you'll have to run it from the ice-9 source -;;; directory, or copy this file elsewhere -;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running -;;; these tests. You may need to delete them in order to run -;;; "test.scm" more than once. - -;;; There are three optional tests: -;;; (TEST-CONT) tests multiple returns from call-with-current-continuation -;;; -;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE -;;; -;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by -;;; either standard. - -;;; If you are testing a R3RS version which does not have `list?' do: -;;; (define list? #f) - -;;; send corrections or additions to jaffer@ai.mit.edu or -;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA - -(define cur-section '())(define errs '()) -(define SECTION (lambda args - (set! cur-section args) #t)) -(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) -(define (report-errs) #f) - -(define test - (lambda (expect fun . args) - (let ((res (if (procedure? fun) (apply fun args) (car args)))) - (with-test-prefix cur-section - (pass-if (call-with-output-string (lambda (port) - (write (cons fun args) port))) - (equal? expect res)))))) - -;; test that all symbol characters are supported. -(SECTION 2 1) -'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.) - -(SECTION 3 4) -(define disjoint-type-functions - (list boolean? char? null? number? pair? procedure? string? symbol? vector?)) -(define type-examples - (list - #t #f #\a '() 9739 '(test) (lambda () #f) car "test" "" 'test - '#() '#(a b c))) -(define type-matrix - (map (lambda (x) - (let ((t (map (lambda (f) (f x)) disjoint-type-functions))) - t)) - type-examples)) -(for-each (lambda (object row) - (let ((count (apply + (map (lambda (elt) (if elt 1 0)) - row)))) - (pass-if (call-with-output-string - (lambda (port) - (display "object recognized by only one predicate: " - port) - (display object port))) - (= count 1)))) - type-examples - type-matrix) - -(SECTION 4 1 2) -(test '(quote a) 'quote (quote 'a)) -(test '(quote a) 'quote ''a) -(SECTION 4 1 3) -(test 12 (if #f + *) 3 4) -(SECTION 4 1 4) -(test 8 (lambda (x) (+ x x)) 4) -(define reverse-subtract - (lambda (x y) (- y x))) -(test 3 reverse-subtract 7 10) -(define add4 - (let ((x 4)) - (lambda (y) (+ x y)))) -(test 10 add4 6) -(test '(3 4 5 6) (lambda x x) 3 4 5 6) -(test '(5 6) (lambda (x y . z) z) 3 4 5 6) -(SECTION 4 1 5) -(test 'yes 'if (if (> 3 2) 'yes 'no)) -(test 'no 'if (if (> 2 3) 'yes 'no)) -(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2))) -(SECTION 4 1 6) -(define x 2) -(test 3 'define (+ x 1)) -(set! x 4) -(test 5 'set! (+ x 1)) -(SECTION 4 2 1) -(test 'greater 'cond (cond ((> 3 2) 'greater) - ((< 3 2) 'less))) -(test 'equal 'cond (cond ((> 3 3) 'greater) - ((< 3 3) 'less) - (else 'equal))) -(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr) - (else #f))) -(test 'composite 'case (case (* 2 3) - ((2 3 5 7) 'prime) - ((1 4 6 8 9) 'composite))) -(test 'consonant 'case (case (car '(c d)) - ((a e i o u) 'vowel) - ((w y) 'semivowel) - (else 'consonant))) -(test #t 'and (and (= 2 2) (> 2 1))) -(test #f 'and (and (= 2 2) (< 2 1))) -(test '(f g) 'and (and 1 2 'c '(f g))) -(test #t 'and (and)) -(test #t 'or (or (= 2 2) (> 2 1))) -(test #t 'or (or (= 2 2) (< 2 1))) -(test #f 'or (or #f #f #f)) -(test #f 'or (or)) -(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0))) -(SECTION 4 2 2) -(test 6 'let (let ((x 2) (y 3)) (* x y))) -(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) -(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) -(test #t 'letrec (letrec ((even? - (lambda (n) (if (zero? n) #t (odd? (- n 1))))) - (odd? - (lambda (n) (if (zero? n) #f (even? (- n 1)))))) - (even? 88))) -(define x 34) -(test 5 'let (let ((x 3)) (define x 5) x)) -(test 34 'let x) -(test 6 'let (let () (define x 6) x)) -(test 34 'let x) -(test 7 'let* (let* ((x 3)) (define x 7) x)) -(test 34 'let* x) -(test 8 'let* (let* () (define x 8) x)) -(test 34 'let* x) -(test 9 'letrec (letrec () (define x 9) x)) -(test 34 'letrec x) -(test 10 'letrec (letrec ((x 3)) (define x 10) x)) -(test 34 'letrec x) -(SECTION 4 2 3) -(define x 0) -(test 6 'begin (begin (set! x 5) (+ x 1))) -(SECTION 4 2 4) -(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5)) - (i 0 (+ i 1))) - ((= i 5) vec) - (vector-set! vec i i))) -(test 25 'do (let ((x '(1 3 5 7 9))) - (do ((x x (cdr x)) - (sum 0 (+ sum (car x)))) - ((null? x) sum)))) -(test 1 'let (let foo () 1)) -(test '((6 1 3) (-5 -2)) 'let - (let loop ((numbers '(3 -2 1 6 -5)) - (nonneg '()) - (neg '())) - (cond ((null? numbers) (list nonneg neg)) - ((negative? (car numbers)) - (loop (cdr numbers) - nonneg - (cons (car numbers) neg))) - (else - (loop (cdr numbers) - (cons (car numbers) nonneg) - neg))))) -(SECTION 4 2 6) -(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) -(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) -(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) -(test '((foo 7) . cons) - 'quasiquote - `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) - -;;; sqt is defined here because not all implementations are required to -;;; support it. -(define (sqt x) - (do ((i 0 (+ i 1))) - ((> (* i i) x) (- i 1)))) - -(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8)) -(test 5 'quasiquote `,(+ 2 3)) -(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) - 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) -(test '(a `(b ,x ,'y d) e) 'quasiquote - (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e))) -(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) -(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4))) -(SECTION 5 2 1) -(define add3 (lambda (x) (+ x 3))) -(test 6 'define (add3 3)) -(define first car) -(test 1 'define (first '(1 2))) -(SECTION 5 2 2) -(test 45 'define - (let ((x 5)) - (define foo (lambda (y) (bar x y))) - (define bar (lambda (a b) (+ (* a b) a))) - (foo (+ x 3)))) -(define x 34) -(define (foo) (define x 5) x) -(test 5 foo) -(test 34 'define x) -(define foo (lambda () (define x 5) x)) -(test 5 foo) -(test 34 'define x) -(define (foo x) ((lambda () (define x 5) x)) x) -(test 88 foo 88) -(test 4 foo 4) -(test 34 'define x) -(SECTION 6 1) -(test #f not #t) -(test #f not 3) -(test #f not (list 3)) -(test #t not #f) -(test #f not '()) -(test #f not (list)) -(test #f not 'nil) - -(test #t boolean? #f) -(test #f boolean? 0) -(test #f boolean? '()) -(SECTION 6 2) -(test #t eqv? 'a 'a) -(test #f eqv? 'a 'b) -(test #t eqv? 2 2) -(test #t eqv? '() '()) -(test #t eqv? '10000 '10000) -(test #f eqv? (cons 1 2)(cons 1 2)) -(test #f eqv? (lambda () 1) (lambda () 2)) -(test #f eqv? #f 'nil) -(let ((p (lambda (x) x))) - (test #t eqv? p p)) -(define gen-counter - (lambda () - (let ((n 0)) - (lambda () (set! n (+ n 1)) n)))) -(let ((g (gen-counter))) (test #t eqv? g g)) -(test #f eqv? (gen-counter) (gen-counter)) -(letrec ((f (lambda () (if (eqv? f g) 'f 'both))) - (g (lambda () (if (eqv? f g) 'g 'both)))) - (test #f eqv? f g)) - -(test #t eq? 'a 'a) -(test #f eq? (list 'a) (list 'a)) -(test #t eq? '() '()) -(test #t eq? car car) -(let ((x '(a))) (test #t eq? x x)) -(let ((x '#())) (test #t eq? x x)) -(let ((x (lambda (x) x))) (test #t eq? x x)) - -(test #t equal? 'a 'a) -(test #t equal? '(a) '(a)) -(test #t equal? '(a (b) c) '(a (b) c)) -(test #t equal? "abc" "abc") -(test #t equal? 2 2) -(test #t equal? (make-vector 5 'a) (make-vector 5 'a)) -(SECTION 6 3) -(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ())))))) -(define x (list 'a 'b 'c)) -(define y x) -(and list? (test #t list? y)) -(set-cdr! x 4) -(test '(a . 4) 'set-cdr! x) -(test #t eqv? x y) -(test '(a b c . d) 'dot '(a . (b . (c . d)))) -(and list? (test #f list? y)) -(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x)))) - -(test #t pair? '(a . b)) -(test #t pair? '(a . 1)) -(test #t pair? '(a b c)) -(test #f pair? '()) -(test #f pair? '#(a b)) - -(test '(a) cons 'a '()) -(test '((a) b c d) cons '(a) '(b c d)) -(test '("a" b c) cons "a" '(b c)) -(test '(a . 3) cons 'a 3) -(test '((a b) . c) cons '(a b) 'c) - -(test 'a car '(a b c)) -(test '(a) car '((a) b c d)) -(test 1 car '(1 . 2)) - -(test '(b c d) cdr '((a) b c d)) -(test 2 cdr '(1 . 2)) - -(test '(a 7 c) list 'a (+ 3 4) 'c) -(test '() list) - -(test 3 length '(a b c)) -(test 3 length '(a (b) (c d e))) -(test 0 length '()) - -(test '(x y) append '(x) '(y)) -(test '(a b c d) append '(a) '(b c d)) -(test '(a (b) (c)) append '(a (b)) '((c))) -(test '() append) -(test '(a b c . d) append '(a b) '(c . d)) -(test 'a append '() 'a) - -(test '(c b a) reverse '(a b c)) -(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f)))) - -(test 'c list-ref '(a b c d) 2) - -(test '(a b c) memq 'a '(a b c)) -(test '(b c) memq 'b '(a b c)) -(test '#f memq 'a '(b c d)) -(test '#f memq (list 'a) '(b (a) c)) -(test '((a) c) member (list 'a) '(b (a) c)) -(test '(101 102) memv 101 '(100 101 102)) - -(define e '((a 1) (b 2) (c 3))) -(test '(a 1) assq 'a e) -(test '(b 2) assq 'b e) -(test #f assq 'd e) -(test #f assq (list 'a) '(((a)) ((b)) ((c)))) -(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c)))) -(test '(5 7) assv 5 '((2 3) (5 7) (11 13))) -(SECTION 6 4) -(test #t symbol? 'foo) -(test #t symbol? (car '(a b))) -(test #f symbol? "bar") -(test #t symbol? 'nil) -(test #f symbol? '()) -(test #f symbol? #f) -;;; But first, what case are symbols in? Determine the standard case: -(define char-standard-case char-upcase) -(if (string=? (symbol->string 'A) "a") - (set! char-standard-case char-downcase)) -;;; Not for Guile -;(test #t 'standard-case -; (string=? (symbol->string 'a) (symbol->string 'A))) -;(test #t 'standard-case -; (or (string=? (symbol->string 'a) "A") -; (string=? (symbol->string 'A) "a"))) -(define (str-copy s) - (let ((v (make-string (string-length s)))) - (do ((i (- (string-length v) 1) (- i 1))) - ((< i 0) v) - (string-set! v i (string-ref s i))))) -(define (string-standard-case s) - (set! s (str-copy s)) - (do ((i 0 (+ 1 i)) - (sl (string-length s))) - ((>= i sl) s) - (string-set! s i (char-standard-case (string-ref s i))))) -;;; Not for Guile -;(test (string-standard-case "flying-fish") symbol->string 'flying-fish) -;(test (string-standard-case "martin") symbol->string 'Martin) -(test "Malvina" symbol->string (string->symbol "Malvina")) -;;; Not for Guile -;(test #t 'standard-case (eq? 'a 'A)) - -(define x (string #\a #\b)) -(define y (string->symbol x)) -(string-set! x 0 #\c) -(test "cb" 'string-set! x) -(test "ab" symbol->string y) -(test y string->symbol "ab") - -;;; Not for Guile -;(test #t eq? 'mISSISSIppi 'mississippi) -;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt"))) -(test 'JollyWog string->symbol (symbol->string 'JollyWog)) - -(SECTION 6 5 5) -(test #t number? 3) -(test #t complex? 3) -(test #t real? 3) -(test #t rational? 3) -(test #t integer? 3) - -(test #t exact? 3) -(test #f inexact? 3) - -(test #t = 22 22 22) -(test #t = 22 22) -(test #f = 34 34 35) -(test #f = 34 35) -(test #t > 3 -6246) -(test #f > 9 9 -2424) -(test #t >= 3 -4 -6246) -(test #t >= 9 9) -(test #f >= 8 9) -(test #t < -1 2 3 4 5 6 7 8) -(test #f < -1 2 3 4 4 5 6 7) -(test #t <= -1 2 3 4 5 6 7 8) -(test #t <= -1 2 3 4 4 5 6 7) -(test #f < 1 3 2) -(test #f >= 1 3 2) - -(test #t zero? 0) -(test #f zero? 1) -(test #f zero? -1) -(test #f zero? -100) -(test #t positive? 4) -(test #f positive? -4) -(test #f positive? 0) -(test #f negative? 4) -(test #t negative? -4) -(test #f negative? 0) -(test #t odd? 3) -(test #f odd? 2) -(test #f odd? -4) -(test #t odd? -1) -(test #f even? 3) -(test #t even? 2) -(test #t even? -4) -(test #f even? -1) - -(test 38 max 34 5 7 38 6) -(test -24 min 3 5 5 330 4 -24) - -(test 7 + 3 4) -(test '3 + 3) -(test 0 +) -(test 4 * 4) -(test 1 *) - -(test -1 - 3 4) -(test -3 - 3) -(test 7 abs -7) -(test 7 abs 7) -(test 0 abs 0) - -(test 5 quotient 35 7) -(test -5 quotient -35 7) -(test -5 quotient 35 -7) -(test 5 quotient -35 -7) -(test 1 modulo 13 4) -(test 1 remainder 13 4) -(test 3 modulo -13 4) -(test -1 remainder -13 4) -(test -3 modulo 13 -4) -(test 1 remainder 13 -4) -(test -1 modulo -13 -4) -(test -1 remainder -13 -4) -(define (divtest n1 n2) - (= n1 (+ (* n2 (quotient n1 n2)) - (remainder n1 n2)))) -(test #t divtest 238 9) -(test #t divtest -238 9) -(test #t divtest 238 -9) -(test #t divtest -238 -9) - -(test 4 gcd 0 4) -(test 4 gcd -4 0) -(test 4 gcd 32 -36) -(test 0 gcd) -(test 288 lcm 32 -36) -(test 1 lcm) - -;;;;From: fred@sce.carleton.ca (Fred J Kaudel) -;;; Modified by jaffer. -(define (test-inexact) - (define f3.9 (string->number "3.9")) - (define f4.0 (string->number "4.0")) - (define f-3.25 (string->number "-3.25")) - (define f.25 (string->number ".25")) - (define f4.5 (string->number "4.5")) - (define f3.5 (string->number "3.5")) - (define f0.0 (string->number "0.0")) - (define f0.8 (string->number "0.8")) - (define f1.0 (string->number "1.0")) - (define wto write-test-obj) - (define dto display-test-obj) - (define lto load-test-obj) - (SECTION 6 5 5) - (test #t inexact? f3.9) - (test #t 'inexact? (inexact? (max f3.9 4))) - (test f4.0 'max (max f3.9 4)) - (test f4.0 'exact->inexact (exact->inexact 4)) - (test (- f4.0) round (- f4.5)) - (test (- f4.0) round (- f3.5)) - (test (- f4.0) round (- f3.9)) - (test f0.0 round f0.0) - (test f0.0 round f.25) - (test f1.0 round f0.8) - (test f4.0 round f3.5) - (test f4.0 round f4.5) - (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. - (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13) - (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) - (test #t call-with-output-file - (data-file-name "tmp3") - (lambda (test-file) - (write-char #\; test-file) - (display write-test-obj test-file) - (newline test-file) - (write load-test-obj test-file) - (output-port? test-file))) - (check-test-file (data-file-name "tmp3")) - (set! write-test-obj wto) - (set! display-test-obj dto) - (set! load-test-obj lto) - (let ((x (string->number "4195835.0")) - (y (string->number "3145727.0"))) - (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y))))) - (report-errs)) - -(define (test-bignum) - (define tb - (lambda (n1 n2) - (= n1 (+ (* n2 (quotient n1 n2)) - (remainder n1 n2))))) - (SECTION 6 5 5) - (test 0 modulo -2177452800 86400) - (test 0 modulo 2177452800 -86400) - (test 0 modulo 2177452800 86400) - (test 0 modulo -2177452800 -86400) - (test #t 'remainder (tb 281474976710655 65535)) - (test #t 'remainder (tb 281474976710654 65535)) - (SECTION 6 5 6) - (test 281474976710655 string->number "281474976710655") - (test "281474976710655" number->string 281474976710655) - (report-errs)) - -(SECTION 6 5 6) -(test "0" number->string 0) -(test "100" number->string 100) -(test "100" number->string 256 16) -(test 100 string->number "100") -(test 256 string->number "100" 16) -(test #f string->number "") -(test #f string->number ".") -(test #f string->number "d") -(test #f string->number "D") -(test #f string->number "i") -(test #f string->number "I") -(test #f string->number "3i") -(test #f string->number "3I") -(test #f string->number "33i") -(test #f string->number "33I") -(test #f string->number "3.3i") -(test #f string->number "3.3I") -(test #f string->number "-") -(test #f string->number "+") - -(SECTION 6 6) -(test #t eqv? '#\ #\Space) -(test #t eqv? #\space '#\Space) -(test #t char? #\a) -(test #t char? #\() -(test #t char? #\ ) -(test #t char? '#\newline) - -(test #f char=? #\A #\B) -(test #f char=? #\a #\b) -(test #f char=? #\9 #\0) -(test #t char=? #\A #\A) - -(test #t char<? #\A #\B) -(test #t char<? #\a #\b) -(test #f char<? #\9 #\0) -(test #f char<? #\A #\A) - -(test #f char>? #\A #\B) -(test #f char>? #\a #\b) -(test #t char>? #\9 #\0) -(test #f char>? #\A #\A) - -(test #t char<=? #\A #\B) -(test #t char<=? #\a #\b) -(test #f char<=? #\9 #\0) -(test #t char<=? #\A #\A) - -(test #f char>=? #\A #\B) -(test #f char>=? #\a #\b) -(test #t char>=? #\9 #\0) -(test #t char>=? #\A #\A) - -(test #f char-ci=? #\A #\B) -(test #f char-ci=? #\a #\B) -(test #f char-ci=? #\A #\b) -(test #f char-ci=? #\a #\b) -(test #f char-ci=? #\9 #\0) -(test #t char-ci=? #\A #\A) -(test #t char-ci=? #\A #\a) - -(test #t char-ci<? #\A #\B) -(test #t char-ci<? #\a #\B) -(test #t char-ci<? #\A #\b) -(test #t char-ci<? #\a #\b) -(test #f char-ci<? #\9 #\0) -(test #f char-ci<? #\A #\A) -(test #f char-ci<? #\A #\a) - -(test #f char-ci>? #\A #\B) -(test #f char-ci>? #\a #\B) -(test #f char-ci>? #\A #\b) -(test #f char-ci>? #\a #\b) -(test #t char-ci>? #\9 #\0) -(test #f char-ci>? #\A #\A) -(test #f char-ci>? #\A #\a) - -(test #t char-ci<=? #\A #\B) -(test #t char-ci<=? #\a #\B) -(test #t char-ci<=? #\A #\b) -(test #t char-ci<=? #\a #\b) -(test #f char-ci<=? #\9 #\0) -(test #t char-ci<=? #\A #\A) -(test #t char-ci<=? #\A #\a) - -(test #f char-ci>=? #\A #\B) -(test #f char-ci>=? #\a #\B) -(test #f char-ci>=? #\A #\b) -(test #f char-ci>=? #\a #\b) -(test #t char-ci>=? #\9 #\0) -(test #t char-ci>=? #\A #\A) -(test #t char-ci>=? #\A #\a) - -(test #t char-alphabetic? #\a) -(test #t char-alphabetic? #\A) -(test #t char-alphabetic? #\z) -(test #t char-alphabetic? #\Z) -(test #f char-alphabetic? #\0) -(test #f char-alphabetic? #\9) -(test #f char-alphabetic? #\space) -(test #f char-alphabetic? #\;) - -(test #f char-numeric? #\a) -(test #f char-numeric? #\A) -(test #f char-numeric? #\z) -(test #f char-numeric? #\Z) -(test #t char-numeric? #\0) -(test #t char-numeric? #\9) -(test #f char-numeric? #\space) -(test #f char-numeric? #\;) - -(test #f char-whitespace? #\a) -(test #f char-whitespace? #\A) -(test #f char-whitespace? #\z) -(test #f char-whitespace? #\Z) -(test #f char-whitespace? #\0) -(test #f char-whitespace? #\9) -(test #t char-whitespace? #\space) -(test #f char-whitespace? #\;) - -(test #f char-upper-case? #\0) -(test #f char-upper-case? #\9) -(test #f char-upper-case? #\space) -(test #f char-upper-case? #\;) - -(test #f char-lower-case? #\0) -(test #f char-lower-case? #\9) -(test #f char-lower-case? #\space) -(test #f char-lower-case? #\;) - -(test #\. integer->char (char->integer #\.)) -(test #\A integer->char (char->integer #\A)) -(test #\a integer->char (char->integer #\a)) -(test #\A char-upcase #\A) -(test #\A char-upcase #\a) -(test #\a char-downcase #\A) -(test #\a char-downcase #\a) -(SECTION 6 7) -(test #t string? "The word \"recursion\\\" has many meanings.") -(test #t string? "") -(define f (make-string 3 #\*)) -(test "?**" 'string-set! (begin (string-set! f 0 #\?) f)) -(test "abc" string #\a #\b #\c) -(test "" string) -(test 3 string-length "abc") -(test #\a string-ref "abc" 0) -(test #\c string-ref "abc" 2) -(test 0 string-length "") -(test "" substring "ab" 0 0) -(test "" substring "ab" 1 1) -(test "" substring "ab" 2 2) -(test "a" substring "ab" 0 1) -(test "b" substring "ab" 1 2) -(test "ab" substring "ab" 0 2) -(test "foobar" string-append "foo" "bar") -(test "foo" string-append "foo") -(test "foo" string-append "foo" "") -(test "foo" string-append "" "foo") -(test "" string-append) -(test "" make-string 0) -(test #t string=? "" "") -(test #f string<? "" "") -(test #f string>? "" "") -(test #t string<=? "" "") -(test #t string>=? "" "") -(test #t string-ci=? "" "") -(test #f string-ci<? "" "") -(test #f string-ci>? "" "") -(test #t string-ci<=? "" "") -(test #t string-ci>=? "" "") - -(test #f string=? "A" "B") -(test #f string=? "a" "b") -(test #f string=? "9" "0") -(test #t string=? "A" "A") - -(test #t string<? "A" "B") -(test #t string<? "a" "b") -(test #f string<? "9" "0") -(test #f string<? "A" "A") - -(test #f string>? "A" "B") -(test #f string>? "a" "b") -(test #t string>? "9" "0") -(test #f string>? "A" "A") - -(test #t string<=? "A" "B") -(test #t string<=? "a" "b") -(test #f string<=? "9" "0") -(test #t string<=? "A" "A") - -(test #f string>=? "A" "B") -(test #f string>=? "a" "b") -(test #t string>=? "9" "0") -(test #t string>=? "A" "A") - -(test #f string-ci=? "A" "B") -(test #f string-ci=? "a" "B") -(test #f string-ci=? "A" "b") -(test #f string-ci=? "a" "b") -(test #f string-ci=? "9" "0") -(test #t string-ci=? "A" "A") -(test #t string-ci=? "A" "a") - -(test #t string-ci<? "A" "B") -(test #t string-ci<? "a" "B") -(test #t string-ci<? "A" "b") -(test #t string-ci<? "a" "b") -(test #f string-ci<? "9" "0") -(test #f string-ci<? "A" "A") -(test #f string-ci<? "A" "a") - -(test #f string-ci>? "A" "B") -(test #f string-ci>? "a" "B") -(test #f string-ci>? "A" "b") -(test #f string-ci>? "a" "b") -(test #t string-ci>? "9" "0") -(test #f string-ci>? "A" "A") -(test #f string-ci>? "A" "a") - -(test #t string-ci<=? "A" "B") -(test #t string-ci<=? "a" "B") -(test #t string-ci<=? "A" "b") -(test #t string-ci<=? "a" "b") -(test #f string-ci<=? "9" "0") -(test #t string-ci<=? "A" "A") -(test #t string-ci<=? "A" "a") - -(test #f string-ci>=? "A" "B") -(test #f string-ci>=? "a" "B") -(test #f string-ci>=? "A" "b") -(test #f string-ci>=? "a" "b") -(test #t string-ci>=? "9" "0") -(test #t string-ci>=? "A" "A") -(test #t string-ci>=? "A" "a") -(SECTION 6 8) -(test #t vector? '#(0 (2 2 2 2) "Anna")) -(test #t vector? '#()) -(test '#(a b c) vector 'a 'b 'c) -(test '#() vector) -(test 3 vector-length '#(0 (2 2 2 2) "Anna")) -(test 0 vector-length '#()) -(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5) -(test '#(0 ("Sue" "Sue") "Anna") 'vector-set - (let ((vec (vector 0 '(2 2 2 2) "Anna"))) - (vector-set! vec 1 '("Sue" "Sue")) - vec)) -(test '#(hi hi) make-vector 2 'hi) -(test '#() make-vector 0) -(test '#() make-vector 0 'a) -(SECTION 6 9) -(test #t procedure? car) -(test #f procedure? 'car) -(test #t procedure? (lambda (x) (* x x))) -(test #f procedure? '(lambda (x) (* x x))) -(test #t call-with-current-continuation procedure?) -(test 7 apply + (list 3 4)) -(test 7 apply (lambda (a b) (+ a b)) (list 3 4)) -(test 17 apply + 10 (list 3 4)) -(test '() apply list '()) -(define compose (lambda (f g) (lambda args (f (apply g args))))) -(test 30 (compose sqt *) 12 75) - -(test '(b e h) map cadr '((a b) (d e) (g h))) -(test '(5 7 9) map + '(1 2 3) '(4 5 6)) -(test '#(0 1 4 9 16) 'for-each - (let ((v (make-vector 5))) - (for-each (lambda (i) (vector-set! v i (* i i))) - '(0 1 2 3 4)) - v)) -(test -3 call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) (if (negative? x) (exit x))) - '(54 0 37 -3 245 19)) - #t)) -(define list-length - (lambda (obj) - (call-with-current-continuation - (lambda (return) - (letrec ((r (lambda (obj) (cond ((null? obj) 0) - ((pair? obj) (+ (r (cdr obj)) 1)) - (else (return #f)))))) - (r obj)))))) -(test 4 list-length '(1 2 3 4)) -(test #f list-length '(a b . c)) -(test '() map cadr '()) - -;;; This tests full conformance of call-with-current-continuation. It -;;; is a separate test because some schemes do not support call/cc -;;; other than escape procedures. I am indebted to -;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this -;;; code. The function leaf-eq? compares the leaves of 2 arbitrary -;;; trees constructed of conses. -(define (next-leaf-generator obj eot) - (letrec ((return #f) - (cont (lambda (x) - (recur obj) - (set! cont (lambda (x) (return eot))) - (cont #f))) - (recur (lambda (obj) - (if (pair? obj) - (for-each recur obj) - (call-with-current-continuation - (lambda (c) - (set! cont c) - (return obj))))))) - (lambda () (call-with-current-continuation - (lambda (ret) (set! return ret) (cont #f)))))) -(define (leaf-eq? x y) - (let* ((eot (list 'eot)) - (xf (next-leaf-generator x eot)) - (yf (next-leaf-generator y eot))) - (letrec ((loop (lambda (x y) - (cond ((not (eq? x y)) #f) - ((eq? eot x) #t) - (else (loop (xf) (yf))))))) - (loop (xf) (yf))))) -(define (test-cont) - (SECTION 6 9) - (test #t leaf-eq? '(a (b (c))) '((a) b c)) - (test #f leaf-eq? '(a (b (c))) '((a) b c d)) - (report-errs)) - -;;; Test Optional R4RS DELAY syntax and FORCE procedure -(define (test-delay) - (SECTION 6 9) - (test 3 'delay (force (delay (+ 1 2)))) - (test '(3 3) 'delay (let ((p (delay (+ 1 2)))) - (list (force p) (force p)))) - (test 2 'delay (letrec ((a-stream - (letrec ((next (lambda (n) - (cons n (delay (next (+ n 1))))))) - (next 0))) - (head car) - (tail (lambda (stream) (force (cdr stream))))) - (head (tail (tail a-stream))))) - (letrec ((count 0) - (p (delay (begin (set! count (+ count 1)) - (if (> count x) - count - (force p))))) - (x 5)) - (test 6 force p) - (set! x 10) - (test 6 force p)) - (test 3 'force - (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1))))) - (c #f)) - (force p))) - (report-errs)) - -(SECTION 6 10 1) -(test #t input-port? (current-input-port)) -(test #t output-port? (current-output-port)) -(test #t call-with-input-file (test-file-name "r4rs.test") input-port?) -(define this-file (open-input-file (test-file-name "r4rs.test"))) -(test #t input-port? this-file) -(SECTION 6 10 2) -(test #\; peek-char this-file) -(test #\; read-char this-file) -(test '(define cur-section '()) read this-file) -(test #\( peek-char this-file) -(test '(define errs '()) read this-file) -(close-input-port this-file) -(close-input-port this-file) -(define (check-test-file name) - (define test-file (open-input-file name)) - (test #t 'input-port? - (call-with-input-file - name - (lambda (test-file) - (test load-test-obj read test-file) - (test #t eof-object? (peek-char test-file)) - (test #t eof-object? (read-char test-file)) - (input-port? test-file)))) - (test #\; read-char test-file) - (test display-test-obj read test-file) - (test load-test-obj read test-file) - (close-input-port test-file)) -(SECTION 6 10 3) -(define write-test-obj - '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) -(define display-test-obj - '(#t #f a () 9739 -3 . #((test) te " " st test #() b c))) -(define load-test-obj - (list 'define 'foo (list 'quote write-test-obj))) -(test #t call-with-output-file - (data-file-name "tmp1") - (lambda (test-file) - (write-char #\; test-file) - (display write-test-obj test-file) - (newline test-file) - (write load-test-obj test-file) - (output-port? test-file))) -(check-test-file (data-file-name "tmp1")) - -(define test-file (open-output-file (data-file-name "tmp2"))) -(write-char #\; test-file) -(display write-test-obj test-file) -(newline test-file) -(write load-test-obj test-file) -(test #t output-port? test-file) -(close-output-port test-file) -(check-test-file (data-file-name "tmp2")) -(define (test-sc4) - (SECTION 6 7) - (test '(#\P #\space #\l) string->list "P l") - (test '() string->list "") - (test "1\\\"" list->string '(#\1 #\\ #\")) - (test "" list->string '()) - (SECTION 6 8) - (test '(dah dah didah) vector->list '#(dah dah didah)) - (test '() vector->list '#()) - (test '#(dididit dah) list->vector '(dididit dah)) - (test '#() list->vector '()) - (SECTION 6 10 4) - (load (data-file-name "tmp1")) - (test write-test-obj 'load foo) - (report-errs)) - -(report-errs) -(if (and (string->number "0.0") (inexact? (string->number "0.0"))) - (test-inexact)) - -(let ((n (string->number "281474976710655"))) - (if (and n (exact? n)) - (test-bignum))) -(test-cont) -(test-sc4) -(test-delay) -"last item in file" - - -;; FIXME: We shouldn't create any global bindings in the test files or -;; alternatively execute every test file's code in a module of its own -(if (defined? 'x) (undefine x)) -(if (defined? 'y) (undefine y)) - -(delete-file (data-file-name "tmp1")) -(delete-file (data-file-name "tmp2")) -(delete-file (data-file-name "tmp3")) diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test deleted file mode 100644 index 64bd05aa7..000000000 --- a/test-suite/tests/reader.test +++ /dev/null @@ -1,41 +0,0 @@ -;;;; reader.test --- test the Guile parser -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 - -(define exception:eof - (cons 'misc-error "^end of file")) -(define exception:unexpected-rparen - (cons 'misc-error "^unexpected \")\"")) - -(define (read-string s) - (with-input-from-string s (lambda () (read)))) - -(with-test-prefix "reading" - (pass-if "0" - (equal? (read-string "0") 0)) - (pass-if "1++i" - (equal? (read-string "1++i") '1++i)) - (pass-if "1+i+i" - (equal? (read-string "1+i+i") '1+i+i)) - (pass-if "1+e10000i" - (equal? (read-string "1+e10000i") '1+e10000i))) - -(pass-if-exception "radix passed to number->string can't be zero" - exception:out-of-range - (number->string 10 0)) -(pass-if-exception "radix passed to number->string can't be one either" - exception:out-of-range - (number->string 10 1)) - -(with-test-prefix "mismatching parentheses" - (pass-if-exception "opening parenthesis" - exception:eof - (read-string "(")) - (pass-if-exception "closing parenthesis following mismatched opening" - exception:unexpected-rparen - (read-string ")")) - (pass-if-exception "opening vector parenthesis" - exception:eof - (read-string "#(")) - (pass-if-exception "closing parenthesis following mismatched vector opening" - exception:unexpected-rparen - (read-string ")"))) diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test deleted file mode 100644 index 0358354ba..000000000 --- a/test-suite/tests/regexp.test +++ /dev/null @@ -1,102 +0,0 @@ -;;;; regexp.test --- test Guile's regular expression functions -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 -;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (test-suite lib) - (ice-9 regex)) - -;;; Run a regexp-substitute or regexp-substitute/global test, once -;;; providing a real port and once providing #f, requesting direct -;;; string output. -(define (vary-port func expected . args) - (pass-if "port is string port" - (equal? expected - (call-with-output-string - (lambda (port) - (apply func port args))))) - (pass-if "port is #f" - (equal? expected - (apply func #f args)))) - -(define (object->string obj) - (call-with-output-string - (lambda (port) - (write obj port)))) - -(with-test-prefix "regexp-substitute" - (let ((match - (string-match "patleft(sub1)patmid(sub2)patright" - "contleftpatleftsub1patmidsub2patrightcontright"))) - (define (try expected . args) - (with-test-prefix (object->string args) - (apply vary-port regexp-substitute expected match args))) - - (try "") - (try "string1" "string1") - (try "string1string2" "string1" "string2") - (try "patleftsub1patmidsub2patright" 0) - (try "hi-patleftsub1patmidsub2patright-bye" "hi-" 0 "-bye") - (try "sub1" 1) - (try "hi-sub1-bye" "hi-" 1 "-bye") - (try "hi-sub2-bye" "hi-" 2 "-bye") - (try "contleft" 'pre) - (try "contright" 'post) - (try "contrightcontleft" 'post 'pre) - (try "contrightcontleftcontrightcontleft" 'post 'pre 'post 'pre) - (try "contrightsub2sub1contleft" 'post 2 1 'pre) - (try "foosub1sub1sub1sub1bar" "foo" 1 1 1 1 "bar"))) - -(with-test-prefix "regexp-substitute/global" - - (define (try expected . args) - (with-test-prefix (object->string args) - (apply vary-port regexp-substitute/global expected args))) - - (try "hi" "a(x*)b" "ab" "hi") - (try "" "a(x*)b" "ab" 1) - (try "xx" "a(x*)b" "axxb" 1) - (try "xx" "a(x*)b" "_axxb_" 1) - (try "pre" "a(x*)b" "preaxxbpost" 'pre) - (try "post" "a(x*)b" "preaxxbpost" 'post) - (try "string" "x" "string" 'pre "y" 'post) - (try "4" "a(x*)b" "_axxb_" (lambda (m) - (number->string (match:end m 1)))) - - (try "_aybycyd_" "x+" "_axbxxcxxxd_" 'pre "y" 'post) - - ;; This should not go into an infinite loop, just because the regexp - ;; can match the empty string. This test also kind of beats on our - ;; definition of where a null string can match. - (try "y_yaybycydy_y" "x*" "_axbxxcxxxd_" 'pre "y" 'post) - - ;; These kind of bother me. The extension from regexp-substitute to - ;; regexp-substitute/global is only natural if your item list - ;; includes both pre and post. If those are required, why bother - ;; to include them at all? - (try "4:7:12:_" "a(x*)b" "_axxbaxbaxxxb_" - (lambda (m) (number->string (match:end m 1))) ":" - 'post) - (try "4:10:19:_:19:10:4" "a(x*)b" "_axxbaxxxxbaxxxxxxxb_" - (lambda (m) (number->string (match:end m 1))) ":" - 'post - ":" (lambda (m) (number->string (match:end m 1)))) - - ;; Jan Nieuwenhuizen's bug, 2 Sep 1999 - (try "" "_" (make-string 500 #\_) - 'post)) diff --git a/test-suite/tests/srfi-10.test b/test-suite/tests/srfi-10.test deleted file mode 100644 index 28caf3ad3..000000000 --- a/test-suite/tests/srfi-10.test +++ /dev/null @@ -1,30 +0,0 @@ -;;;; srfi-10.test --- Test suite for Guile's SRFI-10 functions. -*- scheme -*- -;;;; Martin Grabmueller, 2001-05-10 -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (srfi srfi-10)) - -(define-reader-ctor 'rx make-regexp) - -(with-test-prefix "hash-comma read extension" - - (pass-if "basic feature" - (let* ((rx #,(rx "^foo$"))) - (and (->bool (regexp-exec rx "foo")) - (not (regexp-exec rx "bar foo frob")))))) diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test deleted file mode 100644 index c74f06350..000000000 --- a/test-suite/tests/srfi-13.test +++ /dev/null @@ -1,1029 +0,0 @@ -;;;; srfi-13.test --- Test suite for Guile's SRFI-13 functions. -*- scheme -*- -;;;; Martin Grabmueller, 2001-05-07 -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (srfi srfi-13) (srfi srfi-14) (test-suite lib)) - -;;; This kludge is needed, because SRFI-13 redefines some bindings in -;;; the core. -(define (module-peek module-name sym) - (variable-ref (module-variable (resolve-module module-name) sym))) - -(define exception:strict-infix-grammar - (cons 'misc-error "^strict-infix")) - -(with-test-prefix "string-any" - - (pass-if "no match" - (not (string-any char-upper-case? "abcde"))) - - (pass-if "one match" - (string-any char-upper-case? "abCde")) - - (pass-if "more than one match" - (string-any char-upper-case? "abCDE")) - - (pass-if "no match, start index" - (not (string-any char-upper-case? "Abcde" 1))) - - (pass-if "one match, start index" - (string-any char-upper-case? "abCde" 1)) - - (pass-if "more than one match, start index" - (string-any char-upper-case? "abCDE" 1)) - - (pass-if "no match, start and end index" - (not (string-any char-upper-case? "AbcdE" 1 4))) - - (pass-if "one match, start and end index" - (string-any char-upper-case? "abCde" 1 4)) - - (pass-if "more than one match, start and end index" - (string-any char-upper-case? "abCDE" 1 4))) - -(with-test-prefix "string-every" - - (pass-if "no match at all" - (not (string-every char-upper-case? "abcde"))) - - (pass-if "not all match" - (not (string-every char-upper-case? "abCDE"))) - - (pass-if "all match" - (string-every char-upper-case? "ABCDE")) - - (pass-if "no match at all, start index" - (not (string-every char-upper-case? "Abcde" 1))) - - (pass-if "not all match, start index" - (not (string-every char-upper-case? "ABcde" 1))) - - (pass-if "all match, start index" - (string-every char-upper-case? "aBCDE" 1)) - - (pass-if "no match at all, start and end index" - (not (string-every char-upper-case? "AbcdE" 1 4))) - - (pass-if "not all match, start and end index" - (not (string-every char-upper-case? "ABcde" 1 4))) - - (pass-if "all match, start and end index" - (string-every char-upper-case? "aBCDe" 1 4))) - -(with-test-prefix "string-tabulate" - - (pass-if "static fill-char" - (string=? (string-tabulate (lambda (idx) #\!) 10) "!!!!!!!!!!")) - - (pass-if "variable fill-char" - (string=? (string-tabulate - (lambda (idx) (integer->char (+ idx 32))) 10) " !\"#$%&'()"))) - -;; Get the procedure from the library. -(define string->list (module-peek '(srfi srfi-13) 'string->list)) - -(with-test-prefix "string->list" - - (pass-if "empty" - (zero? (length (string->list "")))) - - (pass-if "nonempty" - (= (length (string->list "foo")) 3)) - - (pass-if "empty, start index" - (zero? (length (string->list "foo" 3 3)))) - - (pass-if "nonempty, start index" - (= (length (string->list "foo" 1 3)) 2)) - ) - -(with-test-prefix "reverse-list->string" - - (pass-if "empty" - (string-null? (reverse-list->string '()))) - - (pass-if "nonempty" - (string=? "foo" (reverse-list->string '(#\o #\o #\f))))) - - -(with-test-prefix "string-join" - - (pass-if "empty list, no delimiter, implicit infix, empty 1" - (string=? "" (string-join '()))) - - (pass-if "empty string, no delimiter, implicit infix, empty 2" - (string=? "" (string-join '("")))) - - (pass-if "non-empty, no delimiter, implicit infix" - (string=? "bla" (string-join '("bla")))) - - (pass-if "empty list, implicit infix, empty 1" - (string=? "" (string-join '() "|delim|"))) - - (pass-if "empty string, implicit infix, empty 2" - (string=? "" (string-join '("") "|delim|"))) - - (pass-if "non-empty, implicit infix" - (string=? "bla" (string-join '("bla") "|delim|"))) - - (pass-if "non-empty, implicit infix" - (string=? "bla" (string-join '("bla") "|delim|"))) - - (pass-if "two strings, implicit infix" - (string=? "bla|delim|fasel" (string-join '("bla" "fasel") "|delim|"))) - - (pass-if "empty, explicit infix" - (string=? "" (string-join '("") "|delim|" 'infix))) - - (pass-if "empty list, explicit infix" - (string=? "" (string-join '() "|delim|" 'infix))) - - (pass-if "non-empty, explicit infix" - (string=? "bla" (string-join '("bla") "|delim|" 'infix))) - - (pass-if "two strings, explicit infix" - (string=? "bla|delim|fasel" (string-join '("bla" "fasel") "|delim|" - 'infix))) - - (pass-if-exception "empty list, strict infix" - exception:strict-infix-grammar - (string-join '() "|delim|" 'strict-infix)) - - (pass-if "empty, strict infix" - (string=? "" (string-join '("") "|delim|" 'strict-infix))) - - (pass-if "non-empty, strict infix" - (string=? "foo" (string-join '("foo") "|delim|" 'strict-infix))) - - (pass-if "two strings, strict infix" - (string=? "foo|delim|bar" (string-join '("foo" "bar") "|delim|" - 'strict-infix))) - - (pass-if "empty list, prefix" - (string=? "" (string-join '() "|delim|" 'prefix))) - - (pass-if "empty, prefix" - (string=? "|delim|" (string-join '("") "|delim|" 'prefix))) - - (pass-if "non-empty, prefix" - (string=? "|delim|foo" (string-join '("foo") "|delim|" 'prefix))) - - (pass-if "two strings, prefix" - (string=? "|delim|foo|delim|bar" (string-join '("foo" "bar") "|delim|" - 'prefix))) - - (pass-if "empty list, suffix" - (string=? "" (string-join '() "|delim|" 'suffix))) - - (pass-if "empty, suffix" - (string=? "|delim|" (string-join '("") "|delim|" 'suffix))) - - (pass-if "non-empty, suffix" - (string=? "foo|delim|" (string-join '("foo") "|delim|" 'suffix))) - - (pass-if "two strings, suffix" - (string=? "foo|delim|bar|delim|" (string-join '("foo" "bar") "|delim|" - 'suffix)))) - -;; Get the procedure from the library. -(define string-copy (module-peek '(srfi srfi-13) 'string-copy)) - -(with-test-prefix "string-copy" - - (pass-if "empty string" - (string=? "" (string-copy ""))) - - (pass-if "full string" - (string=? "foo-bar" (string-copy "foo-bar"))) - - (pass-if "start index" - (string=? "o-bar" (string-copy "foo-bar" 2))) - - (pass-if "start and end index" - (string=? "o-ba" (string-copy "foo-bar" 2 6))) -) - -(with-test-prefix "substring/shared" - - (pass-if "empty string" - (eq? "" (substring/shared "" 0))) - - (pass-if "non-empty string" - (string=? "foo" (substring/shared "foo-bar" 0 3))) - - (pass-if "non-empty string, not eq?" - (string=? "foo-bar" (substring/shared "foo-bar" 0 7)))) - -(with-test-prefix "string-copy!" - - (pass-if "non-empty string" - (string=? "welld, oh yeah!" - (let* ((s "hello") - (t "world, oh yeah!")) - (string-copy! t 1 s 1 3) - t)))) - -(with-test-prefix "string-take" - - (pass-if "empty string" - (string=? "" (string-take "foo bar braz" 0))) - - (pass-if "non-empty string" - (string=? "foo " (string-take "foo bar braz" 4))) - - (pass-if "full string" - (string=? "foo bar braz" (string-take "foo bar braz" 12)))) - -(with-test-prefix "string-take-right" - - (pass-if "empty string" - (string=? "" (string-take-right "foo bar braz" 0))) - - (pass-if "non-empty string" - (string=? "braz" (string-take-right "foo bar braz" 4))) - - (pass-if "full string" - (string=? "foo bar braz" (string-take-right "foo bar braz" 12)))) - -(with-test-prefix "string-drop" - - (pass-if "empty string" - (string=? "" (string-drop "foo bar braz" 12))) - - (pass-if "non-empty string" - (string=? "braz" (string-drop "foo bar braz" 8))) - - (pass-if "full string" - (string=? "foo bar braz" (string-drop "foo bar braz" 0)))) - -(with-test-prefix "string-drop-right" - - (pass-if "empty string" - (string=? "" (string-drop-right "foo bar braz" 12))) - - (pass-if "non-empty string" - (string=? "foo " (string-drop-right "foo bar braz" 8))) - - (pass-if "full string" - (string=? "foo bar braz" (string-drop-right "foo bar braz" 0)))) - -(with-test-prefix "string-pad" - - (pass-if "empty string, zero pad" - (string=? "" (string-pad "" 0))) - - (pass-if "empty string, zero pad, pad char" - (string=? "" (string-pad "" 0))) - - (pass-if "empty pad string, 2 pad " - (string=? " " (string-pad "" 2))) - - (pass-if "empty pad string, 2 pad, pad char" - (string=? "!!" (string-pad "" 2 #\!))) - - (pass-if "empty pad string, 2 pad, pad char, start index" - (string=? "!c" (string-pad "abc" 2 #\! 2))) - - (pass-if "empty pad string, 2 pad, pad char, start and end index" - (string=? "!c" (string-pad "abcd" 2 #\! 2 3))) - - (pass-if "freestyle 1" - (string=? "32" (string-pad (number->string 532) 2 #\!))) - - (pass-if "freestyle 2" - (string=? "!532" (string-pad (number->string 532) 4 #\!)))) - -(with-test-prefix "string-pad-right" - - (pass-if "empty string, zero pad" - (string=? "" (string-pad-right "" 0))) - - (pass-if "empty string, zero pad, pad char" - (string=? "" (string-pad-right "" 0))) - - (pass-if "empty pad string, 2 pad " - (string=? " " (string-pad-right "" 2))) - - (pass-if "empty pad string, 2 pad, pad char" - (string=? "!!" (string-pad-right "" 2 #\!))) - - (pass-if "empty pad string, 2 pad, pad char, start index" - (string=? "c!" (string-pad-right "abc" 2 #\! 2))) - - (pass-if "empty pad string, 2 pad, pad char, start and end index" - (string=? "c!" (string-pad-right "abcd" 2 #\! 2 3))) - - (pass-if "freestyle 1" - (string=? "53" (string-pad-right (number->string 532) 2 #\!))) - - (pass-if "freestyle 2" - (string=? "532!" (string-pad-right (number->string 532) 4 #\!)))) - -(with-test-prefix "string-trim" - - (pass-if "empty string" - (string=? "" (string-trim ""))) - - (pass-if "no char/pred" - (string=? "foo " (string-trim " \tfoo "))) - - (pass-if "start index, pred" - (string=? "foo " (string-trim " \tfoo " char-whitespace? 1))) - - (pass-if "start and end index, pred" - (string=? "f" (string-trim " \tfoo " char-whitespace? 1 3))) - - (pass-if "start index, char" - (string=? "\tfoo " (string-trim " \tfoo " #\space 1))) - - (pass-if "start and end index, char" - (string=? "\tf" (string-trim " \tfoo " #\space 1 3))) - - (pass-if "start index, charset" - (string=? "foo " (string-trim " \tfoo " char-set:whitespace 1))) - - (pass-if "start and end index, charset" - (string=? "f" (string-trim " \tfoo " char-set:whitespace 1 3)))) - -(with-test-prefix "string-trim-right" - - (pass-if "empty string" - (string=? "" (string-trim-right ""))) - - (pass-if "no char/pred" - (string=? " \tfoo" (string-trim-right " \tfoo "))) - - (pass-if "start index, pred" - (string=? "\tfoo" (string-trim-right " \tfoo " char-whitespace? 1))) - - (pass-if "start and end index, pred" - (string=? "\tf" (string-trim-right " \tfoo " char-whitespace? 1 3))) - - (pass-if "start index, char" - (string=? "\tfoo" (string-trim-right " \tfoo " #\space 1))) - - (pass-if "start and end index, char" - (string=? "\tf" (string-trim-right " \tfoo " #\space 1 3))) - - (pass-if "start index, charset" - (string=? "\tfoo" (string-trim-right " \tfoo " char-set:whitespace 1))) - - (pass-if "start and end index, charset" - (string=? "\tf" (string-trim-right " \tfoo " char-set:whitespace 1 3)))) - -(with-test-prefix "string-trim-both" - - (pass-if "empty string" - (string=? "" (string-trim-both ""))) - - (pass-if "no char/pred" - (string=? "foo" (string-trim-both " \tfoo "))) - - (pass-if "start index, pred" - (string=? "foo" (string-trim-both " \tfoo " char-whitespace? 1))) - - (pass-if "start and end index, pred" - (string=? "f" (string-trim-both " \tfoo " char-whitespace? 1 3))) - - (pass-if "start index, char" - (string=? "\tfoo" (string-trim-both " \tfoo " #\space 1))) - - (pass-if "start and end index, char" - (string=? "\tf" (string-trim-both " \tfoo " #\space 1 3))) - - (pass-if "start index, charset" - (string=? "foo" (string-trim-both " \tfoo " char-set:whitespace 1))) - - (pass-if "start and end index, charset" - (string=? "f" (string-trim-both " \tfoo " char-set:whitespace 1 3)))) - -;; Get the procedure from the library. -(define string-fill! (module-peek '(srfi srfi-13) 'string-fill!)) - -(define s0 (make-string 200 #\!)) -(define s1 (make-string 0 #\!)) - -(with-test-prefix "string-fill!" - - (pass-if "empty string, no indices" - (string-fill! s1 #\*) - (= (string-length s1) 0)) - - (pass-if "empty string, start index" - (string-fill! s1 #\* 0) - (= (string-length s1) 0)) - - (pass-if "empty string, start and end index" - (string-fill! s1 #\* 0 0) - (= (string-length s1) 0)) - - (pass-if "no indices" - (string-fill! s0 #\*) - (char=? (string-ref s0 0) #\*)) - - (pass-if "start index" - (string-fill! s0 #\+ 10) - (char=? (string-ref s0 11) #\+)) - - (pass-if "start and end index" - (string-fill! s0 #\| 12 20) - (char=? (string-ref s0 13) #\|))) - -(with-test-prefix "string-prefix-length" - - (pass-if "empty prefix" - (= 0 (string-prefix-length "" "foo bar"))) - - (pass-if "non-empty prefix - match" - (= 3 (string-prefix-length "foo" "foo bar"))) - - (pass-if "non-empty prefix - no match" - (= 0 (string-prefix-length "bar" "foo bar")))) - -(with-test-prefix "string-prefix-length-ci" - - (pass-if "empty prefix" - (= 0 (string-prefix-length-ci "" "foo bar"))) - - (pass-if "non-empty prefix - match" - (= 3 (string-prefix-length-ci "fOo" "foo bar"))) - - (pass-if "non-empty prefix - no match" - (= 0 (string-prefix-length-ci "bAr" "foo bar")))) - -(with-test-prefix "string-suffix-length" - - (pass-if "empty suffix" - (= 0 (string-suffix-length "" "foo bar"))) - - (pass-if "non-empty suffix - match" - (= 3 (string-suffix-length "bar" "foo bar"))) - - (pass-if "non-empty suffix - no match" - (= 0 (string-suffix-length "foo" "foo bar")))) - -(with-test-prefix "string-suffix-length-ci" - - (pass-if "empty suffix" - (= 0 (string-suffix-length-ci "" "foo bar"))) - - (pass-if "non-empty suffix - match" - (= 3 (string-suffix-length-ci "bAr" "foo bar"))) - - (pass-if "non-empty suffix - no match" - (= 0 (string-suffix-length-ci "fOo" "foo bar")))) - -(with-test-prefix "string-prefix?" - - (pass-if "empty prefix" - (string-prefix? "" "foo bar")) - - (pass-if "non-empty prefix - match" - (string-prefix? "foo" "foo bar")) - - (pass-if "non-empty prefix - no match" - (not (string-prefix? "bar" "foo bar")))) - -(with-test-prefix "string-prefix-ci?" - - (pass-if "empty prefix" - (string-prefix-ci? "" "foo bar")) - - (pass-if "non-empty prefix - match" - (string-prefix-ci? "fOo" "foo bar")) - - (pass-if "non-empty prefix - no match" - (not (string-prefix-ci? "bAr" "foo bar")))) - -(with-test-prefix "string-suffix?" - - (pass-if "empty suffix" - (string-suffix? "" "foo bar")) - - (pass-if "non-empty suffix - match" - (string-suffix? "bar" "foo bar")) - - (pass-if "non-empty suffix - no match" - (not (string-suffix? "foo" "foo bar")))) - -(with-test-prefix "string-suffix-ci?" - - (pass-if "empty suffix" - (string-suffix-ci? "" "foo bar")) - - (pass-if "non-empty suffix - match" - (string-suffix-ci? "bAr" "foo bar")) - - (pass-if "non-empty suffix - no match" - (not (string-suffix-ci? "fOo" "foo bar")))) - -;; Get the procedure from the library. -(define string-index (module-peek '(srfi srfi-13) 'string-index)) - -(with-test-prefix "string-index" - - (pass-if "empty string - char" - (not (string-index "" #\a))) - - (pass-if "non-empty - char - match" - (= 5 (string-index "foo bar" #\a))) - - (pass-if "non-empty - char - no match" - (not (string-index "frobnicate" #\x))) - - (pass-if "empty string - char - start index" - (not (string-index "" #\a 0))) - - (pass-if "non-empty - char - match - start index" - (= 5 (string-index "foo bar" #\a 1))) - - (pass-if "non-empty - char - no match - start index" - (not (string-index "frobnicate" #\x 2))) - - (pass-if "empty string - char - start and end index" - (not (string-index "" #\a 0 0))) - - (pass-if "non-empty - char - match - start and end index" - (= 5 (string-index "foo bar" #\a 1 6))) - - (pass-if "non-empty - char - no match - start and end index" - (not (string-index "frobnicate" #\a 2 5))) - - (pass-if "empty string - charset" - (not (string-index "" char-set:letter))) - - (pass-if "non-empty - charset - match" - (= 0 (string-index "foo bar" char-set:letter))) - - (pass-if "non-empty - charset - no match" - (not (string-index "frobnicate" char-set:digit))) - - (pass-if "empty string - charset - start index" - (not (string-index "" char-set:letter 0))) - - (pass-if "non-empty - charset - match - start index" - (= 1 (string-index "foo bar" char-set:letter 1))) - - (pass-if "non-empty - charset - no match - start index" - (not (string-index "frobnicate" char-set:digit 2))) - - (pass-if "empty string - charset - start and end index" - (not (string-index "" char-set:letter 0 0))) - - (pass-if "non-empty - charset - match - start and end index" - (= 1 (string-index "foo bar" char-set:letter 1 6))) - - (pass-if "non-empty - charset - no match - start and end index" - (not (string-index "frobnicate" char-set:digit 2 5))) - - (pass-if "empty string - pred" - (not (string-index "" char-alphabetic?))) - - (pass-if "non-empty - pred - match" - (= 0 (string-index "foo bar" char-alphabetic?))) - - (pass-if "non-empty - pred - no match" - (not (string-index "frobnicate" char-numeric?))) - - (pass-if "empty string - pred - start index" - (not (string-index "" char-alphabetic? 0))) - - (pass-if "non-empty - pred - match - start index" - (= 1 (string-index "foo bar" char-alphabetic? 1))) - - (pass-if "non-empty - pred - no match - start index" - (not (string-index "frobnicate" char-numeric? 2))) - - (pass-if "empty string - pred - start and end index" - (not (string-index "" char-alphabetic? 0 0))) - - (pass-if "non-empty - pred - match - start and end index" - (= 1 (string-index "foo bar" char-alphabetic? 1 6))) - - (pass-if "non-empty - pred - no match - start and end index" - (not (string-index "frobnicate" char-numeric? 2 5)))) - -(with-test-prefix "string-index-right" - - (pass-if "empty string - char" - (not (string-index-right "" #\a))) - - (pass-if "non-empty - char - match" - (= 5 (string-index-right "foo bar" #\a))) - - (pass-if "non-empty - char - no match" - (not (string-index-right "frobnicate" #\x))) - - (pass-if "empty string - char - start index-right" - (not (string-index-right "" #\a 0))) - - (pass-if "non-empty - char - match - start index" - (= 5 (string-index-right "foo bar" #\a 1))) - - (pass-if "non-empty - char - no match - start index" - (not (string-index-right "frobnicate" #\x 2))) - - (pass-if "empty string - char - start and end index" - (not (string-index-right "" #\a 0 0))) - - (pass-if "non-empty - char - match - start and end index" - (= 5 (string-index-right "foo bar" #\a 1 6))) - - (pass-if "non-empty - char - no match - start and end index" - (not (string-index-right "frobnicate" #\a 2 5))) - - (pass-if "empty string - charset" - (not (string-index-right "" char-set:letter))) - - (pass-if "non-empty - charset - match" - (= 6 (string-index-right "foo bar" char-set:letter))) - - (pass-if "non-empty - charset - no match" - (not (string-index-right "frobnicate" char-set:digit))) - - (pass-if "empty string - charset - start index" - (not (string-index-right "" char-set:letter 0))) - - (pass-if "non-empty - charset - match - start index" - (= 6 (string-index-right "foo bar" char-set:letter 1))) - - (pass-if "non-empty - charset - no match - start index" - (not (string-index-right "frobnicate" char-set:digit 2))) - - (pass-if "empty string - charset - start and end index" - (not (string-index-right "" char-set:letter 0 0))) - - (pass-if "non-empty - charset - match - start and end index" - (= 5 (string-index-right "foo bar" char-set:letter 1 6))) - - (pass-if "non-empty - charset - no match - start and end index" - (not (string-index-right "frobnicate" char-set:digit 2 5))) - - (pass-if "empty string - pred" - (not (string-index-right "" char-alphabetic?))) - - (pass-if "non-empty - pred - match" - (= 6 (string-index-right "foo bar" char-alphabetic?))) - - (pass-if "non-empty - pred - no match" - (not (string-index-right "frobnicate" char-numeric?))) - - (pass-if "empty string - pred - start index" - (not (string-index-right "" char-alphabetic? 0))) - - (pass-if "non-empty - pred - match - start index" - (= 6 (string-index-right "foo bar" char-alphabetic? 1))) - - (pass-if "non-empty - pred - no match - start index" - (not (string-index-right "frobnicate" char-numeric? 2))) - - (pass-if "empty string - pred - start and end index" - (not (string-index-right "" char-alphabetic? 0 0))) - - (pass-if "non-empty - pred - match - start and end index" - (= 5 (string-index-right "foo bar" char-alphabetic? 1 6))) - - (pass-if "non-empty - pred - no match - start and end index" - (not (string-index-right "frobnicate" char-numeric? 2 5)))) - -(with-test-prefix "string-skip" - - (pass-if "empty string - char" - (not (string-skip "" #\a))) - - (pass-if "non-empty - char - match" - (= 0 (string-skip "foo bar" #\a))) - - (pass-if "non-empty - char - no match" - (= 0 (string-skip "frobnicate" #\x))) - - (pass-if "empty string - char - start index" - (not (string-skip "" #\a 0))) - - (pass-if "non-empty - char - match - start index" - (= 1 (string-skip "foo bar" #\a 1))) - - (pass-if "non-empty - char - no match - start index" - (= 2 (string-skip "frobnicate" #\x 2))) - - (pass-if "empty string - char - start and end index" - (not (string-skip "" #\a 0 0))) - - (pass-if "non-empty - char - match - start and end index" - (= 1 (string-skip "foo bar" #\a 1 6))) - - (pass-if "non-empty - char - no match - start and end index" - (= 2 (string-skip "frobnicate" #\a 2 5))) - - (pass-if "empty string - charset" - (not (string-skip "" char-set:letter))) - - (pass-if "non-empty - charset - match" - (= 3 (string-skip "foo bar" char-set:letter))) - - (pass-if "non-empty - charset - no match" - (= 0 (string-skip "frobnicate" char-set:digit))) - - (pass-if "empty string - charset - start index" - (not (string-skip "" char-set:letter 0))) - - (pass-if "non-empty - charset - match - start index" - (= 3 (string-skip "foo bar" char-set:letter 1))) - - (pass-if "non-empty - charset - no match - start index" - (= 2 (string-skip "frobnicate" char-set:digit 2))) - - (pass-if "empty string - charset - start and end index" - (not (string-skip "" char-set:letter 0 0))) - - (pass-if "non-empty - charset - match - start and end index" - (= 3 (string-skip "foo bar" char-set:letter 1 6))) - - (pass-if "non-empty - charset - no match - start and end index" - (= 2 (string-skip "frobnicate" char-set:digit 2 5))) - - (pass-if "empty string - pred" - (not (string-skip "" char-alphabetic?))) - - (pass-if "non-empty - pred - match" - (= 3 (string-skip "foo bar" char-alphabetic?))) - - (pass-if "non-empty - pred - no match" - (= 0 (string-skip "frobnicate" char-numeric?))) - - (pass-if "empty string - pred - start index" - (not (string-skip "" char-alphabetic? 0))) - - (pass-if "non-empty - pred - match - start index" - (= 3 (string-skip "foo bar" char-alphabetic? 1))) - - (pass-if "non-empty - pred - no match - start index" - (= 2 (string-skip "frobnicate" char-numeric? 2))) - - (pass-if "empty string - pred - start and end index" - (not (string-skip "" char-alphabetic? 0 0))) - - (pass-if "non-empty - pred - match - start and end index" - (= 3 (string-skip "foo bar" char-alphabetic? 1 6))) - - (pass-if "non-empty - pred - no match - start and end index" - (= 2 (string-skip "frobnicate" char-numeric? 2 5)))) - -(with-test-prefix "string-skip-right" - - (pass-if "empty string - char" - (not (string-skip-right "" #\a))) - - (pass-if "non-empty - char - match" - (= 6 (string-skip-right "foo bar" #\a))) - - (pass-if "non-empty - char - no match" - (= 9 (string-skip-right "frobnicate" #\x))) - - (pass-if "empty string - char - start index-right" - (not (string-skip-right "" #\a 0))) - - (pass-if "non-empty - char - match - start index" - (= 6 (string-skip-right "foo bar" #\a 1))) - - (pass-if "non-empty - char - no match - start index" - (= 9 (string-skip-right "frobnicate" #\x 2))) - - (pass-if "empty string - char - start and end index" - (not (string-skip-right "" #\a 0 0))) - - (pass-if "non-empty - char - match - start and end index" - (= 4 (string-skip-right "foo bar" #\a 1 6))) - - (pass-if "non-empty - char - no match - start and end index" - (= 4 (string-skip-right "frobnicate" #\a 2 5))) - - (pass-if "empty string - charset" - (not (string-skip-right "" char-set:letter))) - - (pass-if "non-empty - charset - match" - (= 3 (string-skip-right "foo bar" char-set:letter))) - - (pass-if "non-empty - charset - no match" - (= 9 (string-skip-right "frobnicate" char-set:digit))) - - (pass-if "empty string - charset - start index" - (not (string-skip-right "" char-set:letter 0))) - - (pass-if "non-empty - charset - match - start index" - (= 3 (string-skip-right "foo bar" char-set:letter 1))) - - (pass-if "non-empty - charset - no match - start index" - (= 9 (string-skip-right "frobnicate" char-set:digit 2))) - - (pass-if "empty string - charset - start and end index" - (not (string-skip-right "" char-set:letter 0 0))) - - (pass-if "non-empty - charset - match - start and end index" - (= 3 (string-skip-right "foo bar" char-set:letter 1 6))) - - (pass-if "non-empty - charset - no match - start and end index" - (= 4 (string-skip-right "frobnicate" char-set:digit 2 5))) - - (pass-if "empty string - pred" - (not (string-skip-right "" char-alphabetic?))) - - (pass-if "non-empty - pred - match" - (= 3 (string-skip-right "foo bar" char-alphabetic?))) - - (pass-if "non-empty - pred - no match" - (= 9 (string-skip-right "frobnicate" char-numeric?))) - - (pass-if "empty string - pred - start index" - (not (string-skip-right "" char-alphabetic? 0))) - - (pass-if "non-empty - pred - match - start index" - (= 3 (string-skip-right "foo bar" char-alphabetic? 1))) - - (pass-if "non-empty - pred - no match - start index" - (= 9 (string-skip-right "frobnicate" char-numeric? 2))) - - (pass-if "empty string - pred - start and end index" - (not (string-skip-right "" char-alphabetic? 0 0))) - - (pass-if "non-empty - pred - match - start and end index" - (= 3 (string-skip-right "foo bar" char-alphabetic? 1 6))) - - (pass-if "non-empty - pred - no match - start and end index" - (= 4 (string-skip-right "frobnicate" char-numeric? 2 5)))) - -(with-test-prefix "string-replace" - - (pass-if "empty string(s), no indices" - (string=? "" (string-replace "" ""))) - - (pass-if "empty string(s), 1 index" - (string=? "" (string-replace "" "" 0))) - - (pass-if "empty string(s), 2 indices" - (string=? "" (string-replace "" "" 0 0))) - - (pass-if "empty string(s), 3 indices" - (string=? "" (string-replace "" "" 0 0 0))) - - (pass-if "empty string(s), 4 indices" - (string=? "" (string-replace "" "" 0 0 0 0))) - - (pass-if "no indices" - (string=? "uu" (string-replace "foo bar" "uu"))) - - (pass-if "one index" - (string=? "fuu" (string-replace "foo bar" "uu" 1))) - - (pass-if "two indices" - (string=? "fuuar" (string-replace "foo bar" "uu" 1 5))) - - (pass-if "three indices" - (string=? "fuar" (string-replace "foo bar" "uu" 1 5 1))) - - (pass-if "four indices" - (string=? "fuar" (string-replace "foo bar" "uu" 1 5 1 2)))) - -(with-test-prefix "string-tokenize" - - (pass-if "empty string, no char/pred" - (zero? (length (string-tokenize "")))) - - (pass-if "empty string, charset" - (zero? (length (string-tokenize "" char-set:punctuation)))) - - (pass-if "no char/pred" - (equal? '("foo" "bar" "!a") (string-tokenize "foo\tbar !a"))) - - (pass-if "charset" - (equal? '("foo" "bar" "!a") (string-tokenize "foo\tbar !a" - char-set:graphic))) - - (pass-if "charset, start index" - (equal? '("oo" "bar" "!a") (string-tokenize "foo\tbar !a" - char-set:graphic 1))) - - (pass-if "charset, start and end index" - (equal? '("oo" "bar" "!") (string-tokenize "foo\tbar !a" - char-set:graphic 1 9)))) - -(with-test-prefix "string-filter" - - (pass-if "empty string, char" - (string=? "" (string-filter "" #\.))) - - (pass-if "empty string, charset" - (string=? "" (string-filter "" char-set:punctuation))) - - (pass-if "empty string, pred" - (string=? "" (string-filter "" char-alphabetic?))) - - (pass-if "char" - (string=? "..." (string-filter ".foo.bar." #\.))) - - (pass-if "charset" - (string=? "..." (string-filter ".foo.bar." char-set:punctuation))) - - (pass-if "pred" - (string=? "foobar" (string-filter ".foo.bar." char-alphabetic?))) - - (pass-if "char, start index" - (string=? ".." (string-filter ".foo.bar." #\. 2))) - - (pass-if "charset, start index" - (string=? ".." (string-filter ".foo.bar." char-set:punctuation 2))) - - (pass-if "pred, start index" - (string=? "oobar" (string-filter ".foo.bar." char-alphabetic? 2))) - - (pass-if "char, start and end index" - (string=? "" (string-filter ".foo.bar." #\. 2 4))) - - (pass-if "charset, start and end index" - (string=? "" (string-filter ".foo.bar." char-set:punctuation 2 4))) - - (pass-if "pred, start and end index" - (string=? "oo" (string-filter ".foo.bar." char-alphabetic? 2 4)))) - -(with-test-prefix "string-delete" - - (pass-if "empty string, char" - (string=? "" (string-delete "" #\.))) - - (pass-if "empty string, charset" - (string=? "" (string-delete "" char-set:punctuation))) - - (pass-if "empty string, pred" - (string=? "" (string-delete "" char-alphabetic?))) - - (pass-if "char" - (string=? "foobar" (string-delete ".foo.bar." #\.))) - - (pass-if "charset" - (string=? "foobar" (string-delete ".foo.bar." char-set:punctuation))) - - (pass-if "pred" - (string=? "..." (string-delete ".foo.bar." char-alphabetic?))) - - (pass-if "char, start index" - (string=? "oobar" (string-delete ".foo.bar." #\. 2))) - - (pass-if "charset, start index" - (string=? "oobar" (string-delete ".foo.bar." char-set:punctuation 2))) - - (pass-if "pred, start index" - (string=? ".." (string-delete ".foo.bar." char-alphabetic? 2))) - - (pass-if "char, start and end index" - (string=? "oo" (string-delete ".foo.bar." #\. 2 4))) - - (pass-if "charset, start and end index" - (string=? "oo" (string-delete ".foo.bar." char-set:punctuation 2 4))) - - (pass-if "pred, start and end index" - (string=? "" (string-delete ".foo.bar." char-alphabetic? 2 4)))) - -(with-test-prefix "string-map" - - (pass-if "constant" - (string=? "xxx" (string-map (lambda (c) #\x) "foo"))) - - (pass-if "identity" - (string=? "foo" (string-map identity "foo"))) - - (pass-if "upcase" - (string=? "FOO" (string-map char-upcase "foo")))) - -(with-test-prefix "string-for-each" - - (pass-if "copy" - (let* ((foo "foo") - (bar (make-string (string-length foo))) - (i 0)) - (string-for-each - (lambda (c) (string-set! bar i c) (set! i (1+ i))) foo) - (string=? foo bar))) - - (pass-if "index" - (let* ((foo "foo") - (bar (make-string (string-length foo)))) - (string-for-each-index - (lambda (i) (string-set! bar i (string-ref foo i))) foo) - (string=? foo bar)))) - diff --git a/test-suite/tests/srfi-14.test b/test-suite/tests/srfi-14.test deleted file mode 100644 index bd927c0bb..000000000 --- a/test-suite/tests/srfi-14.test +++ /dev/null @@ -1,188 +0,0 @@ -;;;; srfi-14.test --- Test suite for Guile's SRFI-14 functions. -*- scheme -*- -;;;; Martin Grabmueller, 2001-07-16 -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (srfi srfi-14)) - -(define exception:invalid-char-set-cursor - (cons 'misc-error "^invalid character set cursor")) - -(define exception:non-char-return - (cons 'misc-error "returned non-char")) - -(with-test-prefix "char-set?" - - (pass-if "success on empty set" - (char-set? (char-set))) - - (pass-if "success on non-empty set" - (char-set? char-set:printing)) - - (pass-if "failure on empty set" - (not (char-set? #t)))) - - -(with-test-prefix "char-set=" - (pass-if "success, no arg" - (char-set=)) - - (pass-if "success, one arg" - (char-set= char-set:lower-case)) - - (pass-if "success, two args" - (char-set= char-set:upper-case char-set:upper-case)) - - (pass-if "failure, first empty" - (not (char-set= (char-set) (char-set #\a)))) - - (pass-if "failure, second empty" - (not (char-set= (char-set #\a) (char-set)))) - - (pass-if "success, more args" - (char-set= char-set:blank char-set:blank char-set:blank))) - -(with-test-prefix "char-set<=" - (pass-if "success, no arg" - (char-set<=)) - - (pass-if "success, one arg" - (char-set<= char-set:lower-case)) - - (pass-if "success, two args" - (char-set<= char-set:upper-case char-set:upper-case)) - - (pass-if "success, first empty" - (char-set<= (char-set) (char-set #\a))) - - (pass-if "failure, second empty" - (not (char-set<= (char-set #\a) (char-set)))) - - (pass-if "success, more args, equal" - (char-set<= char-set:blank char-set:blank char-set:blank)) - - (pass-if "success, more args, not equal" - (char-set<= char-set:blank - (char-set-adjoin char-set:blank #\F) - (char-set-adjoin char-set:blank #\F #\o)))) - -(with-test-prefix "char-set-hash" - (pass-if "empty set, bound" - (let ((h (char-set-hash char-set:empty 31))) - (and h (number? h) (exact? h) (>= h 0) (< h 31)))) - - (pass-if "empty set, no bound" - (let ((h (char-set-hash char-set:empty))) - (and h (number? h) (exact? h) (>= h 0)))) - - (pass-if "full set, bound" - (let ((h (char-set-hash char-set:full 31))) - (and h (number? h) (exact? h) (>= h 0) (< h 31)))) - - (pass-if "full set, no bound" - (let ((h (char-set-hash char-set:full))) - (and h (number? h) (exact? h) (>= h 0)))) - - (pass-if "other set, bound" - (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r) 31))) - (and h (number? h) (exact? h) (>= h 0) (< h 31)))) - - (pass-if "other set, no bound" - (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r)))) - (and h (number? h) (exact? h) (>= h 0))))) - - -(with-test-prefix "char-set cursor" - - (pass-if-exception "invalid character cursor" - exception:invalid-char-set-cursor - (let* ((cs (char-set #\B #\r #\a #\z)) - (cc (char-set-cursor cs))) - (char-set-ref cs 1000))) - - (pass-if "success" - (let* ((cs (char-set #\B #\r #\a #\z)) - (cc (char-set-cursor cs))) - (char? (char-set-ref cs cc)))) - - (pass-if "end of set fails" - (let* ((cs (char-set #\a)) - (cc (char-set-cursor cs))) - (not (end-of-char-set? cc)))) - - (pass-if "end of set succeeds, empty set" - (let* ((cs (char-set)) - (cc (char-set-cursor cs))) - (end-of-char-set? cc))) - - (pass-if "end of set succeeds, non-empty set" - (let* ((cs (char-set #\a)) - (cc (char-set-cursor cs)) - (cc (char-set-cursor-next cs cc))) - (end-of-char-set? cc)))) - -(with-test-prefix "char-set-fold" - - (pass-if "count members" - (= (char-set-fold (lambda (c n) (+ n 1)) 0 (char-set #\a #\b)) 2)) - - (pass-if "copy set" - (= (char-set-size (char-set-fold (lambda (c cs) (char-set-adjoin cs c)) - (char-set) (char-set #\a #\b))) 2))) - -(with-test-prefix "char-set-unfold" - - (pass-if "create char set" - (char-set= char-set:full - (char-set-unfold (lambda (s) (= s 256)) integer->char - (lambda (s) (+ s 1)) 0))) - (pass-if "create char set (base set)" - (char-set= char-set:full - (char-set-unfold (lambda (s) (= s 256)) integer->char - (lambda (s) (+ s 1)) 0 char-set:empty)))) - -(with-test-prefix "char-set-unfold!" - - (pass-if "create char set" - (char-set= char-set:full - (char-set-unfold! (lambda (s) (= s 256)) integer->char - (lambda (s) (+ s 1)) 0 - (char-set-copy char-set:empty)))) - - (pass-if "create char set" - (char-set= char-set:full - (char-set-unfold! (lambda (s) (= s 32)) integer->char - (lambda (s) (+ s 1)) 0 - (char-set-copy char-set:full))))) - - -(with-test-prefix "char-set-for-each" - - (pass-if "copy char set" - (= (char-set-size (let ((cs (char-set))) - (char-set-for-each - (lambda (c) (char-set-adjoin! cs c)) - (char-set #\a #\b)) - cs)) - 2))) - -(with-test-prefix "char-set-map" - - (pass-if "upper case char set" - (char-set= (char-set-map char-upcase char-set:lower-case) - char-set:upper-case))) diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test deleted file mode 100644 index dc6fd7e06..000000000 --- a/test-suite/tests/srfi-17.test +++ /dev/null @@ -1,32 +0,0 @@ -;;;; srfi-17.test --- test suite for Guile's SRFI-17 functions. -*- scheme -*- -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (srfi srfi-17)) - -(with-test-prefix "set!" - - (with-test-prefix "target is not procedure with setter" - - (pass-if-exception "(set! (symbol->string 'x) 1)" - exception:wrong-type-arg - (set! (symbol->string 'x) 1)) - - (pass-if-exception "(set! '#f 1)" - exception:wrong-type-arg - (set! '#f 1)))) diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test deleted file mode 100644 index 75eb25637..000000000 --- a/test-suite/tests/srfi-19.test +++ /dev/null @@ -1,157 +0,0 @@ -;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*- -;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001 -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -;; SRFI-19 overrides current-date, so we have to do the test in a -;; separate module, or later tests will fail. - -(define-module (test-suite test-srfi-19) - :use-module (test-suite lib) - :use-module (srfi srfi-19) - :use-module (ice-9 format)) - -(define (with-tz* tz thunk) - "Temporarily set the TZ environment variable to the passed string -value and call THUNK." - (let ((old-tz #f)) - (dynamic-wind - (lambda () - (set! old-tz (getenv "TZ")) - (putenv (format "TZ=~A" tz))) - thunk - (lambda () - (if old-tz - (putenv (format "TZ=~A" old-tz)) - (putenv "TZ")))))) - -(defmacro with-tz (tz . body) - `(with-tz* ,tz (lambda () ,@body))) - -(define (test-integral-time-structure date->time) - "Test whether the given DATE->TIME procedure creates a time -structure with integral seconds. (The seconds shall be maintained as -integers, or precision may go away silently. The SRFI-19 reference -implementation was not OK for Guile in this respect because of Guile's -incomplete numerical tower implementation.)" - (pass-if (format "~A makes integer seconds" - date->time) - (exact? (time-second - (date->time (make-date 0 0 0 12 1 6 2001 0)))))) - -(define (test-time->date time->date date->time) - (pass-if (format "~A works" - time->date) - (begin - (time->date (date->time (make-date 0 0 0 12 1 6 2001 0))) - #t))) - -(define (test-dst time->date date->time) - (pass-if (format "~A respects local DST if no TZ-OFFSET given" - time->date) - (let ((time (date->time (make-date 0 0 0 12 1 6 2001 0)))) - ;; on 2001-06-01, there should be two hours zone offset - ;; between CET (CEST) and GMT - (= (date-zone-offset - (with-tz "CET" - (time->date time))) - 7200)))) - -(define-macro (test-time-conversion a b) - (let* ((a->b-sym (symbol-append a '-> b)) - (b->a-sym (symbol-append b '-> a))) - `(pass-if (format "~A and ~A work and are inverses of each other" - ',a->b-sym ',b->a-sym) - (let ((time (make-time ,a 12345 67890123))) - (time=? time (,b->a-sym (,a->b-sym time))))))) - -(define (test-time-comparison cmp a b) - (pass-if (format #f "~A works" cmp) - (cmp a b))) - -(define (test-time-arithmetic op a b res) - (pass-if (format #f "~A works" op) - (time=? (op a b) res))) - -(with-test-prefix "SRFI date/time library" - ;; check for typos and silly errors - (pass-if "date-zone-offset is defined" - (and (defined? 'date-zone-offset) - date-zone-offset - #t)) - (pass-if "add-duration is defined" - (and (defined? 'add-duration) - add-duration - #t)) - (pass-if "(current-time time-tai) works" - (begin (current-time time-tai) #t)) - (test-time-conversion time-utc time-tai) - (test-time-conversion time-utc time-monotonic) - (test-time-conversion time-tai time-monotonic) - (pass-if "string->date works" - (begin (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M") - #t)) - ;; check for code paths where reals were passed to quotient, which - ;; doesn't work in Guile (and is unspecified in R5RS) - (test-time->date time-utc->date date->time-utc) - (test-time->date time-tai->date date->time-tai) - (test-time->date time-monotonic->date date->time-monotonic) - (pass-if "Fractional nanoseconds are handled" - (begin (make-time time-duration 1000000000.5 0) #t)) - ;; the seconds in a time shall be maintained as integers, or - ;; precision may silently go away - (test-integral-time-structure date->time-utc) - (test-integral-time-structure date->time-tai) - (test-integral-time-structure date->time-monotonic) - ;; check for DST and zone related problems - (pass-if "date->time-utc is the inverse of time-utc->date" - (let ((time (date->time-utc - (make-date 0 0 0 14 1 6 2001 7200)))) - (time=? time - (date->time-utc (time-utc->date time 7200))))) - (test-dst time-utc->date date->time-utc) - (test-dst time-tai->date date->time-tai) - (test-dst time-monotonic->date date->time-monotonic) - (test-dst julian-day->date date->julian-day) - (test-dst modified-julian-day->date date->modified-julian-day) - (pass-if "string->date respects local DST if no time zone is read" - (time=? (date->time-utc - (with-tz "CET" - (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M"))) - (date->time-utc - (make-date 0 0 0 12 1 6 2001 0)))) - ;; check time comparison procedures - (let* ((time1 (make-time time-monotonic 0 0)) - (time2 (make-time time-monotonic 0 0)) - (time3 (make-time time-monotonic 385907 998360432)) - (time4 (make-time time-monotonic 385907 998360432))) - (test-time-comparison time<=? time1 time3) - (test-time-comparison time<? time1 time3) - (test-time-comparison time=? time1 time2) - (test-time-comparison time>=? time3 time3) - (test-time-comparison time>? time3 time2)) - ;; check time arithmetic procedures - (let* ((time1 (make-time time-monotonic 0 0)) - (time2 (make-time time-monotonic 385907 998360432)) - (diff (time-difference time2 time1))) - (test-time-arithmetic add-duration time1 diff time2) - (test-time-arithmetic subtract-duration time2 diff time1))) - -;; Local Variables: -;; eval: (put 'with-tz 'scheme-indent-function 1) -;; End: diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test deleted file mode 100644 index ac6ce3792..000000000 --- a/test-suite/tests/srfi-4.test +++ /dev/null @@ -1,312 +0,0 @@ -;;;; srfi-4.test --- Test suite for Guile's SRFI-4 functions. -*- scheme -*- -;;;; Martin Grabmueller, 2001-06-26 -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (srfi srfi-4)) - -(with-test-prefix "u8 vectors" - - (pass-if "u8vector? success" - (u8vector? (u8vector))) - - (pass-if "u8vector? failure" - (not (u8vector? (s8vector)))) - - (pass-if "u8vector-length success 1" - (= (u8vector-length (u8vector)) 0)) - - (pass-if "u8vector-length success 2" - (= (u8vector-length (u8vector 3)) 1)) - - (pass-if "u8vector-length failure" - (not (= (u8vector-length (u8vector 3)) 3))) - - (pass-if "u8vector-ref" - (= (u8vector-ref (u8vector 1 2 3) 1) 2)) - - (pass-if "u8vector-set!/ref" - (= (let ((s (make-u8vector 10 0))) - (u8vector-set! s 4 33) - (u8vector-ref s 4)) 33)) - - (pass-if "u8vector->list/list->u8vector" - (equal? (u8vector->list (u8vector 1 2 3 4)) - (u8vector->list (list->u8vector '(1 2 3 4)))))) - -(with-test-prefix "s8 vectors" - - (pass-if "s8vector? success" - (s8vector? (s8vector))) - - (pass-if "s8vector? failure" - (not (s8vector? (u8vector)))) - - (pass-if "s8vector-length success 1" - (= (s8vector-length (s8vector)) 0)) - - (pass-if "s8vector-length success 2" - (= (s8vector-length (s8vector -3)) 1)) - - (pass-if "s8vector-length failure" - (not (= (s8vector-length (s8vector 3)) 3))) - - (pass-if "s8vector-ref" - (= (s8vector-ref (s8vector 1 2 3) 1) 2)) - - (pass-if "s8vector-set!/ref" - (= (let ((s (make-s8vector 10 0))) - (s8vector-set! s 4 33) - (s8vector-ref s 4)) 33)) - - (pass-if "s8vector->list/list->s8vector" - (equal? (s8vector->list (s8vector 1 2 3 4)) - (s8vector->list (list->s8vector '(1 2 3 4)))))) - - -(with-test-prefix "u16 vectors" - - (pass-if "u16vector? success" - (u16vector? (u16vector))) - - (pass-if "u16vector? failure" - (not (u16vector? (s16vector)))) - - (pass-if "u16vector-length success 1" - (= (u16vector-length (u16vector)) 0)) - - (pass-if "u16vector-length success 2" - (= (u16vector-length (u16vector 3)) 1)) - - (pass-if "u16vector-length failure" - (not (= (u16vector-length (u16vector 3)) 3))) - - (pass-if "u16vector-ref" - (= (u16vector-ref (u16vector 1 2 3) 1) 2)) - - (pass-if "u16vector-set!/ref" - (= (let ((s (make-u16vector 10 0))) - (u16vector-set! s 4 33) - (u16vector-ref s 4)) 33)) - - (pass-if "u16vector->list/list->u16vector" - (equal? (u16vector->list (u16vector 1 2 3 4)) - (u16vector->list (list->u16vector '(1 2 3 4)))))) - -(with-test-prefix "s16 vectors" - - (pass-if "s16vector? success" - (s16vector? (s16vector))) - - (pass-if "s16vector? failure" - (not (s16vector? (u16vector)))) - - (pass-if "s16vector-length success 1" - (= (s16vector-length (s16vector)) 0)) - - (pass-if "s16vector-length success 2" - (= (s16vector-length (s16vector -3)) 1)) - - (pass-if "s16vector-length failure" - (not (= (s16vector-length (s16vector 3)) 3))) - - (pass-if "s16vector-ref" - (= (s16vector-ref (s16vector 1 2 3) 1) 2)) - - (pass-if "s16vector-set!/ref" - (= (let ((s (make-s16vector 10 0))) - (s16vector-set! s 4 33) - (s16vector-ref s 4)) 33)) - - (pass-if "s16vector->list/list->s16vector" - (equal? (s16vector->list (s16vector 1 2 3 4)) - (s16vector->list (list->s16vector '(1 2 3 4)))))) - -(with-test-prefix "u32 vectors" - - (pass-if "u32vector? success" - (u32vector? (u32vector))) - - (pass-if "u32vector? failure" - (not (u32vector? (s32vector)))) - - (pass-if "u32vector-length success 1" - (= (u32vector-length (u32vector)) 0)) - - (pass-if "u32vector-length success 2" - (= (u32vector-length (u32vector 3)) 1)) - - (pass-if "u32vector-length failure" - (not (= (u32vector-length (u32vector 3)) 3))) - - (pass-if "u32vector-ref" - (= (u32vector-ref (u32vector 1 2 3) 1) 2)) - - (pass-if "u32vector-set!/ref" - (= (let ((s (make-u32vector 10 0))) - (u32vector-set! s 4 33) - (u32vector-ref s 4)) 33)) - - (pass-if "u32vector->list/list->u32vector" - (equal? (u32vector->list (u32vector 1 2 3 4)) - (u32vector->list (list->u32vector '(1 2 3 4)))))) - -(with-test-prefix "s32 vectors" - - (pass-if "s32vector? success" - (s32vector? (s32vector))) - - (pass-if "s32vector? failure" - (not (s32vector? (u32vector)))) - - (pass-if "s32vector-length success 1" - (= (s32vector-length (s32vector)) 0)) - - (pass-if "s32vector-length success 2" - (= (s32vector-length (s32vector -3)) 1)) - - (pass-if "s32vector-length failure" - (not (= (s32vector-length (s32vector 3)) 3))) - - (pass-if "s32vector-ref" - (= (s32vector-ref (s32vector 1 2 3) 1) 2)) - - (pass-if "s32vector-set!/ref" - (= (let ((s (make-s32vector 10 0))) - (s32vector-set! s 4 33) - (s32vector-ref s 4)) 33)) - - (pass-if "s32vector->list/list->s32vector" - (equal? (s32vector->list (s32vector 1 2 3 4)) - (s32vector->list (list->s32vector '(1 2 3 4)))))) - -(with-test-prefix "u64 vectors" - - (pass-if "u64vector? success" - (u64vector? (u64vector))) - - (pass-if "u64vector? failure" - (not (u64vector? (s64vector)))) - - (pass-if "u64vector-length success 1" - (= (u64vector-length (u64vector)) 0)) - - (pass-if "u64vector-length success 2" - (= (u64vector-length (u64vector 3)) 1)) - - (pass-if "u64vector-length failure" - (not (= (u64vector-length (u64vector 3)) 3))) - - (pass-if "u64vector-ref" - (= (u64vector-ref (u64vector 1 2 3) 1) 2)) - - (pass-if "u64vector-set!/ref" - (= (let ((s (make-u64vector 10 0))) - (u64vector-set! s 4 33) - (u64vector-ref s 4)) 33)) - - (pass-if "u64vector->list/list->u64vector" - (equal? (u64vector->list (u64vector 1 2 3 4)) - (u64vector->list (list->u64vector '(1 2 3 4)))))) - -(with-test-prefix "s64 vectors" - - (pass-if "s64vector? success" - (s64vector? (s64vector))) - - (pass-if "s64vector? failure" - (not (s64vector? (u64vector)))) - - (pass-if "s64vector-length success 1" - (= (s64vector-length (s64vector)) 0)) - - (pass-if "s64vector-length success 2" - (= (s64vector-length (s64vector -3)) 1)) - - (pass-if "s64vector-length failure" - (not (= (s64vector-length (s64vector 3)) 3))) - - (pass-if "s64vector-ref" - (= (s64vector-ref (s64vector 1 2 3) 1) 2)) - - (pass-if "s64vector-set!/ref" - (= (let ((s (make-s64vector 10 0))) - (s64vector-set! s 4 33) - (s64vector-ref s 4)) 33)) - - (pass-if "s64vector->list/list->s64vector" - (equal? (s64vector->list (s64vector 1 2 3 4)) - (s64vector->list (list->s64vector '(1 2 3 4)))))) - -(with-test-prefix "f32 vectors" - - (pass-if "f32vector? success" - (f32vector? (f32vector))) - - (pass-if "f32vector? failure" - (not (f32vector? (s8vector)))) - - (pass-if "f32vector-length success 1" - (= (f32vector-length (f32vector)) 0)) - - (pass-if "f32vector-length success 2" - (= (f32vector-length (f32vector -3)) 1)) - - (pass-if "f32vector-length failure" - (not (= (f32vector-length (f32vector 3)) 3))) - - (pass-if "f32vector-ref" - (= (f32vector-ref (f32vector 1 2 3) 1) 2)) - - (pass-if "f32vector-set!/ref" - (= (let ((s (make-f32vector 10 0))) - (f32vector-set! s 4 33) - (f32vector-ref s 4)) 33)) - - (pass-if "f32vector->list/list->f32vector" - (equal? (f32vector->list (f32vector 1 2 3 4)) - (f32vector->list (list->f32vector '(1 2 3 4)))))) - -(with-test-prefix "f64 vectors" - - (pass-if "f64vector? success" - (f64vector? (f64vector))) - - (pass-if "f64vector? failure" - (not (f64vector? (f32vector)))) - - (pass-if "f64vector-length success 1" - (= (f64vector-length (f64vector)) 0)) - - (pass-if "f64vector-length success 2" - (= (f64vector-length (f64vector -3)) 1)) - - (pass-if "f64vector-length failure" - (not (= (f64vector-length (f64vector 3)) 3))) - - (pass-if "f64vector-ref" - (= (f64vector-ref (f64vector 1 2 3) 1) 2)) - - (pass-if "f64vector-set!/ref" - (= (let ((s (make-f64vector 10 0))) - (f64vector-set! s 4 33) - (f64vector-ref s 4)) 33)) - - (pass-if "f64vector->list/list->f64vector" - (equal? (f64vector->list (f64vector 1 2 3 4)) - (f64vector->list (list->f64vector '(1 2 3 4)))))) diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test deleted file mode 100644 index da33d5488..000000000 --- a/test-suite/tests/srfi-9.test +++ /dev/null @@ -1,42 +0,0 @@ -;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*- -;;;; Martin Grabmueller, 2001-05-10 -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (srfi srfi-9)) - -(define-record-type :foo (make-foo x) foo? - (x get-x) (y get-y set-y!)) - -(define f (make-foo 1)) -(set-y! f 2) - -(with-test-prefix "record procedures" - - (pass-if "predicate" - (foo? f)) - - (pass-if "accessor 1" - (= 1 (get-x f))) - - (pass-if "accessor 2" - (= 2 (get-y f))) - - (pass-if "modifier" - (set-y! f #t) - (eq? #t (get-y f)))) diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test deleted file mode 100644 index 432100f6f..000000000 --- a/test-suite/tests/strings.test +++ /dev/null @@ -1,88 +0,0 @@ -;;;; strings.test --- test suite for Guile's string functions -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- August 1999 -;;;; -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - - -;; FIXME: As soon as guile supports immutable strings, this has to be -;; replaced with the appropriate error type and message. -(define exception:immutable-string - (cons 'some-error-type "^trying to modify an immutable string")) - - -(with-test-prefix "string=?" - - (pass-if "respects 1st parameter's string length" - (not (string=? "foo\0" "foo"))) - - (pass-if "respects 2nd paramter's string length" - (not (string=? "foo" "foo\0"))) - - (with-test-prefix "wrong argument type" - - (pass-if-exception "1st argument symbol" - exception:wrong-type-arg - (string=? 'a "a")) - - (pass-if-exception "2nd argument symbol" - exception:wrong-type-arg - (string=? "a" 'b)))) - -(with-test-prefix "string<?" - - (pass-if "respects string length" - (and (not (string<? "foo\0a" "foo\0a")) - (string<? "foo\0a" "foo\0b"))) - - (with-test-prefix "wrong argument type" - - (pass-if-exception "1st argument symbol" - exception:wrong-type-arg - (string<? 'a "a")) - - (pass-if-exception "2nd argument symbol" - exception:wrong-type-arg - (string<? "a" 'b)))) - -(with-test-prefix "string-ci<?" - - (pass-if "respects string length" - (and (not (string-ci<? "foo\0a" "foo\0a")) - (string-ci<? "foo\0a" "foo\0b"))) - - (with-test-prefix "wrong argument type" - - (pass-if-exception "1st argument symbol" - exception:wrong-type-arg - (string-ci<? 'a "a")) - - (pass-if-exception "2nd argument symbol" - exception:wrong-type-arg - (string-ci<? "a" 'b)))) - -(with-test-prefix "string-set!" - - (expect-fail-exception "string constant" - exception:immutable-string - (string-set! "abc" 1 #\space))) - -(with-test-prefix "substring-move!" - - (pass-if-exception "substring-move! checks start and end correctly" - exception:out-of-range - (substring-move! "sample" 3 0 "test" 3))) diff --git a/test-suite/tests/symbols.test b/test-suite/tests/symbols.test deleted file mode 100644 index 7831a9514..000000000 --- a/test-suite/tests/symbols.test +++ /dev/null @@ -1,90 +0,0 @@ -;;;; symbols.test --- test suite for Guile's symbols -*- scheme -*- -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (ice-9 documentation)) - - -;;; -;;; miscellaneous -;;; - -;; FIXME: As soon as guile supports immutable strings, this has to be -;; replaced with the appropriate error type and message. -(define exception:immutable-string - (cons 'some-error-type "^trying to modify an immutable string")) - -(define (documented? object) - (not (not (object-documentation object)))) - - -;;; -;;; symbol? -;;; - -(with-test-prefix "symbol?" - - (pass-if "documented?" - (documented? symbol?)) - - (pass-if "string" - (not (symbol? "foo"))) - - (pass-if "symbol" - (symbol? 'foo))) - - -;;; -;;; symbol->string -;;; - -(with-test-prefix "symbol->string" - - (expect-fail-exception "result is an immutable string" - exception:immutable-string - (string-set! (symbol->string 'abc) 1 #\space))) - - -;;; -;;; gensym -;;; - -(with-test-prefix "gensym" - - (pass-if "documented?" - (documented? gensym)) - - (pass-if "produces a symbol" - (symbol? (gensym))) - - (pass-if "produces a fresh symbol" - (not (eq? (gensym) (gensym)))) - - (pass-if "accepts a string prefix" - (symbol? (gensym "foo"))) - - (pass-if-exception "does not accept a symbol prefix" - exception:wrong-type-arg - (gensym 'foo)) - - (pass-if "accepts long prefices" - (symbol? (gensym (make-string 4000 #\!)))) - - (pass-if "accepts embedded NULs" - (> (string-length (symbol->string (gensym "foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0"))) 6))) - diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test deleted file mode 100644 index 88667ea06..000000000 --- a/test-suite/tests/syncase.test +++ /dev/null @@ -1,37 +0,0 @@ -;;;; syncase.test --- test suite for (ice-9 syncase) -*- scheme -*- -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -;; These tests are in a module so that the syntax transformer does not -;; affect code outside of this file. -;; -(define-module (syncase-test)) - -(use-modules (test-suite lib)) - -(pass-if "(ice-9 syncase) loads" - (false-if-exception - (begin (eval '(use-syntax (ice-9 syncase)) (current-module)) - #t))) - -(define-syntax plus - (syntax-rules () - ((plus x ...) (+ x ...)))) - -(pass-if "basic syncase macro" - (= (plus 1 2 3) (+ 1 2 3))) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test deleted file mode 100644 index 14836fbc9..000000000 --- a/test-suite/tests/syntax.test +++ /dev/null @@ -1,532 +0,0 @@ -;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*- -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - - -(define exception:bad-bindings - (cons 'misc-error "^bad bindings")) -(define exception:duplicate-bindings - (cons 'misc-error "^duplicate bindings")) -(define exception:bad-body - (cons 'misc-error "^bad body")) -(define exception:bad-formals - (cons 'misc-error "^bad formals")) -(define exception:duplicate-formals - (cons 'misc-error "^duplicate formals")) -(define exception:bad-var - (cons 'misc-error "^bad variable")) -(define exception:bad/missing-clauses - (cons 'misc-error "^bad or missing clauses")) -(define exception:missing/extra-expr - (cons 'misc-error "^missing or extra expression")) - - -(with-test-prefix "expressions" - - (with-test-prefix "missing or extra expression" - - ;; R5RS says: - ;; *Note:* In many dialects of Lisp, the empty combination, (), - ;; is a legitimate expression. In Scheme, combinations must - ;; have at least one subexpression, so () is not a syntactically - ;; valid expression. - - ;; Fixed on 2001-3-3 - (pass-if-exception "empty parentheses \"()\"" - exception:missing/extra-expr - ()))) - -(with-test-prefix "quote" - #t) - -(with-test-prefix "quasiquote" - - (with-test-prefix "unquote" - - (pass-if "repeated execution" - (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i))))) - (and (equal? (foo) '(1)) (equal? (foo) '(2)))))) - - (with-test-prefix "unquote-splicing" - - (pass-if-exception "extra arguments" - exception:missing/extra-expr - (quasiquote ((unquote-splicing (list 1 2) (list 3 4))))))) - -(with-test-prefix "begin" - - (pass-if "legal (begin)" - (begin) - #t) - - (expect-fail-exception "illegal (begin)" - exception:bad-body - (if #t (begin)) - #t)) - -(with-test-prefix "lambda" - - (with-test-prefix "bad formals" - - (pass-if-exception "(lambda)" - exception:bad-formals - (lambda)) - - (pass-if-exception "(lambda . \"foo\")" - exception:bad-formals - (lambda . "foo")) - - (pass-if-exception "(lambda \"foo\")" - exception:bad-formals - (lambda "foo")) - - (pass-if-exception "(lambda \"foo\" #f)" - exception:bad-formals - (lambda "foo" #f)) - - (pass-if-exception "(lambda (x 1) 2)" - exception:bad-formals - (lambda (x 1) 2)) - - (pass-if-exception "(lambda (1 x) 2)" - exception:bad-formals - (lambda (1 x) 2)) - - (pass-if-exception "(lambda (x \"a\") 2)" - exception:bad-formals - (lambda (x "a") 2)) - - (pass-if-exception "(lambda (\"a\" x) 2)" - exception:bad-formals - (lambda ("a" x) 2))) - - (with-test-prefix "duplicate formals" - - ;; Fixed on 2001-3-3 - (pass-if-exception "(lambda (x x) 1)" - exception:duplicate-formals - (lambda (x x) 1)) - - ;; Fixed on 2001-3-3 - (pass-if-exception "(lambda (x x x) 1)" - exception:duplicate-formals - (lambda (x x x) 1))) - - (with-test-prefix "bad body" - - (pass-if-exception "(lambda ())" - exception:bad-body - (lambda ())))) - -(with-test-prefix "let" - - (with-test-prefix "bindings" - - (pass-if-exception "late binding" - exception:unbound-var - (let ((x 1) (y x)) y))) - - (with-test-prefix "bad bindings" - - (pass-if-exception "(let)" - exception:bad-bindings - (let)) - - (pass-if-exception "(let 1)" - exception:bad-bindings - (let 1)) - - (pass-if-exception "(let (x))" - exception:bad-bindings - (let (x))) - - ;; FIXME: Wouldn't one rather expect a 'bad bindings' error? - ;; (Even although the body is bad as well...) - (pass-if-exception "(let ((x)))" - exception:bad-body - (let ((x)))) - - (pass-if-exception "(let (x) 1)" - exception:bad-bindings - (let (x) 1)) - - (pass-if-exception "(let ((x)) 3)" - exception:bad-bindings - (let ((x)) 3)) - - (pass-if-exception "(let ((x 1) y) x)" - exception:bad-bindings - (let ((x 1) y) x)) - - (pass-if-exception "(let ((1 2)) 3)" - exception:bad-var - (let ((1 2)) 3))) - - (with-test-prefix "duplicate bindings" - - (pass-if-exception "(let ((x 1) (x 2)) x)" - exception:duplicate-bindings - (let ((x 1) (x 2)) x))) - - (with-test-prefix "bad body" - - (pass-if-exception "(let ())" - exception:bad-body - (let ())) - - (pass-if-exception "(let ((x 1)))" - exception:bad-body - (let ((x 1)))))) - -(with-test-prefix "named let" - - (with-test-prefix "initializers" - - (pass-if "evaluated in outer environment" - (let ((f -)) - (eqv? (let f ((n (f 1))) n) -1)))) - - (with-test-prefix "bad bindings" - - (pass-if-exception "(let x (y))" - exception:bad-bindings - (let x (y)))) - - (with-test-prefix "bad body" - - (pass-if-exception "(let x ())" - exception:bad-body - (let x ())) - - (pass-if-exception "(let x ((y 1)))" - exception:bad-body - (let x ((y 1)))))) - -(with-test-prefix "let*" - - (with-test-prefix "bindings" - - (pass-if "(let* ((x 1) (x 2)) ...)" - (let* ((x 1) (x 2)) - (= x 2))) - - (pass-if "(let* ((x 1) (x x)) ...)" - (let* ((x 1) (x x)) - (= x 1)))) - - (with-test-prefix "bad bindings" - - (pass-if-exception "(let*)" - exception:bad-bindings - (let*)) - - (pass-if-exception "(let* 1)" - exception:bad-bindings - (let* 1)) - - (pass-if-exception "(let* (x))" - exception:bad-bindings - (let* (x))) - - (pass-if-exception "(let* (x) 1)" - exception:bad-bindings - (let* (x) 1)) - - (pass-if-exception "(let* ((x)) 3)" - exception:bad-bindings - (let* ((x)) 3)) - - (pass-if-exception "(let* ((x 1) y) x)" - exception:bad-bindings - (let* ((x 1) y) x)) - - (pass-if-exception "(let* x ())" - exception:bad-bindings - (let* x ())) - - (pass-if-exception "(let* x (y))" - exception:bad-bindings - (let* x (y))) - - (pass-if-exception "(let* ((1 2)) 3)" - exception:bad-var - (let* ((1 2)) 3))) - - (with-test-prefix "bad body" - - (pass-if-exception "(let* ())" - exception:bad-body - (let* ())) - - (pass-if-exception "(let* ((x 1)))" - exception:bad-body - (let* ((x 1)))))) - -(with-test-prefix "letrec" - - (with-test-prefix "bindings" - - (pass-if-exception "initial bindings are undefined" - exception:unbound-var - (let ((x 1)) - (letrec ((x 1) (y x)) y)))) - - (with-test-prefix "bad bindings" - - (pass-if-exception "(letrec)" - exception:bad-bindings - (letrec)) - - (pass-if-exception "(letrec 1)" - exception:bad-bindings - (letrec 1)) - - (pass-if-exception "(letrec (x))" - exception:bad-bindings - (letrec (x))) - - (pass-if-exception "(letrec (x) 1)" - exception:bad-bindings - (letrec (x) 1)) - - (pass-if-exception "(letrec ((x)) 3)" - exception:bad-bindings - (letrec ((x)) 3)) - - (pass-if-exception "(letrec ((x 1) y) x)" - exception:bad-bindings - (letrec ((x 1) y) x)) - - (pass-if-exception "(letrec x ())" - exception:bad-bindings - (letrec x ())) - - (pass-if-exception "(letrec x (y))" - exception:bad-bindings - (letrec x (y))) - - (pass-if-exception "(letrec ((1 2)) 3)" - exception:bad-var - (letrec ((1 2)) 3))) - - (with-test-prefix "duplicate bindings" - - (pass-if-exception "(letrec ((x 1) (x 2)) x)" - exception:duplicate-bindings - (letrec ((x 1) (x 2)) x))) - - (with-test-prefix "bad body" - - (pass-if-exception "(letrec ())" - exception:bad-body - (letrec ())) - - (pass-if-exception "(letrec ((x 1)))" - exception:bad-body - (letrec ((x 1)))))) - -(with-test-prefix "if" - - (with-test-prefix "missing or extra expressions" - - (pass-if-exception "(if)" - exception:missing/extra-expr - (if)) - - (pass-if-exception "(if 1 2 3 4)" - exception:missing/extra-expr - (if 1 2 3 4)))) - -(with-test-prefix "cond" - - (with-test-prefix "bad or missing clauses" - - (pass-if-exception "(cond)" - exception:bad/missing-clauses - (cond)) - - (pass-if-exception "(cond #t)" - exception:bad/missing-clauses - (cond #t)) - - (pass-if-exception "(cond 1)" - exception:bad/missing-clauses - (cond 1)) - - (pass-if-exception "(cond 1 2)" - exception:bad/missing-clauses - (cond 1 2)) - - (pass-if-exception "(cond 1 2 3)" - exception:bad/missing-clauses - (cond 1 2 3)) - - (pass-if-exception "(cond 1 2 3 4)" - exception:bad/missing-clauses - (cond 1 2 3 4)) - - (pass-if-exception "(cond ())" - exception:bad/missing-clauses - (cond ())) - - (pass-if-exception "(cond () 1)" - exception:bad/missing-clauses - (cond () 1)) - - (pass-if-exception "(cond (1) 1)" - exception:bad/missing-clauses - (cond (1) 1)))) - -(with-test-prefix "cond =>" - - (with-test-prefix "else is handled correctly" - - (pass-if "else =>" - (let ((=> 'foo)) - (eq? (cond (else =>)) 'foo))) - - (pass-if "else => identity" - (let* ((=> 'foo)) - (eq? (cond (else => identity)) identity)))) - - (with-test-prefix "bad formals" - - (pass-if-exception "=> (lambda (x 1) 2)" - exception:bad-formals - (cond (1 => (lambda (x 1) 2)))))) - -(with-test-prefix "case" - - (with-test-prefix "bad or missing clauses" - - (pass-if-exception "(case)" - exception:bad/missing-clauses - (case)) - - (pass-if-exception "(case . \"foo\")" - exception:bad/missing-clauses - (case . "foo")) - - (pass-if-exception "(case 1)" - exception:bad/missing-clauses - (case 1)) - - (pass-if-exception "(case 1 . \"foo\")" - exception:bad/missing-clauses - (case 1 . "foo")) - - (pass-if-exception "(case 1 \"foo\")" - exception:bad/missing-clauses - (case 1 "foo")) - - (pass-if-exception "(case 1 ())" - exception:bad/missing-clauses - (case 1 ())) - - (pass-if-exception "(case 1 (\"foo\"))" - exception:bad/missing-clauses - (case 1 ("foo"))) - - (pass-if-exception "(case 1 (\"foo\" \"bar\"))" - exception:bad/missing-clauses - (case 1 ("foo" "bar"))) - - ;; According to R5RS, the following one is syntactically correct. - ;; (pass-if-exception "(case 1 (() \"bar\"))" - ;; exception:bad/missing-clauses - ;; (case 1 (() "bar"))) - - (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")" - exception:bad/missing-clauses - (case 1 ((2) "bar") . "foo")) - - (pass-if-exception "(case 1 (else #f) ((1) #t))" - exception:bad/missing-clauses - (case 1 ((2) "bar") (else))) - - (pass-if-exception "(case 1 (else #f) . \"foo\")" - exception:bad/missing-clauses - (case 1 (else #f) . "foo")) - - (pass-if-exception "(case 1 (else #f) ((1) #t))" - exception:bad/missing-clauses - (case 1 (else #f) ((1) #t))))) - -(with-test-prefix "define" - - (with-test-prefix "currying" - - (pass-if "(define ((foo)) #f)" - (define ((foo)) #t) - ((foo)))) - - (with-test-prefix "missing or extra expressions" - - (pass-if-exception "(define)" - exception:missing/extra-expr - (define)))) - -(with-test-prefix "set!" - - (with-test-prefix "missing or extra expressions" - - (pass-if-exception "(set!)" - exception:missing/extra-expr - (set!)) - - (pass-if-exception "(set! 1)" - exception:missing/extra-expr - (set! 1)) - - (pass-if-exception "(set! 1 2 3)" - exception:missing/extra-expr - (set! 1 2 3))) - - (with-test-prefix "bad variable" - - (pass-if-exception "(set! \"\" #t)" - exception:bad-var - (set! "" #t)) - - (pass-if-exception "(set! 1 #t)" - exception:bad-var - (set! 1 #t)) - - (pass-if-exception "(set! #t #f)" - exception:bad-var - (set! #t #f)) - - (pass-if-exception "(set! #f #t)" - exception:bad-var - (set! #f #t)) - - (pass-if-exception "(set! #\space #f)" - exception:bad-var - (set! #\space #f)))) - -(with-test-prefix "quote" - - (with-test-prefix "missing or extra expression" - - (pass-if-exception "(quote)" - exception:missing/extra-expr - (quote)) - - (pass-if-exception "(quote a b)" - exception:missing/extra-expr - (quote a b)))) diff --git a/test-suite/tests/time.test b/test-suite/tests/time.test deleted file mode 100644 index 59b9125db..000000000 --- a/test-suite/tests/time.test +++ /dev/null @@ -1,28 +0,0 @@ -;;;; time.test --- test suite for Guile's time functions -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- June 1999 -;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (test-suite lib) - (ice-9 regex)) - -(pass-if "strftime %Z doesn't return garbage" - (let ((t (localtime (current-time)))) - (vector-set! t 10 "ZOW") - (string=? (strftime "%Z" t) - "ZOW"))) diff --git a/test-suite/tests/version.test b/test-suite/tests/version.test deleted file mode 100644 index 79587923d..000000000 --- a/test-suite/tests/version.test +++ /dev/null @@ -1,30 +0,0 @@ -;;;; versions.test --- test suite for Guile's version functions -*- scheme -*- -;;;; Greg J. Badros <gjb@cs.washington.edu> -;;;; -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (test-suite lib)) - -(pass-if "version reporting works" - (and (string? (major-version)) - (string? (minor-version)) - (string? (micro-version)) - (string=? (version) - (string-append (major-version) "." - (minor-version) "." - (micro-version))))) diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test deleted file mode 100644 index e66c89282..000000000 --- a/test-suite/tests/weaks.test +++ /dev/null @@ -1,210 +0,0 @@ -;;;; weaks.test --- tests guile's weaks -*- scheme -*- -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. -;;;; -;;;; 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, 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 software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; As a special exception, the Free Software Foundation gives permission -;;;; for additional uses of the text contained in its release of GUILE. -;;;; -;;;; The exception is that, if you link the GUILE library with other files -;;;; to produce an executable, this does not by itself cause the -;;;; resulting executable to be covered by the GNU General Public License. -;;;; Your use of that executable is in no way restricted on account of -;;;; linking the GUILE library code into it. -;;;; -;;;; This exception does not however invalidate any other reasons why -;;;; the executable file might be covered by the GNU General Public License. -;;;; -;;;; This exception applies only to the code released by the -;;;; Free Software Foundation under the name GUILE. If you copy -;;;; code from other Free Software Foundation releases into a copy of -;;;; GUILE, as the General Public License permits, the exception does -;;;; not apply to the code that you add in this way. To avoid misleading -;;;; anyone as to the status of such modified files, you must delete -;;;; this exception notice from them. -;;;; -;;;; If you write modifications of your own for GUILE, it is your choice -;;;; whether to permit this exception to apply to your modifications. -;;;; If you do not wish that, delete this exception notice. - -;;; {Description} - -;;; This is a semi test suite for weaks; I say semi, because weaks -;;; are pretty non-deterministic given the amount of information we -;;; can infer from scheme. -;;; -;;; In particular, we can't always reliably test the more important -;;; aspects of weaks (i.e., that an object is removed when it's dead) -;;; because we have no way of knowing for certain that the object is -;;; really dead. It tests it anyway, but the failures of any `death' -;;; tests really shouldn't be surprising. -;;; -;;; Interpret failures in the dying functions here as a hint that you -;;; should look at any changes you've made involving weaks -;;; (everything else should always pass), but there are a host of -;;; other reasons why they might not work as tested here, so if you -;;; haven't done anything to weaks, don't sweat it :) - -;;; Creation functions - - -(with-test-prefix - "weak-creation" - (with-test-prefix "make-weak-vector" - (pass-if "normal" - (make-weak-vector 10 #f) - #t) - (pass-if-exception "bad size" - exception:wrong-type-arg - (make-weak-vector 'foo))) - - (with-test-prefix "list->weak-vector" - (pass-if "create" - (let* ((lst '(a b c d e f g)) - (wv (list->weak-vector lst))) - (and (eq? (vector-ref wv 0) 'a) - (eq? (vector-ref wv 1) 'b) - (eq? (vector-ref wv 2) 'c) - (eq? (vector-ref wv 3) 'd) - (eq? (vector-ref wv 4) 'e) - (eq? (vector-ref wv 5) 'f) - (eq? (vector-ref wv 6) 'g)))) - (pass-if-exception "bad-args" - exception:wrong-type-arg - (list->weak-vector 32))) - - (with-test-prefix "make-weak-key-hash-table" - (pass-if "create" - (make-weak-key-hash-table 17) - #t) - (pass-if-exception "bad-args" - exception:wrong-type-arg - (make-weak-key-hash-table '(bad arg)))) - (with-test-prefix "make-weak-value-hash-table" - (pass-if "create" - (make-weak-value-hash-table 17) - #t) - (pass-if-exception "bad-args" - exception:wrong-type-arg - (make-weak-value-hash-table '(bad arg)))) - - (with-test-prefix "make-doubly-weak-hash-table" - (pass-if "create" - (make-doubly-weak-hash-table 17) - #t) - (pass-if-exception "bad-args" - exception:wrong-type-arg - (make-doubly-weak-hash-table '(bad arg))))) - - - - -;; This should remove most of the non-dying problems associated with -;; trying this inside a closure - -(define global-weak (make-weak-vector 10 #f)) -(begin - (vector-set! global-weak 0 "string") - (vector-set! global-weak 1 "beans") - (vector-set! global-weak 2 "to") - (vector-set! global-weak 3 "utah") - (vector-set! global-weak 4 "yum yum") - (gc)) - -;;; Normal weak vectors -(let ((x (make-weak-vector 10 #f)) - (bar "bar")) - (with-test-prefix - "weak-vector" - (pass-if "lives" - (begin - (vector-set! x 0 bar) - (gc) - (and (vector-ref x 0) (eq? bar (vector-ref x 0))))) - (pass-if "dies" - (begin - (gc) - (or (not (vector-ref global-weak 0)) - (not (vector-ref global-weak 1)) - (not (vector-ref global-weak 2)) - (not (vector-ref global-weak 3)) - (not (vector-ref global-weak 4))))))) - - (let ((x (make-weak-key-hash-table 17)) - (y (make-weak-value-hash-table 17)) - (z (make-doubly-weak-hash-table 17)) - (test-key "foo") - (test-value "bar")) - (with-test-prefix - "weak-hash" - (pass-if "lives" - (begin - (hashq-set! x test-key test-value) - (hashq-set! y test-key test-value) - (hashq-set! z test-key test-value) - (gc) - (gc) - (and (hashq-ref x test-key) - (hashq-ref y test-key) - (hashq-ref z test-key) - #t))) - (pass-if "weak-key dies" - (begin - (hashq-set! x "this" "is") - (hashq-set! x "a" "test") - (hashq-set! x "of" "the") - (hashq-set! x "emergency" "weak") - (hashq-set! x "key" "hash system") - (gc) - (and - (or (not (hashq-ref x "this")) - (not (hashq-ref x "a")) - (not (hashq-ref x "of")) - (not (hashq-ref x "emergency")) - (not (hashq-ref x "key"))) - (hashq-ref x test-key) - #t))) - - (pass-if "weak-value dies" - (begin - (hashq-set! y "this" "is") - (hashq-set! y "a" "test") - (hashq-set! y "of" "the") - (hashq-set! y "emergency" "weak") - (hashq-set! y "value" "hash system") - (gc) - (and (or (not (hashq-ref y "this")) - (not (hashq-ref y "a")) - (not (hashq-ref y "of")) - (not (hashq-ref y "emergency")) - (not (hashq-ref y "value"))) - (hashq-ref y test-key) - #t))) - (pass-if "doubly-weak dies" - (begin - (hashq-set! z "this" "is") - (hashq-set! z "a" "test") - (hashq-set! z "of" "the") - (hashq-set! z "emergency" "weak") - (hashq-set! z "all" "hash system") - (gc) - (and (or (not (hashq-ref z "this")) - (not (hashq-ref z "a")) - (not (hashq-ref z "of")) - (not (hashq-ref z "emergency")) - (not (hashq-ref z "all"))) - (hashq-ref z test-key) - #t))))) |