mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 20:30:28 +02:00
This commit was manufactured by cvs2svn to create tag
'mdj-pre-ansi-string'.
This commit is contained in:
cvs2svn
parent
fcb1720f87
commit
e5df49234e
30 changed files with 0 additions and 4169 deletions
|
|
@ -1 +0,0 @@
|
||||||
guile.log
|
|
||||||
|
|
@ -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.
|
|
||||||
|
|
@ -1,166 +0,0 @@
|
||||||
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.
|
|
||||||
|
|
||||||
|
|
@ -1,25 +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.
|
|
||||||
|
|
||||||
Right now, we only have tests for I/O ports.
|
|
||||||
|
|
||||||
To run the test suite, you'll need to:
|
|
||||||
- edit the path to the guile interpreter in `guile-test', and
|
|
||||||
- edit the paths in `paths.scm', so `guile-test' can find the test
|
|
||||||
scripts.
|
|
||||||
|
|
||||||
Once that's done, you can just run the `guile-test' script. That
|
|
||||||
script has usage instructions in the comments at the top.
|
|
||||||
|
|
||||||
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.
|
|
||||||
|
|
@ -1,162 +0,0 @@
|
||||||
#!/usr/local/bin/guile \
|
|
||||||
-e main -s
|
|
||||||
!#
|
|
||||||
|
|
||||||
;;;; guile-test --- run the Guile test suite
|
|
||||||
;;;; Jim Blandy <jimb@red-bean.com> --- May 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
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;;; Usage: guile-test [--log-file LOG] [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'.
|
|
||||||
;;;;
|
|
||||||
;;;; 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.
|
|
||||||
;;;;
|
|
||||||
;;;; If present, the `--log-file LOG' option tells `guile-test' to put
|
|
||||||
;;;; the log output in a file named LOG.
|
|
||||||
;;;;
|
|
||||||
;;;; Installation:
|
|
||||||
;;;;
|
|
||||||
;;;; Change the #! line at the top of this script to point at the
|
|
||||||
;;;; Guile interpreter you want to test. Edit `test-suite/paths.scm'
|
|
||||||
;;;; so that datadir points to the parent directory of the `tests' tree.
|
|
||||||
;;;;
|
|
||||||
;;;; 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 patche 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.
|
|
||||||
|
|
||||||
(use-modules (test-suite lib)
|
|
||||||
(test-suite paths)
|
|
||||||
(ice-9 getopt-long)
|
|
||||||
(ice-9 and-let*))
|
|
||||||
|
|
||||||
|
|
||||||
;;; General utilities, that probably should be in a library somewhere.
|
|
||||||
|
|
||||||
;;; 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 ".."))
|
|
||||||
(loop))
|
|
||||||
(else
|
|
||||||
(visit (string-append root "/" entry))
|
|
||||||
(loop))))))))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; The test driver.
|
|
||||||
|
|
||||||
(define test-root (in-vicinity datadir "tests"))
|
|
||||||
|
|
||||||
(define (test-file-name test)
|
|
||||||
(in-vicinity test-root test))
|
|
||||||
|
|
||||||
;;; Return a list of all the test files in the test tree.
|
|
||||||
(define (enumerate-tests)
|
|
||||||
(let ((root-len (+ 1 (string-length test-root)))
|
|
||||||
(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-root)
|
|
||||||
|
|
||||||
;; 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
|
|
||||||
`((log-file (single-char #\l)
|
|
||||||
(value #t))))))
|
|
||||||
(define (opt tag default)
|
|
||||||
(let ((pair (assq tag options)))
|
|
||||||
(if pair (cdr pair) default)))
|
|
||||||
(let ((log-file (opt 'log-file "guile.log"))
|
|
||||||
(tests (let ((foo (opt '() '())))
|
|
||||||
(if (null? foo) (enumerate-tests)
|
|
||||||
foo))))
|
|
||||||
|
|
||||||
;; Open the log file.
|
|
||||||
(let ((log-port (open-output-file log-file)))
|
|
||||||
|
|
||||||
;; Register some reporters.
|
|
||||||
(let ((counter (make-count-reporter)))
|
|
||||||
(register-reporter (car counter))
|
|
||||||
(register-reporter (make-log-reporter log-port))
|
|
||||||
(register-reporter user-reporter)
|
|
||||||
|
|
||||||
;; Run the tests.
|
|
||||||
(for-each (lambda (test)
|
|
||||||
(with-test-prefix test
|
|
||||||
(catch-test-errors
|
|
||||||
(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))))))
|
|
||||||
|
|
||||||
|
|
||||||
;;; Local Variables:
|
|
||||||
;;; mode: scheme
|
|
||||||
;;; End:
|
|
||||||
|
|
@ -1,450 +0,0 @@
|
||||||
;;;; test-suite/lib.scm --- generic support for testing
|
|
||||||
;;;; 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-module (test-suite lib)
|
|
||||||
#:use-module (test-suite paths))
|
|
||||||
|
|
||||||
(export
|
|
||||||
|
|
||||||
;; Reporting passes and failures.
|
|
||||||
pass fail pass-if
|
|
||||||
|
|
||||||
;; Indicating tests that are expected to fail.
|
|
||||||
expect-failure expect-failure-if expect-failure-if*
|
|
||||||
|
|
||||||
;; Marking independent groups of tests.
|
|
||||||
catch-test-errors catch-test-errors*
|
|
||||||
|
|
||||||
;; 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
|
|
||||||
|
|
||||||
;; Finding test input files.
|
|
||||||
data-file
|
|
||||||
|
|
||||||
;; Noticing whether an error occurs.
|
|
||||||
signals-error? signals-error?*)
|
|
||||||
|
|
||||||
|
|
||||||
;;;; If you're using Emacs's Scheme mode:
|
|
||||||
;;;; (put 'expect-failure 'scheme-indent-function 0)
|
|
||||||
;;;; (put 'with-test-prefix 'scheme-indent-function 1)
|
|
||||||
|
|
||||||
|
|
||||||
;;;; 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.
|
|
||||||
;;;;
|
|
||||||
;;;; The functions for reporting results (PASS, FAIL, PASS-IF, ...)
|
|
||||||
;;;; take the name of the passing/failing test as an argument.
|
|
||||||
;;;; For example:
|
|
||||||
;;;;
|
|
||||||
;;;; (if (= 4 (+ 2 2))
|
|
||||||
;;;; (pass "simple addition"))
|
|
||||||
;;;;
|
|
||||||
;;;; 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 "division" (= (- 4 2) 2)))
|
|
||||||
;;;; (pass-if "multiplication" (= (* 2 2) 4)))
|
|
||||||
;;;;
|
|
||||||
;;;; In that example, the three test names are:
|
|
||||||
;;;; ("basic arithmetic" "addition"),
|
|
||||||
;;;; ("basic arithmetic" "division"), 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 one argument, RESULT; its return value
|
|
||||||
;;;; is ignored. RESULT has one of the following forms:
|
|
||||||
;;;;
|
|
||||||
;;;; (pass TEST) - The test named TEST passed.
|
|
||||||
;;;; (fail TEST) - The test named TEST failed.
|
|
||||||
;;;; (xpass TEST) - The test named TEST passed unexpectedly.
|
|
||||||
;;;; (xfail TEST) - The test named TEST failed, as expected.
|
|
||||||
;;;; (error PREFIX) - An error occurred, with TEST as the current
|
|
||||||
;;;; test name prefix. Some tests were
|
|
||||||
;;;; probably not executed because of this.
|
|
||||||
;;;;
|
|
||||||
;;;; 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.
|
|
||||||
|
|
||||||
|
|
||||||
;;;; with-test-prefix: naming groups of tests
|
|
||||||
;;;; See the discussion of TEST
|
|
||||||
|
|
||||||
;;; A fluid containing the current test prefix, as a list.
|
|
||||||
(define prefix-fluid (make-fluid))
|
|
||||||
(fluid-set! 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)))
|
|
||||||
|
|
||||||
(define (current-test-prefix)
|
|
||||||
(fluid-ref prefix-fluid))
|
|
||||||
|
|
||||||
|
|
||||||
;;;; register-reporter, etc. --- the global reporter list
|
|
||||||
|
|
||||||
;;; 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 result)
|
|
||||||
(if (pair? reporters)
|
|
||||||
(for-each (lambda (reporter) (reporter result))
|
|
||||||
reporters)
|
|
||||||
(default-reporter result)))
|
|
||||||
|
|
||||||
|
|
||||||
;;;; Some useful reporter functions.
|
|
||||||
|
|
||||||
;;; 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 (outcome) (cons outcome 0))
|
|
||||||
'(pass fail xpass xfail error))))
|
|
||||||
(list
|
|
||||||
(lambda (result)
|
|
||||||
(let ((pair (assq (car result) counts)))
|
|
||||||
(if pair (set-cdr! pair (+ 1 (cdr pair)))
|
|
||||||
(error "count-reporter: unexpected test result: " result))))
|
|
||||||
(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
|
|
||||||
(let ((tags '(pass fail xpass xfail error))
|
|
||||||
(labels
|
|
||||||
'("passes: "
|
|
||||||
"failures: "
|
|
||||||
"unexpected passes: "
|
|
||||||
"expected failures: "
|
|
||||||
"errors: ")))
|
|
||||||
(lambda (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 label)
|
|
||||||
(let ((result (assq tag results)))
|
|
||||||
(if result
|
|
||||||
(display-line-port port label (cdr result))
|
|
||||||
(display-line-port port
|
|
||||||
"Test suite bug: "
|
|
||||||
"no total available for `" tag "'"))))
|
|
||||||
tags labels)
|
|
||||||
(newline port)))))
|
|
||||||
|
|
||||||
;;; Handy functions. Should be in a library somewhere.
|
|
||||||
(define (display-line . objs)
|
|
||||||
(for-each display objs)
|
|
||||||
(newline))
|
|
||||||
(define (display-line-port port . objs)
|
|
||||||
(for-each (lambda (obj) (display obj port))
|
|
||||||
objs)
|
|
||||||
(newline port))
|
|
||||||
|
|
||||||
;;; 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))
|
|
||||||
(if (pair? name)
|
|
||||||
(begin
|
|
||||||
(display (car name) port)
|
|
||||||
(if (pair? (cdr name))
|
|
||||||
(display ": " port))
|
|
||||||
(loop (cdr name))))))))
|
|
||||||
|
|
||||||
;;; 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 (result)
|
|
||||||
(display (car result) port)
|
|
||||||
(display ": " port)
|
|
||||||
(display (format-test-name (cadr result)) port)
|
|
||||||
(newline port)
|
|
||||||
(force-output port))))
|
|
||||||
|
|
||||||
;;; A reporter that reports all results to the user.
|
|
||||||
(define (full-reporter result)
|
|
||||||
(let ((label (case (car result)
|
|
||||||
((pass) "pass")
|
|
||||||
((fail) "FAIL")
|
|
||||||
((xpass) "XPASS")
|
|
||||||
((xfail) "xfail")
|
|
||||||
((error) "ERROR")
|
|
||||||
(else #f))))
|
|
||||||
(if label
|
|
||||||
(display-line label ": " (format-test-name (cadr result)))
|
|
||||||
(error "(test-suite lib) FULL-REPORTER: unrecognized result: "
|
|
||||||
result))))
|
|
||||||
|
|
||||||
;;; A reporter procedure which shows interesting results (failures,
|
|
||||||
;;; unexpected passes) to the user.
|
|
||||||
(define (user-reporter result)
|
|
||||||
(case (car result)
|
|
||||||
((fail xpass) (full-reporter result))))
|
|
||||||
|
|
||||||
(set! default-reporter full-reporter)
|
|
||||||
|
|
||||||
|
|
||||||
;;;; Marking independent groups of tests.
|
|
||||||
|
|
||||||
;;; When test code encounters an error (like "file not found" or "()
|
|
||||||
;;; is not a pair"), that may mean that that particular test can't
|
|
||||||
;;; continue, or that some nearby tests shouldn't be run, but it
|
|
||||||
;;; doesn't mean the whole test suite must be aborted.
|
|
||||||
;;;
|
|
||||||
;;; Wrap each group of interdependent tests in a CATCH-TEST-ERRORS
|
|
||||||
;;; form, so that if an error occurs, that group will be aborted, but
|
|
||||||
;;; control will continue after the catch-test-errors form.
|
|
||||||
|
|
||||||
;;; Evaluate thunk, catching errors. If THUNK returns without
|
|
||||||
;;; signalling any errors, return a list containing its value.
|
|
||||||
;;; Otherwise, return #f.
|
|
||||||
(define (catch-test-errors* thunk)
|
|
||||||
|
|
||||||
(letrec ((handler
|
|
||||||
(lambda (key . args)
|
|
||||||
(display-line "ERROR in test "
|
|
||||||
(format-test-name (current-test-prefix))
|
|
||||||
":")
|
|
||||||
(apply display-error
|
|
||||||
(make-stack #t handler)
|
|
||||||
(current-error-port)
|
|
||||||
args)
|
|
||||||
(throw 'catch-test-errors))))
|
|
||||||
|
|
||||||
;; I don't know if we should really catch everything here. If you
|
|
||||||
;; find a case where an error is signalled which really should abort
|
|
||||||
;; the whole test case, feel free to adjust this appropriately.
|
|
||||||
(catch 'catch-test-errors
|
|
||||||
(lambda ()
|
|
||||||
(lazy-catch #t
|
|
||||||
(lambda () (list (thunk)))
|
|
||||||
handler))
|
|
||||||
(lambda args
|
|
||||||
(report (list 'error (current-test-prefix)))
|
|
||||||
#f))))
|
|
||||||
|
|
||||||
;;; (catch-test-errors BODY ...)
|
|
||||||
;;; Evaluate the expressions BODY ... If a BODY expression signals an
|
|
||||||
;;; error, record that in the test results, and return #f. Otherwise,
|
|
||||||
;;; return a list containing the value of the last BODY expression.
|
|
||||||
(defmacro catch-test-errors body
|
|
||||||
`(catch-test-errors* (lambda () ,@body)))
|
|
||||||
|
|
||||||
|
|
||||||
;;;; Indicating tests that are expected to fail.
|
|
||||||
|
|
||||||
;;; Fluid indicating whether we're currently expecting tests to fail.
|
|
||||||
(define expected-failure-fluid (make-fluid))
|
|
||||||
|
|
||||||
;;; Hmm. The documentation treats EXPECT-FAILURE-IF as the primitive,
|
|
||||||
;;; but in the implementation, EXPECT-FAILURE-IF* is the primitive.
|
|
||||||
|
|
||||||
;;; (expect-failure-if TEST BODY ...)
|
|
||||||
;;; Evaluate the expression TEST, then evaluate BODY ...
|
|
||||||
;;; If TEST evaluates to a true value, expect all tests whose results
|
|
||||||
;;; are reported by the BODY expressions to fail.
|
|
||||||
;;; Return the value of the last BODY form.
|
|
||||||
(defmacro expect-failure-if (test . body)
|
|
||||||
`(expect-failure-if* ,test (lambda () ,@body)))
|
|
||||||
|
|
||||||
;;; Call THUNK; if SHOULD-FAIL is true, expect any tests whose results
|
|
||||||
;;; are reported by THUNK to fail. Return the value returned by THUNK.
|
|
||||||
(define (expect-failure-if* should-fail thunk)
|
|
||||||
(with-fluids ((expected-failure-fluid (not (not should-fail))))
|
|
||||||
(thunk)))
|
|
||||||
|
|
||||||
;;; (expect-failure BODY ...)
|
|
||||||
;;; Evaluate the expressions BODY ..., expecting all tests whose results
|
|
||||||
;;; they report to fail.
|
|
||||||
(defmacro expect-failure body
|
|
||||||
`(expect-failure-if #t ,@body))
|
|
||||||
|
|
||||||
(define (pessimist?)
|
|
||||||
(fluid-ref expected-failure-fluid))
|
|
||||||
|
|
||||||
|
|
||||||
;;;; Reporting passes and failures.
|
|
||||||
|
|
||||||
(define (full-name name)
|
|
||||||
(append (current-test-prefix) (list name)))
|
|
||||||
|
|
||||||
(define (pass name)
|
|
||||||
(report (list (if (pessimist?) 'xpass 'pass)
|
|
||||||
(full-name name))))
|
|
||||||
|
|
||||||
(define (fail name)
|
|
||||||
(report (list (if (pessimist?) 'xfail 'fail)
|
|
||||||
(full-name name))))
|
|
||||||
|
|
||||||
(define (pass-if name condition)
|
|
||||||
((if condition pass fail) name))
|
|
||||||
|
|
||||||
|
|
||||||
;;;; Helping test cases find their files
|
|
||||||
|
|
||||||
;;; Returns FILENAME, relative to the directory the test suite data
|
|
||||||
;;; files were installed in, and makes sure the file exists.
|
|
||||||
(define (data-file filename)
|
|
||||||
(let ((f (in-vicinity datadir filename)))
|
|
||||||
(or (file-exists? f)
|
|
||||||
(error "Test suite data file does not exist: " f))
|
|
||||||
f))
|
|
||||||
|
|
||||||
|
|
||||||
;;;; Detecting whether errors occur
|
|
||||||
|
|
||||||
;;; (signals-error? KEY BODY ...)
|
|
||||||
;;; Evaluate the expressions BODY ... . If any errors occur, return #t;
|
|
||||||
;;; otherwise, return #f.
|
|
||||||
;;;
|
|
||||||
;;; KEY indicates the sort of errors to look for; it can be a symbol,
|
|
||||||
;;; indicating that only errors with that name should be caught, or
|
|
||||||
;;; #t, meaning that any kind of error should be caught.
|
|
||||||
(defmacro signals-error? key-and-body
|
|
||||||
`(signals-error?* ,(car key-and-body)
|
|
||||||
(lambda () ,@(cdr key-and-body))))
|
|
||||||
|
|
||||||
;;; (signals-error?* KEY THUNK)
|
|
||||||
;;; Apply THUNK, catching errors. If any errors occur, return #t;
|
|
||||||
;;; otherwise, return #f.
|
|
||||||
;;;
|
|
||||||
;;; KEY indicates the sort of errors to look for; it can be a symbol,
|
|
||||||
;;; indicating that only errors with that name should be caught, or
|
|
||||||
;;; #t, meaning that any kind of error should be caught.
|
|
||||||
(define (signals-error?* key thunk)
|
|
||||||
(catch key
|
|
||||||
(lambda () (thunk) #f)
|
|
||||||
(lambda args #t)))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -1,301 +0,0 @@
|
||||||
;;;; alist.test --- tests guile's alists -*- scheme -*-
|
|
||||||
;;;; 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
|
|
||||||
;;;;
|
|
||||||
;;;; 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
|
|
||||||
(catch-test-errors
|
|
||||||
(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 "alist: acons"
|
|
||||||
(and (equal? a '((a . b) (c . d) (e . f)))
|
|
||||||
(equal? b '(("this" . "is") ("a" . "test")))))
|
|
||||||
(pass-if "alist: sloppy-assq"
|
|
||||||
(let ((x (sloppy-assq 'c a)))
|
|
||||||
(and (pair? x)
|
|
||||||
(eq? (car x) 'c)
|
|
||||||
(eq? (cdr x) 'd))))
|
|
||||||
(pass-if "alist: sloppy-assq not"
|
|
||||||
(let ((x (sloppy-assq "this" b)))
|
|
||||||
(not x)))
|
|
||||||
(pass-if "alist: sloppy-assv"
|
|
||||||
(let ((x (sloppy-assv 'c a)))
|
|
||||||
(and (pair? x)
|
|
||||||
(eq? (car x) 'c)
|
|
||||||
(eq? (cdr x) 'd))))
|
|
||||||
(pass-if "alist: sloppy-assv not"
|
|
||||||
(let ((x (sloppy-assv "this" b)))
|
|
||||||
(not x)))
|
|
||||||
(pass-if "alist: sloppy-assoc"
|
|
||||||
(let ((x (sloppy-assoc "this" b)))
|
|
||||||
(and (pair? x)
|
|
||||||
(string=? (cdr x) "is"))))
|
|
||||||
(pass-if "alist: sloppy-assoc not"
|
|
||||||
(let ((x (sloppy-assoc "heehee" b)))
|
|
||||||
(not x)))
|
|
||||||
(pass-if "alist: assq"
|
|
||||||
(let ((x (assq 'c a)))
|
|
||||||
(and (pair? x)
|
|
||||||
(eq? (car x) 'c)
|
|
||||||
(eq? (cdr x) 'd))))
|
|
||||||
(pass-if "alist: assq deformed"
|
|
||||||
(catch 'wrong-type-arg
|
|
||||||
(lambda ()
|
|
||||||
(assq 'x deformed))
|
|
||||||
(lambda (key . args)
|
|
||||||
#t)))
|
|
||||||
(pass-if-not "alist: assq not" (assq 'r a))
|
|
||||||
(pass-if "alist: assv"
|
|
||||||
(let ((x (assv 'a a)))
|
|
||||||
(and (pair? x)
|
|
||||||
(eq? (car x) 'a)
|
|
||||||
(eq? (cdr x) 'b))))
|
|
||||||
(pass-if "alist: assv deformed"
|
|
||||||
(catch 'wrong-type-arg
|
|
||||||
(lambda ()
|
|
||||||
(assv 'x deformed)
|
|
||||||
#f)
|
|
||||||
(lambda (key . args)
|
|
||||||
#t)))
|
|
||||||
(pass-if-not "alist: assv not" (assq "this" b))
|
|
||||||
|
|
||||||
(pass-if "alist: assoc"
|
|
||||||
(let ((x (assoc "this" b)))
|
|
||||||
(and (pair? x)
|
|
||||||
(string=? (car x) "this")
|
|
||||||
(string=? (cdr x) "is"))))
|
|
||||||
(pass-if "alist: assoc deformed"
|
|
||||||
(catch 'wrong-type-arg
|
|
||||||
(lambda ()
|
|
||||||
(assoc 'x deformed)
|
|
||||||
#f)
|
|
||||||
(lambda (key . args)
|
|
||||||
#t)))
|
|
||||||
(pass-if-not "alist: assoc not" (assoc "this isn't" b))))
|
|
||||||
|
|
||||||
|
|
||||||
;;; Refers
|
|
||||||
(catch-test-errors
|
|
||||||
(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 "alist: assq-ref"
|
|
||||||
(let ((x (assq-ref a 'foo)))
|
|
||||||
(and (list? x)
|
|
||||||
(eq? (car x) 'bar))))
|
|
||||||
|
|
||||||
(pass-if-not "alist: assq-ref not" (assq-ref b "one"))
|
|
||||||
(pass-if "alist: assv-ref"
|
|
||||||
(let ((x (assv-ref a 'baz)))
|
|
||||||
(and (list? x)
|
|
||||||
(eq? (car x) 'quux))))
|
|
||||||
|
|
||||||
(pass-if-not "alist: assv-ref not" (assv-ref b "one"))
|
|
||||||
|
|
||||||
(pass-if "alist: assoc-ref"
|
|
||||||
(let ((x (assoc-ref b "one")))
|
|
||||||
(and (list? x)
|
|
||||||
(eq? (car x) 2)
|
|
||||||
(eq? (cadr x) 3))))
|
|
||||||
|
|
||||||
|
|
||||||
(pass-if-not "alist: assoc-ref not" (assoc-ref a 'testing))
|
|
||||||
(expect-failure-if (not (defined? 'sloppy-assv-ref))
|
|
||||||
(pass-if "alist: assv-ref deformed"
|
|
||||||
(catch 'wrong-type-arg
|
|
||||||
(lambda ()
|
|
||||||
(assv-ref deformed 'sloppy)
|
|
||||||
#f)
|
|
||||||
(lambda (key . args)
|
|
||||||
#t)))
|
|
||||||
(pass-if "alist: assoc-ref deformed"
|
|
||||||
(catch 'wrong-type-arg
|
|
||||||
(lambda ()
|
|
||||||
(assoc-ref deformed 'sloppy)
|
|
||||||
#f)
|
|
||||||
(lambda (key . args)
|
|
||||||
#t)))
|
|
||||||
|
|
||||||
(pass-if "alist: assq-ref deformed"
|
|
||||||
(catch 'wrong-type-arg
|
|
||||||
(lambda ()
|
|
||||||
(assq-ref deformed 'sloppy)
|
|
||||||
#f)
|
|
||||||
(lambda (key . args)
|
|
||||||
#t))))))
|
|
||||||
|
|
||||||
|
|
||||||
;;; Setters
|
|
||||||
(catch-test-errors
|
|
||||||
(let ((a '((another . silly) (alist . test-case)))
|
|
||||||
(b '(("this" "one" "has") ("strings" "!")))
|
|
||||||
(deformed '(canada is a cold nation)))
|
|
||||||
(pass-if "alist: 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 "alist: 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 "alist: assv-set!"
|
|
||||||
(begin
|
|
||||||
(set! a (assv-set! a 'another 'boring))
|
|
||||||
(let ((x (safe-assv-ref a 'another)))
|
|
||||||
(and x
|
|
||||||
(eq? x 'boring)))))
|
|
||||||
(pass-if "alist: 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 "alist: 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 "alist: 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")))))
|
|
||||||
(expect-failure-if (not (defined? 'sloppy-assq-ref))
|
|
||||||
(pass-if "alist: assq-set! deformed"
|
|
||||||
(catch 'wrong-type-arg
|
|
||||||
(lambda ()
|
|
||||||
(assq-set! deformed 'cold '(very cold))
|
|
||||||
#f)
|
|
||||||
(lambda (key . args)
|
|
||||||
#t)))
|
|
||||||
(pass-if "alist: assv-set! deformed"
|
|
||||||
(catch 'wrong-type-arg
|
|
||||||
(lambda ()
|
|
||||||
(assv-set! deformed 'canada 'Canada)
|
|
||||||
#f)
|
|
||||||
(lambda (key . args)
|
|
||||||
#t)))
|
|
||||||
(pass-if "alist: assoc-set! deformed"
|
|
||||||
(catch 'wrong-type-arg
|
|
||||||
(lambda ()
|
|
||||||
(assoc-set! deformed 'canada
|
|
||||||
'(Iceland hence the name))
|
|
||||||
#f)
|
|
||||||
(lambda (key . args)
|
|
||||||
#t))))))
|
|
||||||
|
|
||||||
;;; Removers
|
|
||||||
|
|
||||||
(catch-test-errors
|
|
||||||
(let ((a '((a b) (c d) (e boring)))
|
|
||||||
(b '(("what" . "else") ("could" . "I") ("say" . "here")))
|
|
||||||
(deformed 1))
|
|
||||||
(pass-if "alist: assq-remove!"
|
|
||||||
(begin
|
|
||||||
(set! a (assq-remove! a 'a))
|
|
||||||
(equal? a '((c d) (e boring)))))
|
|
||||||
(pass-if "alist: assv-remove!"
|
|
||||||
(begin
|
|
||||||
(set! a (assv-remove! a 'c))
|
|
||||||
(equal? a '((e boring)))))
|
|
||||||
(pass-if "alist: assoc-remove!"
|
|
||||||
(begin
|
|
||||||
(set! b (assoc-remove! b "what"))
|
|
||||||
(equal? b '(("could" . "I") ("say" . "here")))))
|
|
||||||
(expect-failure-if (not (defined? 'sloppy-assq-remove!))
|
|
||||||
(pass-if "alist: assq-remove! deformed"
|
|
||||||
(catch 'wrong-type-arg
|
|
||||||
(lambda ()
|
|
||||||
(assq-remove! deformed 'puddle)
|
|
||||||
#f)
|
|
||||||
(lambda (key . args)
|
|
||||||
#t)))
|
|
||||||
(pass-if "alist: assv-remove! deformed"
|
|
||||||
(catch 'wrong-type-arg
|
|
||||||
(lambda ()
|
|
||||||
(assv-remove! deformed 'splashing)
|
|
||||||
#f)
|
|
||||||
(lambda (key . args)
|
|
||||||
#t)))
|
|
||||||
(pass-if "alist: assoc-remove! deformed"
|
|
||||||
(catch 'wrong-type-arg
|
|
||||||
(lambda ()
|
|
||||||
(assoc-remove! deformed 'fun)
|
|
||||||
#f)
|
|
||||||
(lambda (key . args)
|
|
||||||
#t))))))
|
|
||||||
|
|
@ -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)))
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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.
|
|
||||||
|
|
@ -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;
|
|
||||||
}
|
|
||||||
|
|
@ -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);
|
|
||||||
}
|
|
||||||
|
|
@ -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 */
|
|
||||||
|
|
@ -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))))
|
|
||||||
|
|
||||||
|
|
@ -1,65 +0,0 @@
|
||||||
;;;; guardians.test --- test suite for Guile Guardians -*- scheme -*-
|
|
||||||
;;;; Jim Blandy <jimb@red-bean.com> --- July 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
|
|
||||||
|
|
||||||
;;; 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" 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)))))
|
|
||||||
|
|
@ -1,183 +0,0 @@
|
||||||
;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*-
|
|
||||||
;;;; 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
|
|
||||||
;;;;
|
|
||||||
;;;; 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}
|
|
||||||
;;;
|
|
||||||
;;; A test suite for hooks. I maybe should've split off some of the
|
|
||||||
;;; stuff (like with alists), but this is small enough that it
|
|
||||||
;;; probably isn't worth the hassle. A little note: in some places it
|
|
||||||
;;; catches all errors when it probably shouldn't, since there's only
|
|
||||||
;;; one error we consider correct. This is mostly because the
|
|
||||||
;;; add-hook! error in released guiles isn't really accurate
|
|
||||||
;;; This should be changed once a released version returns
|
|
||||||
;;; wrong-type-arg from add-hook!
|
|
||||||
|
|
||||||
;; {Utility stuff}
|
|
||||||
;; Evaluate form inside a catch; if it throws an error, return true
|
|
||||||
;; This is good for checking that errors are not ignored
|
|
||||||
|
|
||||||
(define-macro (catch-error-returning-true error . form)
|
|
||||||
`(catch ,error (lambda () (begin ,@form #f)) (lambda (key . args) #t)))
|
|
||||||
|
|
||||||
;; Evaluate form inside a catch; if it throws an error, return false
|
|
||||||
;; Good for making sure that errors don't occur
|
|
||||||
|
|
||||||
(define-macro (catch-error-returning-false error . form)
|
|
||||||
`(catch ,error (lambda () (begin ,@form #t)) (lambda (key . args) #f)))
|
|
||||||
|
|
||||||
;; pass-if-not: syntactic sugar
|
|
||||||
|
|
||||||
(define-macro (pass-if-not string form)
|
|
||||||
`(pass-if ,string (not ,form)))
|
|
||||||
|
|
||||||
;; {The tests}
|
|
||||||
(catch-test-errors
|
|
||||||
(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"
|
|
||||||
(catch-error-returning-false
|
|
||||||
#t
|
|
||||||
(define x (make-hook 1))))
|
|
||||||
|
|
||||||
(pass-if "add-hook!"
|
|
||||||
(catch-error-returning-false
|
|
||||||
#t
|
|
||||||
(let ((x (make-hook 1)))
|
|
||||||
(add-hook! x proc1)
|
|
||||||
(add-hook! x proc2))))
|
|
||||||
|
|
||||||
(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 "illegal proc"
|
|
||||||
(catch-error-returning-true
|
|
||||||
#t
|
|
||||||
(let ((x (make-hook 1)))
|
|
||||||
(add-hook! x bad-proc))))
|
|
||||||
(pass-if "illegal hook"
|
|
||||||
(catch-error-returning-true
|
|
||||||
'wrong-type-arg
|
|
||||||
(add-hook! '(foo) proc1))))
|
|
||||||
(pass-if "run-hook"
|
|
||||||
(let ((x (make-hook 1)))
|
|
||||||
(catch-error-returning-false #t
|
|
||||||
(add-hook! x proc1)
|
|
||||||
(add-hook! x proc2)
|
|
||||||
(run-hook x 1))))
|
|
||||||
(with-test-prefix "run-hook"
|
|
||||||
(pass-if "bad hook"
|
|
||||||
(catch-error-returning-true
|
|
||||||
#t
|
|
||||||
(let ((x (cons 'a 'b)))
|
|
||||||
(run-hook x 1))))
|
|
||||||
(pass-if "too many args"
|
|
||||||
(let ((x (make-hook 1)))
|
|
||||||
(catch-error-returning-true
|
|
||||||
#t
|
|
||||||
(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!)))))
|
|
||||||
|
|
||||||
(pass-if "make-hook-with-name"
|
|
||||||
(catch-error-returning-false
|
|
||||||
#t
|
|
||||||
(let ((x (make-hook-with-name 'x 1)))
|
|
||||||
(add-hook! x proc1))))
|
|
||||||
(pass-if "make-hook-with-name: bad name"
|
|
||||||
(catch-error-returning-true
|
|
||||||
'wrong-type-arg
|
|
||||||
(define x (make-hook-with-name '(a b) 1))))
|
|
||||||
|
|
||||||
(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"
|
|
||||||
(catch-error-returning-false
|
|
||||||
#t
|
|
||||||
(let ((x (make-hook 1)))
|
|
||||||
(remove-hook! x proc1)))))
|
|
||||||
(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)))))
|
|
||||||
(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)))
|
|
||||||
(pass-if "bad hook"
|
|
||||||
(catch-error-returning-true
|
|
||||||
#t
|
|
||||||
(reset-hook! '(a b))))))))
|
|
||||||
|
|
@ -1,53 +0,0 @@
|
||||||
;;;; interp.test --- tests for bugs in the Guile interpreter -*- scheme -*-
|
|
||||||
;;;;
|
|
||||||
;;;; 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
|
|
||||||
|
|
||||||
(pass-if "Internal defines 1"
|
|
||||||
(letrec ((foo (lambda (arg)
|
|
||||||
(or arg (and (procedure? foo)
|
|
||||||
(foo 99))))))
|
|
||||||
(define bar (foo #f))
|
|
||||||
(foo #f)))
|
|
||||||
|
|
||||||
(pass-if "Internal defines 2"
|
|
||||||
(letrec ((foo 77)
|
|
||||||
(bar #f)
|
|
||||||
(retfoo (lambda () foo)))
|
|
||||||
(define baz (retfoo))
|
|
||||||
(retfoo)))
|
|
||||||
|
|
||||||
;; 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)))))))
|
|
||||||
|
|
@ -1,117 +0,0 @@
|
||||||
;;;; load.test --- test LOAD and path searching 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))
|
|
||||||
|
|
||||||
(define temp-dir (tmpnam))
|
|
||||||
|
|
||||||
(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)
|
|
||||||
|
|
||||||
(delete-tree temp-dir)
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -1,446 +0,0 @@
|
||||||
;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*-
|
|
||||||
;;;; Jim Blandy <jimb@red-bean.com> --- May 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 popen))
|
|
||||||
|
|
||||||
(define (display-line . args)
|
|
||||||
(for-each display args)
|
|
||||||
(newline))
|
|
||||||
|
|
||||||
(define (test-file)
|
|
||||||
(tmpnam))
|
|
||||||
|
|
||||||
|
|
||||||
;;;; 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.
|
|
||||||
(catch-test-errors
|
|
||||||
(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.
|
|
||||||
(catch-test-errors
|
|
||||||
(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.
|
|
||||||
(catch-test-errors
|
|
||||||
(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))
|
|
||||||
(delete-file filename)))
|
|
||||||
|
|
||||||
;;; Unbuffered input/output port with seeking.
|
|
||||||
(catch-test-errors
|
|
||||||
(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))
|
|
||||||
(delete-file filename)))
|
|
||||||
|
|
||||||
;;; Buffered output-only and input-only ports with seeking.
|
|
||||||
(catch-test-errors
|
|
||||||
(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.
|
|
||||||
(catch-test-errors
|
|
||||||
(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))))
|
|
||||||
(delete-file filename)))
|
|
||||||
|
|
||||||
;;; line buffering mode.
|
|
||||||
(catch-test-errors
|
|
||||||
(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.
|
|
||||||
(catch-test-errors
|
|
||||||
(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 error.
|
|
||||||
(catch-test-errors
|
|
||||||
(let* ((p (pipe))
|
|
||||||
(r (car p)))
|
|
||||||
(fcntl r F_SETFL O_NONBLOCK)
|
|
||||||
(pass-if "non-blocking-I/O"
|
|
||||||
(catch 'system-error
|
|
||||||
(lambda () (read-char r) #f)
|
|
||||||
(lambda (key . args)
|
|
||||||
(and (eq? key 'system-error)
|
|
||||||
(= (car (list-ref args 3)) EAGAIN)))))))
|
|
||||||
|
|
||||||
|
|
||||||
;;;; Pipe (popen) ports.
|
|
||||||
|
|
||||||
;;; Run a command, and read its output.
|
|
||||||
(catch-test-errors
|
|
||||||
(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.
|
|
||||||
(catch-test-errors
|
|
||||||
(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.
|
|
||||||
(catch-test-errors
|
|
||||||
(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.
|
|
||||||
(catch-test-errors
|
|
||||||
(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.
|
|
||||||
(catch-test-errors
|
|
||||||
(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.
|
|
||||||
(catch-test-errors
|
|
||||||
(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))))
|
|
||||||
|
|
||||||
(catch-test-errors
|
|
||||||
(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)))
|
|
||||||
|
|
||||||
(catch-test-errors
|
|
||||||
(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))))
|
|
||||||
|
|
||||||
|
|
||||||
;;;; 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 name
|
|
||||||
(signals-error? 'wrong-type-arg (procedure))))))
|
|
||||||
(list read read-char read-line)
|
|
||||||
'("read" "read-char" "read-line")))
|
|
||||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,25 +0,0 @@
|
||||||
;;;; reader.test --- test the Guile parser -*- scheme -*-
|
|
||||||
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
|
|
||||||
|
|
||||||
(define (try-to-read string)
|
|
||||||
(pass-if (call-with-output-string (lambda (port)
|
|
||||||
(display "Try to read " port)
|
|
||||||
(write string port)))
|
|
||||||
(not (signals-error?
|
|
||||||
'signal
|
|
||||||
(call-with-input-string string
|
|
||||||
(lambda (p) (read p)))))))
|
|
||||||
|
|
||||||
(try-to-read "0")
|
|
||||||
(try-to-read "1++i")
|
|
||||||
(try-to-read "1+i+i")
|
|
||||||
(try-to-read "1+e10000i")
|
|
||||||
|
|
||||||
(pass-if "radix passed to number->string can't be zero"
|
|
||||||
(signals-error?
|
|
||||||
'out-of-range
|
|
||||||
(number->string 10 0)))
|
|
||||||
(pass-if "radix passed to number->string can't be one either"
|
|
||||||
(signals-error?
|
|
||||||
'out-of-range
|
|
||||||
(number->string 10 1)))
|
|
||||||
|
|
@ -1,103 +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 "" "" "" "")
|
|
||||||
(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))
|
|
||||||
|
|
@ -1,30 +0,0 @@
|
||||||
;;;; strings.test --- test suite for Guile's string functions -*- scheme -*-
|
|
||||||
;;;; Jim Blandy <jimb@red-bean.com> --- August 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))
|
|
||||||
|
|
||||||
(pass-if "string<? respects string length"
|
|
||||||
(not (string<? "foo\0" "foo")))
|
|
||||||
(pass-if "string-ci<? respects string length"
|
|
||||||
(not (string-ci<? "foo\0" "foo")))
|
|
||||||
(pass-if "substring-move! checks start and end correctly"
|
|
||||||
(signals-error?
|
|
||||||
'out-of-range
|
|
||||||
(substring-move! "sample" 3 0 "test" 3)))
|
|
||||||
|
|
@ -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")))
|
|
||||||
|
|
@ -1,26 +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 "version reporting works"
|
|
||||||
(and (string? (major-version))
|
|
||||||
(string? (minor-version))
|
|
||||||
(string=? (version) (string-append (major-version) "." (minor-version)))))
|
|
||||||
|
|
@ -1,234 +0,0 @@
|
||||||
;;;; weaks.test --- tests guile's weaks -*- scheme -*-
|
|
||||||
;;;; 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
|
|
||||||
;;;;
|
|
||||||
;;;; 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 :)
|
|
||||||
|
|
||||||
;;; Utility stuff (maybe these should go in lib? They're pretty useful
|
|
||||||
;;; at keeping the code size down)
|
|
||||||
|
|
||||||
;; Evaluate form inside a catch; if it throws, return false
|
|
||||||
|
|
||||||
(define-macro (catch-error-returning-false error . form)
|
|
||||||
`(catch ,error (lambda () (begin ,@form #t)) (lambda (key . args) #f)))
|
|
||||||
|
|
||||||
(define-macro (catch-error-returning-true error . form)
|
|
||||||
`(catch ,error (lambda () (begin ,@form #f)) (lambda args #t)))
|
|
||||||
|
|
||||||
(define-macro (pass-if-not string form)
|
|
||||||
`(pass-if ,string (not ,form)))
|
|
||||||
|
|
||||||
;;; Creation functions
|
|
||||||
|
|
||||||
|
|
||||||
(catch-test-errors
|
|
||||||
(with-test-prefix
|
|
||||||
"weak-creation"
|
|
||||||
(with-test-prefix "make-weak-vector"
|
|
||||||
(pass-if "normal"
|
|
||||||
(catch-error-returning-false #t
|
|
||||||
(define x (make-weak-vector 10 #f))))
|
|
||||||
(pass-if "bad size"
|
|
||||||
(catch-error-returning-true
|
|
||||||
'wrong-type-arg
|
|
||||||
(define x (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 "bad-args"
|
|
||||||
(catch-error-returning-true
|
|
||||||
'wrong-type-arg
|
|
||||||
(define x (list->weak-vector 32)))))
|
|
||||||
|
|
||||||
(with-test-prefix "make-weak-key-hash-table"
|
|
||||||
(pass-if "create"
|
|
||||||
(catch-error-returning-false
|
|
||||||
#t
|
|
||||||
(define x (make-weak-key-hash-table 17))))
|
|
||||||
(pass-if "bad-args"
|
|
||||||
(catch-error-returning-true
|
|
||||||
'wrong-type-arg
|
|
||||||
(define x
|
|
||||||
(make-weak-key-hash-table '(bad arg))))))
|
|
||||||
(with-test-prefix "make-weak-value-hash-table"
|
|
||||||
(pass-if "create"
|
|
||||||
(catch-error-returning-false
|
|
||||||
#t
|
|
||||||
(define x (make-weak-value-hash-table 17))))
|
|
||||||
(pass-if "bad-args"
|
|
||||||
(catch-error-returning-true
|
|
||||||
'wrong-type-arg
|
|
||||||
(define x
|
|
||||||
(make-weak-value-hash-table '(bad arg))))))
|
|
||||||
|
|
||||||
(with-test-prefix "make-doubly-weak-hash-table"
|
|
||||||
(pass-if "create"
|
|
||||||
(catch-error-returning-false
|
|
||||||
#t
|
|
||||||
(define x (make-doubly-weak-hash-table 17))))
|
|
||||||
(pass-if "bad-args"
|
|
||||||
(catch-error-returning-true
|
|
||||||
'wrong-type-arg
|
|
||||||
(define x
|
|
||||||
(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
|
|
||||||
(catch-test-errors
|
|
||||||
(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))))))))
|
|
||||||
|
|
||||||
(catch-test-errors
|
|
||||||
(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))))
|
|
||||||
(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))))
|
|
||||||
|
|
||||||
(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))))
|
|
||||||
(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)))))))
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue