summaryrefslogtreecommitdiff
path: root/test-suite
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite')
-rw-r--r--test-suite/.cvsignore6
-rw-r--r--test-suite/COPYING340
-rw-r--r--test-suite/ChangeLog815
-rw-r--r--test-suite/Makefile.am52
-rw-r--r--test-suite/README47
-rwxr-xr-xtest-suite/guile-test235
-rw-r--r--test-suite/lib.scm484
-rw-r--r--test-suite/tests/alist.test269
-rw-r--r--test-suite/tests/asmobs/Makefile0
-rw-r--r--test-suite/tests/asmobs/README0
-rw-r--r--test-suite/tests/asmobs/asmobs-test.scm0
-rw-r--r--test-suite/tests/asmobs/asmobs.c0
-rw-r--r--test-suite/tests/bit-operations.test354
-rw-r--r--test-suite/tests/c-api.test46
-rw-r--r--test-suite/tests/c-api/Makefile16
-rw-r--r--test-suite/tests/c-api/README7
-rw-r--r--test-suite/tests/c-api/strings.c70
-rw-r--r--test-suite/tests/c-api/testlib.c121
-rw-r--r--test-suite/tests/c-api/testlib.h28
-rw-r--r--test-suite/tests/chars.test31
-rw-r--r--test-suite/tests/common-list.test242
-rw-r--r--test-suite/tests/dynamic-scope.test78
-rw-r--r--test-suite/tests/elisp.test355
-rw-r--r--test-suite/tests/environments.test1070
-rw-r--r--test-suite/tests/eval.test248
-rw-r--r--test-suite/tests/exceptions.test86
-rw-r--r--test-suite/tests/format.test39
-rw-r--r--test-suite/tests/gc.test67
-rw-r--r--test-suite/tests/getopt-long.test274
-rw-r--r--test-suite/tests/goops.test169
-rw-r--r--test-suite/tests/guardians.test65
-rw-r--r--test-suite/tests/hooks.test149
-rw-r--r--test-suite/tests/import.test76
-rw-r--r--test-suite/tests/interp.test53
-rw-r--r--test-suite/tests/list.test628
-rw-r--r--test-suite/tests/load.test126
-rw-r--r--test-suite/tests/multilingual.nottest81
-rw-r--r--test-suite/tests/numbers.test1490
-rw-r--r--test-suite/tests/optargs.test29
-rw-r--r--test-suite/tests/ports.test466
-rw-r--r--test-suite/tests/r4rs.test1024
-rw-r--r--test-suite/tests/reader.test41
-rw-r--r--test-suite/tests/regexp.test102
-rw-r--r--test-suite/tests/srfi-10.test30
-rw-r--r--test-suite/tests/srfi-13.test1029
-rw-r--r--test-suite/tests/srfi-14.test188
-rw-r--r--test-suite/tests/srfi-17.test32
-rw-r--r--test-suite/tests/srfi-19.test157
-rw-r--r--test-suite/tests/srfi-4.test312
-rw-r--r--test-suite/tests/srfi-9.test42
-rw-r--r--test-suite/tests/strings.test88
-rw-r--r--test-suite/tests/symbols.test90
-rw-r--r--test-suite/tests/syncase.test37
-rw-r--r--test-suite/tests/syntax.test532
-rw-r--r--test-suite/tests/time.test28
-rw-r--r--test-suite/tests/version.test30
-rw-r--r--test-suite/tests/weaks.test210
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)))))