diff options
| author | cvs2svn <admin@example.com> | 2000-01-17 19:45:52 +0000 |
|---|---|---|
| committer | cvs2svn <admin@example.com> | 2000-01-17 19:45:52 +0000 |
| commit | e5df49234e169f7a96d42dc6f3853173f4d64bb8 (patch) | |
| tree | a30be6177cbb624f7fdd00454f470be089f56fc3 | |
| parent | fcb1720f878502b9f46eaddf2077838bcdf101d7 (diff) | |
| download | guile-mdj-pre-ansi-string.tar.gz | |
This commit was manufactured by cvs2svn to create tagmdj-pre-ansi-string
'mdj-pre-ansi-string'.
30 files changed, 0 insertions, 4169 deletions
diff --git a/libguile/Makefile.in b/libguile/Makefile.in deleted file mode 100644 index e69de29bb..000000000 --- a/libguile/Makefile.in +++ /dev/null diff --git a/test-suite/.cvsignore b/test-suite/.cvsignore deleted file mode 100644 index bd48d648f..000000000 --- a/test-suite/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -guile.log diff --git a/test-suite/COPYING b/test-suite/COPYING deleted file mode 100644 index eeb586b39..000000000 --- a/test-suite/COPYING +++ /dev/null @@ -1,340 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991 Free Software Foundation, Inc. - 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - <one line to give the program's name and a brief idea of what it does.> - Copyright (C) 19yy <name of author> - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) 19yy name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - <signature of Ty Coon>, 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog deleted file mode 100644 index e07265386..000000000 --- a/test-suite/ChangeLog +++ /dev/null @@ -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. - diff --git a/test-suite/README b/test-suite/README deleted file mode 100644 index 3ec7f3617..000000000 --- a/test-suite/README +++ /dev/null @@ -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. diff --git a/test-suite/guile-test b/test-suite/guile-test deleted file mode 100755 index f46bcae62..000000000 --- a/test-suite/guile-test +++ /dev/null @@ -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: diff --git a/test-suite/lib.scm b/test-suite/lib.scm deleted file mode 100644 index aab9fa62b..000000000 --- a/test-suite/lib.scm +++ /dev/null @@ -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))) - - diff --git a/test-suite/paths.scm b/test-suite/paths.scm deleted file mode 100644 index e69de29bb..000000000 --- a/test-suite/paths.scm +++ /dev/null diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test deleted file mode 100644 index d021717c9..000000000 --- a/test-suite/tests/alist.test +++ /dev/null @@ -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)))))) diff --git a/test-suite/tests/c-api.test b/test-suite/tests/c-api.test deleted file mode 100644 index 97146ea8a..000000000 --- a/test-suite/tests/c-api.test +++ /dev/null @@ -1,46 +0,0 @@ -;;;; c-api.test --- complementary test suite for the c-api -*- scheme -*- -;;;; MDJ 990915 <djurfeldt@nada.kth.se> -;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(define srcdir (cdr (assq 'srcdir %guile-build-info))) - -(define (egrep string filename) - (zero? (system (string-append "egrep '" string "' " filename " >/dev/null")))) - -(define (seek-offset-test dirname) - (let ((dir (opendir dirname))) - (do ((filename (readdir dir) (readdir dir))) - ((eof-object? filename)) - (if (and - (eqv? (string-ref filename (- (string-length filename) 1)) #\c) - (eqv? (string-ref filename (- (string-length filename) 2)) #\.)) - (let ((file (string-append dirname "/" filename))) - (if (and (file-exists? file) - (egrep "SEEK_(SET|CUR|END)" file) - (not (egrep "unistd.h" file))) - (fail file))))))) - -;;; A rough conservative test to check that all source files -;;; which use SEEK_SET, SEEK_CUR, and SEEK_END include unistd.h. -;;; -;;; If this test start to trigger without reason, we just modify it -;;; to be more precise. -(with-test-prefix "SEEK_XXX => #include <unistd.h>" - (if (file-exists? srcdir) - (seek-offset-test srcdir))) diff --git a/test-suite/tests/c-api/Makefile b/test-suite/tests/c-api/Makefile deleted file mode 100644 index 44488af50..000000000 --- a/test-suite/tests/c-api/Makefile +++ /dev/null @@ -1,16 +0,0 @@ -CC = gcc -CFLAGS = -g `guile-config compile` - -all: strings - -strings: strings.o testlib.o - ${CC} ${CFLAGS} ${LDFLAGS} -o strings strings.o testlib.o \ - `guile-config link` - -strings.o: strings.c testlib.h -testlib.o: testlib.c testlib.h - - -clean: - rm -f strings - rm -f *.o diff --git a/test-suite/tests/c-api/README b/test-suite/tests/c-api/README deleted file mode 100644 index f041346ad..000000000 --- a/test-suite/tests/c-api/README +++ /dev/null @@ -1,7 +0,0 @@ -This directory contains tests for Guile's C API. At the moment, the -test suite doesn't have any way to run these automatically --- we need -to 1) figure out how to run the compiler, and 2) figure out how to -integrate results from C tests into the test suite statistics. - -Nonetheless, it's better to have this code accumulating here than -someplace else where nobody can find it. diff --git a/test-suite/tests/c-api/strings.c b/test-suite/tests/c-api/strings.c deleted file mode 100644 index 13cfcf0ef..000000000 --- a/test-suite/tests/c-api/strings.c +++ /dev/null @@ -1,70 +0,0 @@ -/* strings.c --- test the Guile C API's string handling functions - Jim Blandy <jimb@red-bean.com> --- August 1999 */ - -#include <guile/gh.h> - -#include "testlib.h" - -static int -string_equal (SCM str, char *lit) -{ - int len = strlen (lit); - - return (SCM_LENGTH (str) == len - && ! memcmp (SCM_ROCHARS (str), lit, len)); -} - -void -test_gh_set_substr () -{ - test_context_t cx = test_enter_context ("gh_set_substr"); - SCM string; - - string = gh_str02scm ("Free, darnit!"); - test_pass_if ("make a string", gh_string_p (string)); - - gh_set_substr ("dammit", string, 6, 6); - test_pass_if ("gh_set_substr from literal", - string_equal (string, "Free, dammit!")); - - /* Make sure that we can use the string itself as a source. - - I guess this behavior isn't really visible, since the GH API - doesn't provide any direct access to the string contents. But I - think it should, eventually. You can't write efficient string - code if you have to copy the string just to look at it. */ - - /* Copy a substring to an overlapping region to its right. */ - gh_set_substr (SCM_CHARS (string), string, 4, 6); - test_pass_if ("gh_set_substr shifting right", - string_equal (string, "FreeFree, it!")); - - string = gh_str02scm ("Free, darnit!"); - test_pass_if ("make another string", gh_string_p (string)); - - /* Copy a substring to an overlapping region to its left. */ - gh_set_substr (SCM_CHARS (string) + 6, string, 2, 6); - test_pass_if ("gh_set_substr shifting right", - string_equal (string, "Frdarnitrnit!")); - - test_restore_context (cx); -} - -void -main_prog (int argc, char *argv[]) -{ - test_context_t strings = test_enter_context ("strings.c"); - - test_gh_set_substr (); - - test_restore_context (strings); - - exit (test_summarize ()); -} - -int -main (int argc, char *argv[]) -{ - gh_enter (argc, argv, main_prog); - return 0; -} diff --git a/test-suite/tests/c-api/testlib.c b/test-suite/tests/c-api/testlib.c deleted file mode 100644 index 21fff2492..000000000 --- a/test-suite/tests/c-api/testlib.c +++ /dev/null @@ -1,121 +0,0 @@ -/* testlib.c --- reporting test results - Jim Blandy <jimb@red-bean.com> --- August 1999 */ - -#include <stdlib.h> -#include <stdio.h> - -#include "testlib.h" - - - -/* Dying. */ - -static void -fatal (char *message) -{ - fprintf (stderr, "%s\n", message); - exit (1); -} - - -/* Contexts. */ - -/* If it gets deeper than this, that's probably an error, right? */ -#define MAX_NESTING 10 - -int depth = 0; -char *context_name_stack[MAX_NESTING]; -int marker; -int context_marker_stack[MAX_NESTING]; - -test_context_t -test_enter_context (char *name) -{ - if (depth >= MAX_NESTING) - fatal ("test contexts nested too deeply"); - - /* Generate a unique marker value for this context. */ - marker++; - - context_name_stack[depth] = name; - context_marker_stack[depth] = marker; - - depth++; - - return marker; -} - -void -test_restore_context (test_context_t context) -{ - if (depth <= 0) - fatal ("attempt to leave outermost context"); - - depth--; - - /* Make sure that we're exiting the same context we last entered. */ - if (context_marker_stack[depth] != context) - fatal ("contexts not nested properly"); -} - - -/* Reporting results. */ - -int count_passes, count_fails; - -static void -print_test_name (char *name) -{ - int i; - - for (i = 0; i < depth; i++) - printf ("%s: ", context_name_stack[i]); - - printf ("%s", name); -} - -static void -print_result (char *result, char *name) -{ - printf ("%s: ", result); - print_test_name (name); - putchar ('\n'); -} - -void -test_pass (char *name) -{ - print_result ("PASS", name); - count_passes++; -} - -void -test_fail (char *name) -{ - print_result ("FAIL", name); - count_fails++; -} - -void -test_pass_if (char *name, int condition) -{ - (condition ? test_pass : test_fail) (name); -} - - -/* Printing a summary. */ - -/* Print a summary of the reported test results. Return zero if - no failures occurred, one otherwise. */ - -int -test_summarize () -{ - putchar ('\n'); - - printf ("passes: %d\n", count_passes); - printf ("failures: %d\n", count_fails); - printf ("total tests: %d\n", count_passes + count_fails); - - return (count_fails != 0); -} diff --git a/test-suite/tests/c-api/testlib.h b/test-suite/tests/c-api/testlib.h deleted file mode 100644 index 3adaf7fc2..000000000 --- a/test-suite/tests/c-api/testlib.h +++ /dev/null @@ -1,28 +0,0 @@ -/* testlib.h --- reporting test results - Jim Blandy <jimb@red-bean.com> --- August 1999 */ - -#ifndef TESTLIB_H -#define TESTLIB_H - -extern void test_pass (char *name); -extern void test_fail (char *name); -extern void test_pass_if (char *name, int condition); - -/* We need a way to keep track of what groups of tests we're currently - within. A call to test_enter_context assures that future tests - will be reported with a name prefixed by NAME, until we call - test_restore_context with the value it returned. - - Calls to test_enter_context and test_restore_context should be - properly nested; passing the context around allows them to detect - mismatches. - - It is the caller's responsibility to free NAME after exiting the - context. (This is trivial if you're passing string literals to - test_enter_context.) */ - -typedef int test_context_t; -extern test_context_t test_enter_context (char *name); -extern void test_restore_context (test_context_t context); - -#endif /* TESTLIB_H */ diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test deleted file mode 100644 index de75d85eb..000000000 --- a/test-suite/tests/chars.test +++ /dev/null @@ -1,31 +0,0 @@ -;;;; chars.test --- test suite for Guile's char functions -*- scheme -*- -;;;; Greg J. Badros <gjb@cs.washington.edu> -;;;; -;;;; Copyright (C) 2000 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - - -(use-modules (test-suite lib)) - -(pass-if "char-is-both? works" - (and - (not (char-is-both? #\?)) - (not (char-is-both? #\newline)) - (char-is-both? #\a) - (char-is-both? #\Z) - (not (char-is-both? #\1)))) - diff --git a/test-suite/tests/guardians.test b/test-suite/tests/guardians.test deleted file mode 100644 index 4d8eac678..000000000 --- a/test-suite/tests/guardians.test +++ /dev/null @@ -1,65 +0,0 @@ -;;;; guardians.test --- test suite for Guile Guardians -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- July 1999 -;;;; -;;;; Copyright (C) 1999 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))))) diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test deleted file mode 100644 index 5d328b422..000000000 --- a/test-suite/tests/hooks.test +++ /dev/null @@ -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)))))))) diff --git a/test-suite/tests/interp.test b/test-suite/tests/interp.test deleted file mode 100644 index fb6e4d6f0..000000000 --- a/test-suite/tests/interp.test +++ /dev/null @@ -1,53 +0,0 @@ -;;;; interp.test --- tests for bugs in the Guile interpreter -*- scheme -*- -;;;; -;;;; Copyright (C) 1999 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))))))) diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test deleted file mode 100644 index 485766ebd..000000000 --- a/test-suite/tests/load.test +++ /dev/null @@ -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) diff --git a/test-suite/tests/mambo.test b/test-suite/tests/mambo.test deleted file mode 100644 index e69de29bb..000000000 --- a/test-suite/tests/mambo.test +++ /dev/null diff --git a/test-suite/tests/multilingual.nottest b/test-suite/tests/multilingual.nottest deleted file mode 100644 index 468acd924..000000000 --- a/test-suite/tests/multilingual.nottest +++ /dev/null @@ -1,81 +0,0 @@ -;;;; multilingual.nottest --- tests of multilingual support -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 -;;;; This isn't a test yet, because we don't have multilingual support yet. -;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (test-suite lib)) - - -;;; Tests of Emacs 20.4 character encoding. - -;;; Check that characters are being encoded correctly. - -;;; These tests are specific to the Emacs 20.4 encoding; they'll need -;;; to be replaced when Guile switches to UTF-8. See mb.c for a -;;; description of this encoding. - -(define (check-encoding char-number encoding) - (let ((singleton (string (integer->char char-number)))) - (pass-if (string-append "encoding character " - (number->string char-number)) - (equal? (string->bytes singleton) encoding)) - (pass-if (string-append "decoding character " - (number->string char-number)) - (catch #t - (lambda () - (equal? (bytes->string encoding) singleton)) - (lambda dummy #f))))) - - -;; Check some ASCII characters. -(check-encoding 0 #y(0)) -(check-encoding 127 #y(127)) -(check-encoding 31 #y(31)) -(check-encoding 32 #y(32)) -(check-encoding 42 #y(42)) - -;;; Sometimes we mark something as an "end of range", when it's not -;;; actually the last character that would use that encoding form. -;;; This is because not all character set numbers are assigned, and we -;;; can't use unassigned character set numbers. So the value given is -;;; the last value which actually corresponds to something in a real -;;; character set. - -;; Check some characters encoded in two bytes. -(check-encoding 2208 #y(#x81 #xA0)) ; beginning of range -(check-encoding 3839 #y(#x8d #xFF)) ; end of range -(check-encoding 2273 #y(#x81 #xE1)) - -;; Check some big characters encoded in three bytes. -(check-encoding 20512 #y(#x90 #xA0 #xA0)) ; beginning of range -(check-encoding 180223 #y(#x99 #xFF #xFF)) ; end of range -(check-encoding 53931 #y(#x92 #xA5 #xAB)) - -;; Check some small characters encoded in three bytes --- some from -;; the #x9A prefix range, and some from the #x9B prefix range. -(check-encoding 6176 #y(#x9A #xA0 #xA0)) ; start of the #9A prefix range -(check-encoding 7167 #y(#x9A #xA7 #xFF)) ; end of the #9A prefix range -(check-encoding 14368 #y(#x9B #xE0 #xA0)) ; start of the #9B prefix range -(check-encoding 14591 #y(#x9B #xE1 #xFF)) ; end of the #9B prefix range - -;; Check some characters encoded in four bytes. -(check-encoding 266272 #y(#x9C #xF0 #xA0 #xA0)) ; start of the #9C prefix range -(check-encoding 294911 #y(#x9C #xF1 #xFF #xFF)) ; end of the #9C prefix range -(check-encoding 348192 #y(#x9D #xF5 #xA0 #xA0)) ; start of the #9D prefix range -(check-encoding 475135 #y(#x9D #xFC #xFF #xFF)) ; start of the #9D prefix range diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test deleted file mode 100644 index 5c508a9ab..000000000 --- a/test-suite/tests/ports.test +++ /dev/null @@ -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"))) diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test deleted file mode 100644 index c915b515c..000000000 --- a/test-suite/tests/r4rs.test +++ /dev/null @@ -1,1014 +0,0 @@ -;;;; r4rs.test --- tests for R4RS compliance -*- scheme -*- -;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 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. - - -;;;; ============= NOTE ============= - -;;;; This file is a quick-and-dirty adaptation of Aubrey's test suite -;;;; to Guile's testing framework. As such, it's not as clean as one -;;;; might hope. (In particular, it uses with-test-prefix oddly.) -;;;; -;;;; If you're looking for an example of a test suite to imitate, you -;;;; might do better by looking at ports.test, which uses the -;;;; (test-suite lib) functions much more idiomatically. - - -;;;; "test.scm" Test correctness of scheme implementations. -;;;; Author: Aubrey Jaffer -;;;; Modified: Mikael Djurfeldt -;;;; Removed tests which Guile deliberately -;;;; won't pass. Made the the tests (test-cont), (test-sc4), and -;;;; (test-delay) start to run automatically. -;;;; Modified: Jim Blandy -;;;; adapted to new Guile test suite framework - -;;; This includes examples from -;;; William Clinger and Jonathan Rees, editors. -;;; Revised^4 Report on the Algorithmic Language Scheme -;;; and the IEEE specification. - -;;; The input tests read this file expecting it to be named -;;; "test.scm", so you'll have to run it from the ice-9 source -;;; directory, or copy this file elsewhere -;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running -;;; these tests. You may need to delete them in order to run -;;; "test.scm" more than once. - -;;; There are three optional tests: -;;; (TEST-CONT) tests multiple returns from call-with-current-continuation -;;; -;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE -;;; -;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by -;;; either standard. - -;;; If you are testing a R3RS version which does not have `list?' do: -;;; (define list? #f) - -;;; send corrections or additions to jaffer@ai.mit.edu or -;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA - -(define cur-section '())(define errs '()) -(define SECTION (lambda args - (set! cur-section args) #t)) -(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) -(define (report-errs) #f) - -(define test - (lambda (expect fun . args) - (let ((res (if (procedure? fun) (apply fun args) (car args)))) - (with-test-prefix cur-section - (pass-if (call-with-output-string (lambda (port) - (write (cons fun args) port))) - (equal? expect res)))))) - -;; test that all symbol characters are supported. -(SECTION 2 1) -'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.) - -(SECTION 3 4) -(define disjoint-type-functions - (list boolean? char? null? number? pair? procedure? string? symbol? vector?)) -(define type-examples - (list - #t #f #\a '() 9739 '(test) (lambda () #f) car "test" "" 'test - '#() '#(a b c))) -(define type-matrix - (map (lambda (x) - (let ((t (map (lambda (f) (f x)) disjoint-type-functions))) - t)) - type-examples)) -(for-each (lambda (object row) - (let ((count (apply + (map (lambda (elt) (if elt 1 0)) - row)))) - (pass-if (call-with-output-string - (lambda (port) - (display "object recognized by only one predicate: " - port) - (display object port))) - (= count 1)))) - type-examples - type-matrix) - -(SECTION 4 1 2) -(test '(quote a) 'quote (quote 'a)) -(test '(quote a) 'quote ''a) -(SECTION 4 1 3) -(test 12 (if #f + *) 3 4) -(SECTION 4 1 4) -(test 8 (lambda (x) (+ x x)) 4) -(define reverse-subtract - (lambda (x y) (- y x))) -(test 3 reverse-subtract 7 10) -(define add4 - (let ((x 4)) - (lambda (y) (+ x y)))) -(test 10 add4 6) -(test '(3 4 5 6) (lambda x x) 3 4 5 6) -(test '(5 6) (lambda (x y . z) z) 3 4 5 6) -(SECTION 4 1 5) -(test 'yes 'if (if (> 3 2) 'yes 'no)) -(test 'no 'if (if (> 2 3) 'yes 'no)) -(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2))) -(SECTION 4 1 6) -(define x 2) -(test 3 'define (+ x 1)) -(set! x 4) -(test 5 'set! (+ x 1)) -(SECTION 4 2 1) -(test 'greater 'cond (cond ((> 3 2) 'greater) - ((< 3 2) 'less))) -(test 'equal 'cond (cond ((> 3 3) 'greater) - ((< 3 3) 'less) - (else 'equal))) -(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr) - (else #f))) -(test 'composite 'case (case (* 2 3) - ((2 3 5 7) 'prime) - ((1 4 6 8 9) 'composite))) -(test 'consonant 'case (case (car '(c d)) - ((a e i o u) 'vowel) - ((w y) 'semivowel) - (else 'consonant))) -(test #t 'and (and (= 2 2) (> 2 1))) -(test #f 'and (and (= 2 2) (< 2 1))) -(test '(f g) 'and (and 1 2 'c '(f g))) -(test #t 'and (and)) -(test #t 'or (or (= 2 2) (> 2 1))) -(test #t 'or (or (= 2 2) (< 2 1))) -(test #f 'or (or #f #f #f)) -(test #f 'or (or)) -(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0))) -(SECTION 4 2 2) -(test 6 'let (let ((x 2) (y 3)) (* x y))) -(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) -(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) -(test #t 'letrec (letrec ((even? - (lambda (n) (if (zero? n) #t (odd? (- n 1))))) - (odd? - (lambda (n) (if (zero? n) #f (even? (- n 1)))))) - (even? 88))) -(define x 34) -(test 5 'let (let ((x 3)) (define x 5) x)) -(test 34 'let x) -(test 6 'let (let () (define x 6) x)) -(test 34 'let x) -(test 7 'let* (let* ((x 3)) (define x 7) x)) -(test 34 'let* x) -(test 8 'let* (let* () (define x 8) x)) -(test 34 'let* x) -(test 9 'letrec (letrec () (define x 9) x)) -(test 34 'letrec x) -(test 10 'letrec (letrec ((x 3)) (define x 10) x)) -(test 34 'letrec x) -(SECTION 4 2 3) -(define x 0) -(test 6 'begin (begin (set! x 5) (+ x 1))) -(SECTION 4 2 4) -(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5)) - (i 0 (+ i 1))) - ((= i 5) vec) - (vector-set! vec i i))) -(test 25 'do (let ((x '(1 3 5 7 9))) - (do ((x x (cdr x)) - (sum 0 (+ sum (car x)))) - ((null? x) sum)))) -(test 1 'let (let foo () 1)) -(test '((6 1 3) (-5 -2)) 'let - (let loop ((numbers '(3 -2 1 6 -5)) - (nonneg '()) - (neg '())) - (cond ((null? numbers) (list nonneg neg)) - ((negative? (car numbers)) - (loop (cdr numbers) - nonneg - (cons (car numbers) neg))) - (else - (loop (cdr numbers) - (cons (car numbers) nonneg) - neg))))) -(SECTION 4 2 6) -(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) -(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) -(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) -(test '((foo 7) . cons) - 'quasiquote - `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) - -;;; sqt is defined here because not all implementations are required to -;;; support it. -(define (sqt x) - (do ((i 0 (+ i 1))) - ((> (* i i) x) (- i 1)))) - -(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8)) -(test 5 'quasiquote `,(+ 2 3)) -(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) - 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) -(test '(a `(b ,x ,'y d) e) 'quasiquote - (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e))) -(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) -(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4))) -(SECTION 5 2 1) -(define add3 (lambda (x) (+ x 3))) -(test 6 'define (add3 3)) -(define first car) -(test 1 'define (first '(1 2))) -(SECTION 5 2 2) -(test 45 'define - (let ((x 5)) - (define foo (lambda (y) (bar x y))) - (define bar (lambda (a b) (+ (* a b) a))) - (foo (+ x 3)))) -(define x 34) -(define (foo) (define x 5) x) -(test 5 foo) -(test 34 'define x) -(define foo (lambda () (define x 5) x)) -(test 5 foo) -(test 34 'define x) -(define (foo x) ((lambda () (define x 5) x)) x) -(test 88 foo 88) -(test 4 foo 4) -(test 34 'define x) -(SECTION 6 1) -(test #f not #t) -(test #f not 3) -(test #f not (list 3)) -(test #t not #f) -(test #f not '()) -(test #f not (list)) -(test #f not 'nil) - -(test #t boolean? #f) -(test #f boolean? 0) -(test #f boolean? '()) -(SECTION 6 2) -(test #t eqv? 'a 'a) -(test #f eqv? 'a 'b) -(test #t eqv? 2 2) -(test #t eqv? '() '()) -(test #t eqv? '10000 '10000) -(test #f eqv? (cons 1 2)(cons 1 2)) -(test #f eqv? (lambda () 1) (lambda () 2)) -(test #f eqv? #f 'nil) -(let ((p (lambda (x) x))) - (test #t eqv? p p)) -(define gen-counter - (lambda () - (let ((n 0)) - (lambda () (set! n (+ n 1)) n)))) -(let ((g (gen-counter))) (test #t eqv? g g)) -(test #f eqv? (gen-counter) (gen-counter)) -(letrec ((f (lambda () (if (eqv? f g) 'f 'both))) - (g (lambda () (if (eqv? f g) 'g 'both)))) - (test #f eqv? f g)) - -(test #t eq? 'a 'a) -(test #f eq? (list 'a) (list 'a)) -(test #t eq? '() '()) -(test #t eq? car car) -(let ((x '(a))) (test #t eq? x x)) -(let ((x '#())) (test #t eq? x x)) -(let ((x (lambda (x) x))) (test #t eq? x x)) - -(test #t equal? 'a 'a) -(test #t equal? '(a) '(a)) -(test #t equal? '(a (b) c) '(a (b) c)) -(test #t equal? "abc" "abc") -(test #t equal? 2 2) -(test #t equal? (make-vector 5 'a) (make-vector 5 'a)) -(SECTION 6 3) -(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ())))))) -(define x (list 'a 'b 'c)) -(define y x) -(and list? (test #t list? y)) -(set-cdr! x 4) -(test '(a . 4) 'set-cdr! x) -(test #t eqv? x y) -(test '(a b c . d) 'dot '(a . (b . (c . d)))) -(and list? (test #f list? y)) -(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x)))) - -(test #t pair? '(a . b)) -(test #t pair? '(a . 1)) -(test #t pair? '(a b c)) -(test #f pair? '()) -(test #f pair? '#(a b)) - -(test '(a) cons 'a '()) -(test '((a) b c d) cons '(a) '(b c d)) -(test '("a" b c) cons "a" '(b c)) -(test '(a . 3) cons 'a 3) -(test '((a b) . c) cons '(a b) 'c) - -(test 'a car '(a b c)) -(test '(a) car '((a) b c d)) -(test 1 car '(1 . 2)) - -(test '(b c d) cdr '((a) b c d)) -(test 2 cdr '(1 . 2)) - -(test '(a 7 c) list 'a (+ 3 4) 'c) -(test '() list) - -(test 3 length '(a b c)) -(test 3 length '(a (b) (c d e))) -(test 0 length '()) - -(test '(x y) append '(x) '(y)) -(test '(a b c d) append '(a) '(b c d)) -(test '(a (b) (c)) append '(a (b)) '((c))) -(test '() append) -(test '(a b c . d) append '(a b) '(c . d)) -(test 'a append '() 'a) - -(test '(c b a) reverse '(a b c)) -(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f)))) - -(test 'c list-ref '(a b c d) 2) - -(test '(a b c) memq 'a '(a b c)) -(test '(b c) memq 'b '(a b c)) -(test '#f memq 'a '(b c d)) -(test '#f memq (list 'a) '(b (a) c)) -(test '((a) c) member (list 'a) '(b (a) c)) -(test '(101 102) memv 101 '(100 101 102)) - -(define e '((a 1) (b 2) (c 3))) -(test '(a 1) assq 'a e) -(test '(b 2) assq 'b e) -(test #f assq 'd e) -(test #f assq (list 'a) '(((a)) ((b)) ((c)))) -(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c)))) -(test '(5 7) assv 5 '((2 3) (5 7) (11 13))) -(SECTION 6 4) -(test #t symbol? 'foo) -(test #t symbol? (car '(a b))) -(test #f symbol? "bar") -(test #t symbol? 'nil) -(test #f symbol? '()) -(test #f symbol? #f) -;;; But first, what case are symbols in? Determine the standard case: -(define char-standard-case char-upcase) -(if (string=? (symbol->string 'A) "a") - (set! char-standard-case char-downcase)) -;;; Not for Guile -;(test #t 'standard-case -; (string=? (symbol->string 'a) (symbol->string 'A))) -;(test #t 'standard-case -; (or (string=? (symbol->string 'a) "A") -; (string=? (symbol->string 'A) "a"))) -(define (str-copy s) - (let ((v (make-string (string-length s)))) - (do ((i (- (string-length v) 1) (- i 1))) - ((< i 0) v) - (string-set! v i (string-ref s i))))) -(define (string-standard-case s) - (set! s (str-copy s)) - (do ((i 0 (+ 1 i)) - (sl (string-length s))) - ((>= i sl) s) - (string-set! s i (char-standard-case (string-ref s i))))) -;;; Not for Guile -;(test (string-standard-case "flying-fish") symbol->string 'flying-fish) -;(test (string-standard-case "martin") symbol->string 'Martin) -(test "Malvina" symbol->string (string->symbol "Malvina")) -;;; Not for Guile -;(test #t 'standard-case (eq? 'a 'A)) - -(define x (string #\a #\b)) -(define y (string->symbol x)) -(string-set! x 0 #\c) -(test "cb" 'string-set! x) -(test "ab" symbol->string y) -(test y string->symbol "ab") - -;;; Not for Guile -;(test #t eq? 'mISSISSIppi 'mississippi) -;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt"))) -(test 'JollyWog string->symbol (symbol->string 'JollyWog)) - -(SECTION 6 5 5) -(test #t number? 3) -(test #t complex? 3) -(test #t real? 3) -(test #t rational? 3) -(test #t integer? 3) - -(test #t exact? 3) -(test #f inexact? 3) - -(test #t = 22 22 22) -(test #t = 22 22) -(test #f = 34 34 35) -(test #f = 34 35) -(test #t > 3 -6246) -(test #f > 9 9 -2424) -(test #t >= 3 -4 -6246) -(test #t >= 9 9) -(test #f >= 8 9) -(test #t < -1 2 3 4 5 6 7 8) -(test #f < -1 2 3 4 4 5 6 7) -(test #t <= -1 2 3 4 5 6 7 8) -(test #t <= -1 2 3 4 4 5 6 7) -(test #f < 1 3 2) -(test #f >= 1 3 2) - -(test #t zero? 0) -(test #f zero? 1) -(test #f zero? -1) -(test #f zero? -100) -(test #t positive? 4) -(test #f positive? -4) -(test #f positive? 0) -(test #f negative? 4) -(test #t negative? -4) -(test #f negative? 0) -(test #t odd? 3) -(test #f odd? 2) -(test #f odd? -4) -(test #t odd? -1) -(test #f even? 3) -(test #t even? 2) -(test #t even? -4) -(test #f even? -1) - -(test 38 max 34 5 7 38 6) -(test -24 min 3 5 5 330 4 -24) - -(test 7 + 3 4) -(test '3 + 3) -(test 0 +) -(test 4 * 4) -(test 1 *) - -(test -1 - 3 4) -(test -3 - 3) -(test 7 abs -7) -(test 7 abs 7) -(test 0 abs 0) - -(test 5 quotient 35 7) -(test -5 quotient -35 7) -(test -5 quotient 35 -7) -(test 5 quotient -35 -7) -(test 1 modulo 13 4) -(test 1 remainder 13 4) -(test 3 modulo -13 4) -(test -1 remainder -13 4) -(test -3 modulo 13 -4) -(test 1 remainder 13 -4) -(test -1 modulo -13 -4) -(test -1 remainder -13 -4) -(define (divtest n1 n2) - (= n1 (+ (* n2 (quotient n1 n2)) - (remainder n1 n2)))) -(test #t divtest 238 9) -(test #t divtest -238 9) -(test #t divtest 238 -9) -(test #t divtest -238 -9) - -(test 4 gcd 0 4) -(test 4 gcd -4 0) -(test 4 gcd 32 -36) -(test 0 gcd) -(test 288 lcm 32 -36) -(test 1 lcm) - -;;;;From: fred@sce.carleton.ca (Fred J Kaudel) -;;; Modified by jaffer. -(define (test-inexact) - (define f3.9 (string->number "3.9")) - (define f4.0 (string->number "4.0")) - (define f-3.25 (string->number "-3.25")) - (define f.25 (string->number ".25")) - (define f4.5 (string->number "4.5")) - (define f3.5 (string->number "3.5")) - (define f0.0 (string->number "0.0")) - (define f0.8 (string->number "0.8")) - (define f1.0 (string->number "1.0")) - (define wto write-test-obj) - (define dto display-test-obj) - (define lto load-test-obj) - (SECTION 6 5 5) - (test #t inexact? f3.9) - (test #t 'inexact? (inexact? (max f3.9 4))) - (test f4.0 'max (max f3.9 4)) - (test f4.0 'exact->inexact (exact->inexact 4)) - (test (- f4.0) round (- f4.5)) - (test (- f4.0) round (- f3.5)) - (test (- f4.0) round (- f3.9)) - (test f0.0 round f0.0) - (test f0.0 round f.25) - (test f1.0 round f0.8) - (test f4.0 round f3.5) - (test f4.0 round f4.5) - (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. - (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13) - (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) - (test #t call-with-output-file - "tmp3" - (lambda (test-file) - (write-char #\; test-file) - (display write-test-obj test-file) - (newline test-file) - (write load-test-obj test-file) - (output-port? test-file))) - (check-test-file "tmp3") - (set! write-test-obj wto) - (set! display-test-obj dto) - (set! load-test-obj lto) - (let ((x (string->number "4195835.0")) - (y (string->number "3145727.0"))) - (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y))))) - (report-errs)) - -(define (test-bignum) - (define tb - (lambda (n1 n2) - (= n1 (+ (* n2 (quotient n1 n2)) - (remainder n1 n2))))) - (SECTION 6 5 5) - (test 0 modulo -2177452800 86400) - (test 0 modulo 2177452800 -86400) - (test 0 modulo 2177452800 86400) - (test 0 modulo -2177452800 -86400) - (test #t 'remainder (tb 281474976710655 65535)) - (test #t 'remainder (tb 281474976710654 65535)) - (SECTION 6 5 6) - (test 281474976710655 string->number "281474976710655") - (test "281474976710655" number->string 281474976710655) - (report-errs)) - -(SECTION 6 5 6) -(test "0" number->string 0) -(test "100" number->string 100) -(test "100" number->string 256 16) -(test 100 string->number "100") -(test 256 string->number "100" 16) -(test #f string->number "") -(test #f string->number ".") -(test #f string->number "d") -(test #f string->number "D") -(test #f string->number "i") -(test #f string->number "I") -(test #f string->number "3i") -(test #f string->number "3I") -(test #f string->number "33i") -(test #f string->number "33I") -(test #f string->number "3.3i") -(test #f string->number "3.3I") -(test #f string->number "-") -(test #f string->number "+") - -(SECTION 6 6) -(test #t eqv? '#\ #\Space) -(test #t eqv? #\space '#\Space) -(test #t char? #\a) -(test #t char? #\() -(test #t char? #\ ) -(test #t char? '#\newline) - -(test #f char=? #\A #\B) -(test #f char=? #\a #\b) -(test #f char=? #\9 #\0) -(test #t char=? #\A #\A) - -(test #t char<? #\A #\B) -(test #t char<? #\a #\b) -(test #f char<? #\9 #\0) -(test #f char<? #\A #\A) - -(test #f char>? #\A #\B) -(test #f char>? #\a #\b) -(test #t char>? #\9 #\0) -(test #f char>? #\A #\A) - -(test #t char<=? #\A #\B) -(test #t char<=? #\a #\b) -(test #f char<=? #\9 #\0) -(test #t char<=? #\A #\A) - -(test #f char>=? #\A #\B) -(test #f char>=? #\a #\b) -(test #t char>=? #\9 #\0) -(test #t char>=? #\A #\A) - -(test #f char-ci=? #\A #\B) -(test #f char-ci=? #\a #\B) -(test #f char-ci=? #\A #\b) -(test #f char-ci=? #\a #\b) -(test #f char-ci=? #\9 #\0) -(test #t char-ci=? #\A #\A) -(test #t char-ci=? #\A #\a) - -(test #t char-ci<? #\A #\B) -(test #t char-ci<? #\a #\B) -(test #t char-ci<? #\A #\b) -(test #t char-ci<? #\a #\b) -(test #f char-ci<? #\9 #\0) -(test #f char-ci<? #\A #\A) -(test #f char-ci<? #\A #\a) - -(test #f char-ci>? #\A #\B) -(test #f char-ci>? #\a #\B) -(test #f char-ci>? #\A #\b) -(test #f char-ci>? #\a #\b) -(test #t char-ci>? #\9 #\0) -(test #f char-ci>? #\A #\A) -(test #f char-ci>? #\A #\a) - -(test #t char-ci<=? #\A #\B) -(test #t char-ci<=? #\a #\B) -(test #t char-ci<=? #\A #\b) -(test #t char-ci<=? #\a #\b) -(test #f char-ci<=? #\9 #\0) -(test #t char-ci<=? #\A #\A) -(test #t char-ci<=? #\A #\a) - -(test #f char-ci>=? #\A #\B) -(test #f char-ci>=? #\a #\B) -(test #f char-ci>=? #\A #\b) -(test #f char-ci>=? #\a #\b) -(test #t char-ci>=? #\9 #\0) -(test #t char-ci>=? #\A #\A) -(test #t char-ci>=? #\A #\a) - -(test #t char-alphabetic? #\a) -(test #t char-alphabetic? #\A) -(test #t char-alphabetic? #\z) -(test #t char-alphabetic? #\Z) -(test #f char-alphabetic? #\0) -(test #f char-alphabetic? #\9) -(test #f char-alphabetic? #\space) -(test #f char-alphabetic? #\;) - -(test #f char-numeric? #\a) -(test #f char-numeric? #\A) -(test #f char-numeric? #\z) -(test #f char-numeric? #\Z) -(test #t char-numeric? #\0) -(test #t char-numeric? #\9) -(test #f char-numeric? #\space) -(test #f char-numeric? #\;) - -(test #f char-whitespace? #\a) -(test #f char-whitespace? #\A) -(test #f char-whitespace? #\z) -(test #f char-whitespace? #\Z) -(test #f char-whitespace? #\0) -(test #f char-whitespace? #\9) -(test #t char-whitespace? #\space) -(test #f char-whitespace? #\;) - -(test #f char-upper-case? #\0) -(test #f char-upper-case? #\9) -(test #f char-upper-case? #\space) -(test #f char-upper-case? #\;) - -(test #f char-lower-case? #\0) -(test #f char-lower-case? #\9) -(test #f char-lower-case? #\space) -(test #f char-lower-case? #\;) - -(test #\. integer->char (char->integer #\.)) -(test #\A integer->char (char->integer #\A)) -(test #\a integer->char (char->integer #\a)) -(test #\A char-upcase #\A) -(test #\A char-upcase #\a) -(test #\a char-downcase #\A) -(test #\a char-downcase #\a) -(SECTION 6 7) -(test #t string? "The word \"recursion\\\" has many meanings.") -(test #t string? "") -(define f (make-string 3 #\*)) -(test "?**" 'string-set! (begin (string-set! f 0 #\?) f)) -(test "abc" string #\a #\b #\c) -(test "" string) -(test 3 string-length "abc") -(test #\a string-ref "abc" 0) -(test #\c string-ref "abc" 2) -(test 0 string-length "") -(test "" substring "ab" 0 0) -(test "" substring "ab" 1 1) -(test "" substring "ab" 2 2) -(test "a" substring "ab" 0 1) -(test "b" substring "ab" 1 2) -(test "ab" substring "ab" 0 2) -(test "foobar" string-append "foo" "bar") -(test "foo" string-append "foo") -(test "foo" string-append "foo" "") -(test "foo" string-append "" "foo") -(test "" string-append) -(test "" make-string 0) -(test #t string=? "" "") -(test #f string<? "" "") -(test #f string>? "" "") -(test #t string<=? "" "") -(test #t string>=? "" "") -(test #t string-ci=? "" "") -(test #f string-ci<? "" "") -(test #f string-ci>? "" "") -(test #t string-ci<=? "" "") -(test #t string-ci>=? "" "") - -(test #f string=? "A" "B") -(test #f string=? "a" "b") -(test #f string=? "9" "0") -(test #t string=? "A" "A") - -(test #t string<? "A" "B") -(test #t string<? "a" "b") -(test #f string<? "9" "0") -(test #f string<? "A" "A") - -(test #f string>? "A" "B") -(test #f string>? "a" "b") -(test #t string>? "9" "0") -(test #f string>? "A" "A") - -(test #t string<=? "A" "B") -(test #t string<=? "a" "b") -(test #f string<=? "9" "0") -(test #t string<=? "A" "A") - -(test #f string>=? "A" "B") -(test #f string>=? "a" "b") -(test #t string>=? "9" "0") -(test #t string>=? "A" "A") - -(test #f string-ci=? "A" "B") -(test #f string-ci=? "a" "B") -(test #f string-ci=? "A" "b") -(test #f string-ci=? "a" "b") -(test #f string-ci=? "9" "0") -(test #t string-ci=? "A" "A") -(test #t string-ci=? "A" "a") - -(test #t string-ci<? "A" "B") -(test #t string-ci<? "a" "B") -(test #t string-ci<? "A" "b") -(test #t string-ci<? "a" "b") -(test #f string-ci<? "9" "0") -(test #f string-ci<? "A" "A") -(test #f string-ci<? "A" "a") - -(test #f string-ci>? "A" "B") -(test #f string-ci>? "a" "B") -(test #f string-ci>? "A" "b") -(test #f string-ci>? "a" "b") -(test #t string-ci>? "9" "0") -(test #f string-ci>? "A" "A") -(test #f string-ci>? "A" "a") - -(test #t string-ci<=? "A" "B") -(test #t string-ci<=? "a" "B") -(test #t string-ci<=? "A" "b") -(test #t string-ci<=? "a" "b") -(test #f string-ci<=? "9" "0") -(test #t string-ci<=? "A" "A") -(test #t string-ci<=? "A" "a") - -(test #f string-ci>=? "A" "B") -(test #f string-ci>=? "a" "B") -(test #f string-ci>=? "A" "b") -(test #f string-ci>=? "a" "b") -(test #t string-ci>=? "9" "0") -(test #t string-ci>=? "A" "A") -(test #t string-ci>=? "A" "a") -(SECTION 6 8) -(test #t vector? '#(0 (2 2 2 2) "Anna")) -(test #t vector? '#()) -(test '#(a b c) vector 'a 'b 'c) -(test '#() vector) -(test 3 vector-length '#(0 (2 2 2 2) "Anna")) -(test 0 vector-length '#()) -(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5) -(test '#(0 ("Sue" "Sue") "Anna") 'vector-set - (let ((vec (vector 0 '(2 2 2 2) "Anna"))) - (vector-set! vec 1 '("Sue" "Sue")) - vec)) -(test '#(hi hi) make-vector 2 'hi) -(test '#() make-vector 0) -(test '#() make-vector 0 'a) -(SECTION 6 9) -(test #t procedure? car) -(test #f procedure? 'car) -(test #t procedure? (lambda (x) (* x x))) -(test #f procedure? '(lambda (x) (* x x))) -(test #t call-with-current-continuation procedure?) -(test 7 apply + (list 3 4)) -(test 7 apply (lambda (a b) (+ a b)) (list 3 4)) -(test 17 apply + 10 (list 3 4)) -(test '() apply list '()) -(define compose (lambda (f g) (lambda args (f (apply g args))))) -(test 30 (compose sqt *) 12 75) - -(test '(b e h) map cadr '((a b) (d e) (g h))) -(test '(5 7 9) map + '(1 2 3) '(4 5 6)) -(test '#(0 1 4 9 16) 'for-each - (let ((v (make-vector 5))) - (for-each (lambda (i) (vector-set! v i (* i i))) - '(0 1 2 3 4)) - v)) -(test -3 call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) (if (negative? x) (exit x))) - '(54 0 37 -3 245 19)) - #t)) -(define list-length - (lambda (obj) - (call-with-current-continuation - (lambda (return) - (letrec ((r (lambda (obj) (cond ((null? obj) 0) - ((pair? obj) (+ (r (cdr obj)) 1)) - (else (return #f)))))) - (r obj)))))) -(test 4 list-length '(1 2 3 4)) -(test #f list-length '(a b . c)) -(test '() map cadr '()) - -;;; This tests full conformance of call-with-current-continuation. It -;;; is a separate test because some schemes do not support call/cc -;;; other than escape procedures. I am indebted to -;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this -;;; code. The function leaf-eq? compares the leaves of 2 arbitrary -;;; trees constructed of conses. -(define (next-leaf-generator obj eot) - (letrec ((return #f) - (cont (lambda (x) - (recur obj) - (set! cont (lambda (x) (return eot))) - (cont #f))) - (recur (lambda (obj) - (if (pair? obj) - (for-each recur obj) - (call-with-current-continuation - (lambda (c) - (set! cont c) - (return obj))))))) - (lambda () (call-with-current-continuation - (lambda (ret) (set! return ret) (cont #f)))))) -(define (leaf-eq? x y) - (let* ((eot (list 'eot)) - (xf (next-leaf-generator x eot)) - (yf (next-leaf-generator y eot))) - (letrec ((loop (lambda (x y) - (cond ((not (eq? x y)) #f) - ((eq? eot x) #t) - (else (loop (xf) (yf))))))) - (loop (xf) (yf))))) -(define (test-cont) - (SECTION 6 9) - (test #t leaf-eq? '(a (b (c))) '((a) b c)) - (test #f leaf-eq? '(a (b (c))) '((a) b c d)) - (report-errs)) - -;;; Test Optional R4RS DELAY syntax and FORCE procedure -(define (test-delay) - (SECTION 6 9) - (test 3 'delay (force (delay (+ 1 2)))) - (test '(3 3) 'delay (let ((p (delay (+ 1 2)))) - (list (force p) (force p)))) - (test 2 'delay (letrec ((a-stream - (letrec ((next (lambda (n) - (cons n (delay (next (+ n 1))))))) - (next 0))) - (head car) - (tail (lambda (stream) (force (cdr stream))))) - (head (tail (tail a-stream))))) - (letrec ((count 0) - (p (delay (begin (set! count (+ count 1)) - (if (> count x) - count - (force p))))) - (x 5)) - (test 6 force p) - (set! x 10) - (test 6 force p)) - (test 3 'force - (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1))))) - (c #f)) - (force p))) - (report-errs)) - -(SECTION 6 10 1) -(test #t input-port? (current-input-port)) -(test #t output-port? (current-output-port)) -(test #t call-with-input-file (data-file "tests/r4rs.test") input-port?) -(define this-file (open-input-file (data-file "tests/r4rs.test"))) -(test #t input-port? this-file) -(SECTION 6 10 2) -(test #\; peek-char this-file) -(test #\; read-char this-file) -(test '(define cur-section '()) read this-file) -(test #\( peek-char this-file) -(test '(define errs '()) read this-file) -(close-input-port this-file) -(close-input-port this-file) -(define (check-test-file name) - (define test-file (open-input-file name)) - (test #t 'input-port? - (call-with-input-file - name - (lambda (test-file) - (test load-test-obj read test-file) - (test #t eof-object? (peek-char test-file)) - (test #t eof-object? (read-char test-file)) - (input-port? test-file)))) - (test #\; read-char test-file) - (test display-test-obj read test-file) - (test load-test-obj read test-file) - (close-input-port test-file)) -(SECTION 6 10 3) -(define write-test-obj - '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) -(define display-test-obj - '(#t #f a () 9739 -3 . #((test) te " " st test #() b c))) -(define load-test-obj - (list 'define 'foo (list 'quote write-test-obj))) -(test #t call-with-output-file - "tmp1" - (lambda (test-file) - (write-char #\; test-file) - (display write-test-obj test-file) - (newline test-file) - (write load-test-obj test-file) - (output-port? test-file))) -(check-test-file "tmp1") - -(define test-file (open-output-file "tmp2")) -(write-char #\; test-file) -(display write-test-obj test-file) -(newline test-file) -(write load-test-obj test-file) -(test #t output-port? test-file) -(close-output-port test-file) -(check-test-file "tmp2") -(define (test-sc4) - (SECTION 6 7) - (test '(#\P #\space #\l) string->list "P l") - (test '() string->list "") - (test "1\\\"" list->string '(#\1 #\\ #\")) - (test "" list->string '()) - (SECTION 6 8) - (test '(dah dah didah) vector->list '#(dah dah didah)) - (test '() vector->list '#()) - (test '#(dididit dah) list->vector '(dididit dah)) - (test '#() list->vector '()) - (SECTION 6 10 4) - (load (data-file "tmp1")) - (test write-test-obj 'load foo) - (report-errs)) - -(report-errs) -(if (and (string->number "0.0") (inexact? (string->number "0.0"))) - (test-inexact)) - -(let ((n (string->number "281474976710655"))) - (if (and n (exact? n)) - (test-bignum))) -(test-cont) -(test-sc4) -(test-delay) -"last item in file" diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test deleted file mode 100644 index 97c89c5a7..000000000 --- a/test-suite/tests/reader.test +++ /dev/null @@ -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))) diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test deleted file mode 100644 index d74470334..000000000 --- a/test-suite/tests/regexp.test +++ /dev/null @@ -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)) diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test deleted file mode 100644 index e439b95a1..000000000 --- a/test-suite/tests/strings.test +++ /dev/null @@ -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))) diff --git a/test-suite/tests/time.test b/test-suite/tests/time.test deleted file mode 100644 index 59b9125db..000000000 --- a/test-suite/tests/time.test +++ /dev/null @@ -1,28 +0,0 @@ -;;;; time.test --- test suite for Guile's time functions -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- June 1999 -;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(use-modules (test-suite lib) - (ice-9 regex)) - -(pass-if "strftime %Z doesn't return garbage" - (let ((t (localtime (current-time)))) - (vector-set! t 10 "ZOW") - (string=? (strftime "%Z" t) - "ZOW"))) diff --git a/test-suite/tests/version.test b/test-suite/tests/version.test deleted file mode 100644 index 0f9531c2b..000000000 --- a/test-suite/tests/version.test +++ /dev/null @@ -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))))) diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test deleted file mode 100644 index c6dbe500f..000000000 --- a/test-suite/tests/weaks.test +++ /dev/null @@ -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))))))) |