mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 04:15:36 +02:00
Code Activity

Merge branch 'master' into boehm-demers-weiser-gc

Browse source 
Conflicts:
	lib/Makefile.am
	libguile/Makefile.am
	libguile/frames.c
	libguile/gc-card.c
	libguile/gc-freelist.c
	libguile/gc-mark.c
	libguile/gc-segment.c
	libguile/gc_os_dep.c
	libguile/load.c
	libguile/macros.c
	libguile/objcodes.c
	libguile/programs.c
	libguile/strings.c
	libguile/vm.c
	m4/gnulib-cache.m4
	m4/gnulib-comp.m4
	m4/inline.m4
This commit is contained in:
Ludovic Courtès 2009-08-17 23:39:56 +02:00
commit fbb857a472
823 changed files with 61674 additions and 14111 deletions
Download patch file Download diff file Expand all files Collapse all files

27
test-suite/Makefile.am
View file

@ -4,20 +4,20 @@
##
## This file is part of GUILE.
##
## GUILE 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.
## GUILE is free software; you can redistribute it and/or modify it
## under the terms of the GNU Lesser General Public License as
## published by the Free Software Foundation; either version 3, or
## (at your option) any later version.
##
## GUILE 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.
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU Lesser General Public License for more details.
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
## You should have received a copy of the GNU Lesser General Public
## License along with GUILE; see the file COPYING.LESSER. If not,
## write to the Free Software Foundation, Inc., 51 Franklin Street,
## Fifth Floor, Boston, MA 02110-1301 USA
SUBDIRS = standalone
@ -26,6 +26,7 @@ SCM_TESTS = tests/alist.test \
tests/arbiters.test \
tests/asm-to-bytecode.test \
tests/bit-operations.test \
tests/bytevectors.test \
tests/c-api.test \
tests/chars.test \
tests/common-list.test \
@ -61,6 +62,7 @@ SCM_TESTS = tests/alist.test \
tests/q.test \
tests/r4rs.test \
tests/r5rs_pitfall.test \
tests/r6rs-ports.test \
tests/ramap.test \
tests/reader.test \
tests/receive.test \
@ -92,6 +94,7 @@ SCM_TESTS = tests/alist.test \
tests/syntax.test \
tests/threads.test \
tests/time.test \
tests/tree-il.test \
tests/unif.test \
tests/version.test \
tests/weaks.test

18
test-suite/guile-test
View file

@ -7,20 +7,20 @@
;;;;
;;;; Copyright (C) 1999, 2001, 2006 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 free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3, 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.
;;;; GNU Lesser 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this software; see the file COPYING.LESSER.
;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin
;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;; Usage: [guile -e main -s] guile-test [OPTIONS] [TEST ...]

63
test-suite/lib.scm
View file

@ -1,20 +1,20 @@
;;;; test-suite/lib.scm --- generic support for testing
;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009 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 free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3, 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.
;;;; GNU Lesser 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this software; see the file COPYING.LESSER.
;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin
;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite lib)
:use-module (ice-9 stack-catch)
@ -32,6 +32,7 @@
exception:system-error
exception:miscellaneous-error
exception:string-contains-nul
exception:read-error
;; Reporting passes and failures.
run-test
@ -265,6 +266,8 @@
(cons 'system-error ".*"))
(define exception:miscellaneous-error
(cons 'misc-error "^.*"))
(define exception:read-error
(cons 'read-error "^.*$"))
;; as per throw in scm_to_locale_stringn()
(define exception:string-contains-nul
@ -317,20 +320,24 @@
(set! run-test local-run-test))
;;; A short form for tests that are expected to pass, taken from Greg.
(defmacro pass-if (name . rest)
(if (and (null? rest) (pair? name))
;; presume this is a simple test, i.e. (pass-if (even? 2))
;; where the body should also be the name.
`(run-test ',name #t (lambda () ,name))
`(run-test ,name #t (lambda () ,@rest))))
(define-syntax pass-if
(syntax-rules ()
((_ name)
;; presume this is a simple test, i.e. (pass-if (even? 2))
;; where the body should also be the name.
(run-test 'name #t (lambda () name)))
((_ name rest ...)
(run-test name #t (lambda () rest ...)))))
;;; A short form for tests that are expected to fail, taken from Greg.
(defmacro expect-fail (name . rest)
(if (and (null? rest) (pair? name))
;; presume this is a simple test, i.e. (expect-fail (even? 2))
;; where the body should also be the name.
`(run-test ',name #f (lambda () ,name))
`(run-test ,name #f (lambda () ,@rest))))
(define-syntax expect-fail
(syntax-rules ()
((_ name)
;; presume this is a simple test, i.e. (expect-fail (even? 2))
;; where the body should also be the name.
(run-test 'name #f (lambda () name)))
((_ name rest ...)
(run-test name #f (lambda () rest ...)))))
;;; A helper function to implement the macros that test for exceptions.
(define (run-test-exception name exception expect-pass thunk)
@ -362,12 +369,16 @@
(apply throw key proc message rest))))))))
;;; A short form for tests that expect a certain exception to be thrown.
(defmacro pass-if-exception (name exception body . rest)
`(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
(define-syntax pass-if-exception
(syntax-rules ()
((_ name exception body rest ...)
(run-test-exception name exception #t (lambda () body rest ...)))))
;;; A short form for tests expected to fail to throw a certain exception.
(defmacro expect-fail-exception (name exception body . rest)
`(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
(define-syntax expect-fail-exception
(syntax-rules ()
((_ name exception body rest ...)
(run-test-exception name exception #f (lambda () body rest ...)))))
;;;; TEST NAMES

36
test-suite/standalone/Makefile.am
View file

@ -4,20 +4,20 @@
##
## This file is part of GUILE.
##
## GUILE 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.
## GUILE is free software; you can redistribute it and/or modify it
## under the terms of the GNU Lesser General Public License as
## published by the Free Software Foundation; either version 3, or
## (at your option) any later version.
##
## GUILE 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.
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU Lesser General Public License for more details.
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
## You should have received a copy of the GNU Lesser General Public
## License along with GUILE; see the file COPYING.LESSER. If not,
## write to the Free Software Foundation, Inc., 51 Franklin Street,
## Fifth Floor, Boston, MA 02110-1301 USA
# initializations so we can use += below.
@ -28,7 +28,8 @@ check_SCRIPTS =
BUILT_SOURCES =
EXTRA_DIST =
TESTS_ENVIRONMENT = "${top_builddir}/pre-inst-guile-env"
TESTS_ENVIRONMENT = \
GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env"
test_cflags = \
-I$(top_srcdir)/test-suite/standalone \
@ -125,6 +126,15 @@ test_scm_take_locale_symbol_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-scm-take-locale-symbol
TESTS += test-scm-take-locale-symbol
# test-extensions
noinst_LTLIBRARIES += libtest-extensions.la
libtest_extensions_la_SOURCES = test-extensions-lib.c
libtest_extensions_la_CFLAGS = ${test_cflags}
libtest_extensions_la_LDFLAGS = -no-undefined -rpath `pwd` # so libtool will really build an .so
libtest_extensions_la_LIBADD = ${top_builddir}/libguile/libguile.la
check_SCRIPTS += test-extensions
TESTS += test-extensions
if BUILD_PTHREAD_SUPPORT

2
test-suite/standalone/README
View file

@ -12,7 +12,7 @@ If you want to use a scheme script, prefix it as follows:
!#
Makefile.am will arrange for all tests (scripts or executables) to be
run under pre-inst-guile-env so that the PATH, LD_LIBRARY_PATH, and
run under uninstalled-env so that the PATH, LD_LIBRARY_PATH, and
GUILE_LOAD_PATH will be augmented appropriately.
The Makefile.am has an example of creating a shared library to be used

13
test-suite/standalone/test-asmobs-lib.c
View file

@ -1,18 +1,19 @@
/* Copyright (C) 1999,2000,2001,2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#ifndef HAVE_CONFIG_H

113
test-suite/standalone/test-conversion.c
View file

@ -1,18 +1,19 @@
/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008 Free Software Foundation, Inc.
/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#if HAVE_CONFIG_H
@ -680,31 +681,31 @@ test_8u (const char *str, scm_t_uintmax (*func) (SCM), const char *func_name,
#define DEFSTST(f) static scm_t_intmax tst_##f (SCM x) { return f(x); }
#define DEFUTST(f) static scm_t_uintmax tst_##f (SCM x) { return f(x); }
DEFSTST (scm_to_schar);
DEFUTST (scm_to_uchar);
DEFSTST (scm_to_char);
DEFSTST (scm_to_short);
DEFUTST (scm_to_ushort);
DEFSTST (scm_to_int);
DEFUTST (scm_to_uint);
DEFSTST (scm_to_long);
DEFUTST (scm_to_ulong);
DEFSTST (scm_to_schar)
DEFUTST (scm_to_uchar)
DEFSTST (scm_to_char)
DEFSTST (scm_to_short)
DEFUTST (scm_to_ushort)
DEFSTST (scm_to_int)
DEFUTST (scm_to_uint)
DEFSTST (scm_to_long)
DEFUTST (scm_to_ulong)
#if SCM_SIZEOF_LONG_LONG != 0
DEFSTST (scm_to_long_long);
DEFUTST (scm_to_ulong_long);
DEFSTST (scm_to_long_long)
DEFUTST (scm_to_ulong_long)
#endif
DEFSTST (scm_to_ssize_t);
DEFUTST (scm_to_size_t);
DEFSTST (scm_to_ssize_t)
DEFUTST (scm_to_size_t)
DEFSTST (scm_to_int8);
DEFUTST (scm_to_uint8);
DEFSTST (scm_to_int16);
DEFUTST (scm_to_uint16);
DEFSTST (scm_to_int32);
DEFUTST (scm_to_uint32);
DEFSTST (scm_to_int8)
DEFUTST (scm_to_uint8)
DEFSTST (scm_to_int16)
DEFUTST (scm_to_uint16)
DEFSTST (scm_to_int32)
DEFUTST (scm_to_uint32)
#ifdef SCM_HAVE_T_INT64
DEFSTST (scm_to_int64);
DEFUTST (scm_to_uint64);
DEFSTST (scm_to_int64)
DEFUTST (scm_to_uint64)
#endif
#define TEST_8S(v,f,r,re,te) test_8s (v, tst_##f, #f, r, re, te)
@ -818,15 +819,60 @@ test_9 (double val, const char *result)
}
}
/* The `infinity' and `not-a-number' values. */
static double guile_Inf, guile_NaN;
/* Initialize GUILE_INF and GUILE_NAN. Taken from `guile_ieee_init ()' in
`libguile/numbers.c'. */
static void
ieee_init (void)
{
#ifdef INFINITY
/* C99 INFINITY, when available.
FIXME: The standard allows for INFINITY to be something that overflows
at compile time. We ought to have a configure test to check for that
before trying to use it. (But in practice we believe this is not a
problem on any system guile is likely to target.) */
guile_Inf = INFINITY;
#elif HAVE_DINFINITY
/* OSF */
extern unsigned int DINFINITY[2];
guile_Inf = (*((double *) (DINFINITY)));
#else
double tmp = 1e+10;
guile_Inf = tmp;
for (;;)
{
guile_Inf *= 1e+10;
if (guile_Inf == tmp)
break;
tmp = guile_Inf;
}
#endif
#ifdef NAN
/* C99 NAN, when available */
guile_NaN = NAN;
#elif HAVE_DQNAN
{
/* OSF */
extern unsigned int DQNAN[2];
guile_NaN = (*((double *)(DQNAN)));
}
#else
guile_NaN = guile_Inf / guile_Inf;
#endif
}
static void
test_from_double ()
{
test_9 (12, "12.0");
test_9 (0.25, "0.25");
test_9 (0.1, "0.1");
test_9 (1.0/0.0, "+inf.0");
test_9 (-1.0/0.0, "-inf.0");
test_9 (0.0/0.0, "+nan.0");
test_9 (guile_Inf, "+inf.0");
test_9 (-guile_Inf, "-inf.0");
test_9 (guile_NaN, "+nan.0");
}
typedef struct {
@ -880,8 +926,8 @@ test_to_double ()
test_10 ("12", 12.0, 0);
test_10 ("0.25", 0.25, 0);
test_10 ("1/4", 0.25, 0);
test_10 ("+inf.0", 1.0/0.0, 0);
test_10 ("-inf.0", -1.0/0.0, 0);
test_10 ("+inf.0", guile_Inf, 0);
test_10 ("-inf.0",-guile_Inf, 0);
test_10 ("+1i", 0.0, 1);
}
@ -1056,6 +1102,7 @@ tests (void *data, int argc, char **argv)
int
main (int argc, char *argv[])
{
ieee_init ();
scm_boot_guile (argc, argv, tests, NULL);
return 0;
}

14
test-suite/standalone/test-extensions Executable file
View file

@ -0,0 +1,14 @@
#!/bin/sh
exec guile -q -s "$0" "$@"
!#
(load-extension "libtest-extensions" "libtest_extensions_init")
(load-extension "libtest-extensions" "libtest_extensions_init2")
(or (= init2-count 1)
(error "init2 called more or less than one time"))
;; Local Variables:
;; mode: scheme
;; End:

44
test-suite/standalone/test-extensions-lib.c Normal file
View file

@ -0,0 +1,44 @@
/* Copyright (C) 1999,2000,2001,2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#ifndef HAVE_CONFIG_H
# include <config.h>
#endif
#include <libguile.h>
SCM init2_count;
void libtest_extensions_init2 (void);
void libtest_extensions_init (void);
void
libtest_extensions_init2 (void)
{
scm_variable_set_x (init2_count,
scm_from_int (scm_to_int (scm_variable_ref (init2_count)) + 1));
}
void
libtest_extensions_init (void)
{
scm_c_define ("init2-count", scm_from_int (0));
init2_count = scm_permanent_object (scm_c_lookup ("init2-count"));
scm_c_register_extension ("libtest-extensions", "libtest_extensions_init2",
(scm_t_extension_init_func)libtest_extensions_init2, NULL);
}

23
test-suite/standalone/test-fast-slot-ref.in
View file

@ -2,19 +2,20 @@
# Copyright (C) 2006 Free Software Foundation, Inc.
#
# This library is free software; you can redistribute it and/or modify it
# under the terms of the GNU Lesser General Public License as published by
# the Free Software Foundation; either version 2.1 of the License, or (at
# your option) any later version.
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public License
# as published by the Free Software Foundation; either version 3 of
# the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
# License for more details.
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public License
# along with this library; if not, write to the Free Software Foundation,
# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
# 02110-1301 USA
# Test for %fast-slot-ref, which was previously implemented such that
# an out-of-range slot index could escape being properly detected, and
@ -25,7 +26,7 @@
# executing the (%fast-slot-ref i 3) line. For reasons as yet
# unknown, it does not cause a segmentation fault if the same code is
# loaded as a script; that is why we run it here using "guile -q <<EOF".
exec guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm >/dev/null 2>&1 <<EOF
exec guile -q >/dev/null 2>&1 <<EOF
(use-modules (oop goops))
(define-module (oop goops))
(define-class <c> () (a #:init-value 1) (b #:init-value 2) (c #:init-value 3))

13
test-suite/standalone/test-list.c
View file

@ -3,18 +3,19 @@
/* Copyright (C) 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#ifndef HAVE_CONFIG_H

13
test-suite/standalone/test-num2integral.c
View file

@ -1,18 +1,19 @@
/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#ifndef HAVE_CONFIG_H

22
test-suite/standalone/test-round.c
View file

@ -1,18 +1,19 @@
/* Copyright (C) 2004, 2006, 2008 Free Software Foundation, Inc.
/* Copyright (C) 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#if HAVE_CONFIG_H
@ -25,6 +26,13 @@
#if HAVE_FENV_H
#include <fenv.h>
#elif defined HAVE_MACHINE_FPU_H
/* On Tru64 5.1b, the declaration of fesetround(3) is in <machine/fpu.h>.
On NetBSD, this header has to be included along with <sys/types.h>. */
# ifdef HAVE_SYS_TYPES_H
# include <sys/types.h>
# endif
# include <machine/fpu.h>
#endif
#include <libguile.h>

13
test-suite/standalone/test-scm-c-read.c
View file

@ -1,18 +1,19 @@
/* Copyright (C) 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
/* Exercise `scm_c_read ()' and the port type API. Verify assumptions that

13
test-suite/standalone/test-scm-take-locale-symbol.c
View file

@ -1,18 +1,19 @@
/* Copyright (C) 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
/* Exercise `scm_take_locale_symbol ()', making sure it returns an interned

13
test-suite/standalone/test-scm-with-guile.c
View file

@ -1,18 +1,19 @@
/* Copyright (C) 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/

13
test-suite/standalone/test-unwind.c
View file

@ -1,18 +1,19 @@
/* Copyright (C) 2004, 2005, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#if HAVE_CONFIG_H

27
test-suite/standalone/test-use-srfi.in
View file

@ -2,24 +2,25 @@
# Copyright (C) 2006 Free Software Foundation, Inc.
#
# This library is free software; you can redistribute it and/or modify it
# under the terms of the GNU Lesser General Public License as published by
# the Free Software Foundation; either version 2.1 of the License, or (at
# your option) any later version.
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public License
# as published by the Free Software Foundation; either version 3 of
# the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
# License for more details.
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public License
# along with this library; if not, write to the Free Software Foundation,
# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
# 02110-1301 USA
# Test that two srfi numbers on the command line work.
#
guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm --use-srfi=1,10 >/dev/null <<EOF
guile -q --use-srfi=1,10 >/dev/null <<EOF
(if (and (defined? 'partition)
(defined? 'define-reader-ctor))
(exit 0) ;; good
@ -38,7 +39,7 @@ fi
# `top-repl' the core bindings got ahead of anything --use-srfi gave.
#
guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm --use-srfi=1 >/dev/null <<EOF
guile -q --use-srfi=1 >/dev/null <<EOF
(catch #t
(lambda ()
(iota 2 3 4))
@ -56,7 +57,7 @@ fi
# exercises duplicates handling in `top-repl' versus `use-srfis' (in
# boot-9.scm).
#
guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm --use-srfi=17 >/dev/null <<EOF
guile -q --use-srfi=17 >/dev/null <<EOF
(if (procedure-with-setter? car)
(exit 0) ;; good
(exit 1)) ;; bad

13
test-suite/standalone/test-with-guile-module.c
View file

@ -1,18 +1,19 @@
/* Copyright (C) 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#ifndef HAVE_CONFIG_H

2
test-suite/tests/alist.test
View file

@ -4,7 +4,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

25
test-suite/tests/and-let-star.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 2004, 2006 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-and-let-star)
#:use-module (test-suite lib)

2
test-suite/tests/arbiters.test
View file

@ -5,7 +5,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

90
test-suite/tests/asm-to-bytecode.test
View file

@ -3,7 +3,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@ -15,20 +15,33 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite tests asm-to-bytecode)
#:use-module (rnrs bytevector)
#:use-module (test-suite lib)
#:use-module (system vm instruction)
#:use-module (language assembly compile-bytecode))
(define (->u8-list sym val)
(let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
(uint32 4 ,bytevector-u32-native-set!))
sym)))
(or entry (error "unknown sym" sym))
(let ((bv (make-bytevector (car entry))))
((cadr entry) bv 0 val)
(bytevector->u8-list bv))))
(define (munge-bytecode v)
(let ((newv (make-u8vector (vector-length v))))
(let lp ((i 0))
(if (= i (vector-length v))
newv
(let ((x (vector-ref v i)))
(u8vector-set! newv i (if (symbol? x)
(instruction->opcode x)
x))
(lp (1+ i)))))))
(let lp ((i 0) (out '()))
(if (= i (vector-length v))
(list->u8vector (reverse out))
(let ((x (vector-ref v i)))
(cond
((symbol? x)
(lp (1+ i) (cons (instruction->opcode x) out)))
((integer? x)
(lp (1+ i) (cons x out)))
((pair? x)
(lp (1+ i) (append (reverse (apply ->u8-list x)) out)))
(else (error "bad test bytecode" x)))))))
(define (comp-test x y)
(let* ((y (munge-bytecode y))
@ -45,21 +58,13 @@
(lambda ()
(equal? v y)))))
(with-test-prefix "compiler"
(with-test-prefix "asm-to-bytecode"
(comp-test '(make-int8 3)
#(make-int8 3))
(comp-test `(load-integer ,(string (integer->char 0)))
#(load-integer 0 0 1 0))
(comp-test `(load-integer ,(string (integer->char 255)))
#(load-integer 0 0 1 255))
(comp-test `(load-integer ,(string (integer->char 1) (integer->char 0)))
#(load-integer 0 0 2 1 0))
(comp-test '(load-number "3.14")
(vector 'load-number 0 0 4 (char->integer #\3) (char->integer #\.)
(char->integer #\1) (char->integer #\4)))
@ -72,25 +77,34 @@
(vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o)
(char->integer #\o)))
(comp-test '(load-keyword "qux")
(vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u)
(char->integer #\x)))
;; fixme: little-endian test.
(comp-test '(load-program 3 2 1 0 () 3 #f (make-int8 3) (return))
(vector 'load-program 3 2 1 0 3 0 0 0 0 0 0 0
(instruction->opcode 'make-int8) 3
(instruction->opcode 'return)))
(comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return))
#(load-program
3 2 (uint16 1) ;; nargs, nrest, nlocs
(uint32 3) ;; len
(uint32 0) ;; metalen
(uint32 0) ;; padding
make-int8 3
return))
;; fixme: little-endian test.
(comp-test '(load-program 3 2 1 0 () 3
(load-program 3 2 1 0 () 3
;; the nops are to pad meta to an 8-byte alignment. not strictly
;; necessary for this test, but representative of the common case.
(comp-test '(load-program 3 2 1 () 8
(load-program 3 2 1 () 3
#f
(make-int8 3) (return))
(make-int8 3) (return))
(vector 'load-program 3 2 1 0 3 0 0 0 (+ 3 12) 0 0 0
(instruction->opcode 'make-int8) 3
(instruction->opcode 'return)
3 2 1 0 3 0 0 0 0 0 0 0
(instruction->opcode 'make-int8) 3
(instruction->opcode 'return)))))
(make-int8 3) (return)
(nop) (nop) (nop) (nop) (nop))
#(load-program
3 2 (uint16 1) ;; nargs, nrest, nlocs
(uint32 8) ;; len
(uint32 19) ;; metalen
(uint32 0) ;; padding
make-int8 3
return
nop nop nop nop nop
3 2 (uint16 1) ;; nargs, nrest, nlocs
(uint32 3) ;; len
(uint32 0) ;; metalen
(uint32 0) ;; padding
make-int8 3
return))))

9
test-suite/tests/bit-operations.test
View file

@ -1,10 +1,10 @@
;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
;;;; Copyright (C) 2000, 2001, 2003, 2006, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@ -15,8 +15,9 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (test-suite lib)
(ice-9 documentation))
(define-module (test-bit-operations)
:use-module (test-suite lib)
:use-module (ice-9 documentation))
;;;

681
test-suite/tests/bytevectors.test Normal file
View file

@ -0,0 +1,681 @@
;;;; bytevectors.test --- Exercise the R6RS bytevector API.
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-bytevector)
:use-module (test-suite lib)
:use-module (system base compile)
:use-module (rnrs bytevector))
;;; Some of the tests in here are examples taken from the R6RS Standard
;;; Libraries document.
(define-syntax c&e
(syntax-rules (pass-if pass-if-exception)
((_ (pass-if test-name exp))
(begin (pass-if (string-append test-name " (eval)")
(primitive-eval 'exp))
(pass-if (string-append test-name " (compile)")
(compile 'exp #:to 'value))))
((_ (pass-if-exception test-name exc exp))
(begin (pass-if-exception (string-append test-name " (eval)")
exc (primitive-eval 'exp))
(pass-if-exception (string-append test-name " (compile)")
exc (compile 'exp #:to 'value))))))
(define-syntax with-test-prefix/c&e
(syntax-rules ()
((_ section-name exp ...)
(with-test-prefix section-name (c&e exp) ...))))
(with-test-prefix/c&e "2.2 General Operations"
(pass-if "native-endianness"
(not (not (memq (native-endianness) '(big little)))))
(pass-if "make-bytevector"
(and (bytevector? (make-bytevector 20))
(bytevector? (make-bytevector 20 3))))
(pass-if "bytevector-length"
(= (bytevector-length (make-bytevector 20)) 20))
(pass-if "bytevector=?"
(and (bytevector=? (make-bytevector 20 7)
(make-bytevector 20 7))
(not (bytevector=? (make-bytevector 20 7)
(make-bytevector 20 0))))))
(with-test-prefix/c&e "2.3 Operations on Bytes and Octets"
(pass-if "bytevector-{u8,s8}-ref"
(equal? '(-127 129 -1 255)
(let ((b1 (make-bytevector 16 -127))
(b2 (make-bytevector 16 255)))
(list (bytevector-s8-ref b1 0)
(bytevector-u8-ref b1 0)
(bytevector-s8-ref b2 0)
(bytevector-u8-ref b2 0)))))
(pass-if "bytevector-{u8,s8}-set!"
(equal? '(-126 130 -10 246)
(let ((b (make-bytevector 16 -127)))
(bytevector-s8-set! b 0 -126)
(bytevector-u8-set! b 1 246)
(list (bytevector-s8-ref b 0)
(bytevector-u8-ref b 0)
(bytevector-s8-ref b 1)
(bytevector-u8-ref b 1)))))
(pass-if "bytevector->u8-list"
(let ((lst '(1 2 3 128 150 255)))
(equal? lst
(bytevector->u8-list
(let ((b (make-bytevector 6)))
(for-each (lambda (i v)
(bytevector-u8-set! b i v))
(iota 6)
lst)
b)))))
(pass-if "u8-list->bytevector"
(let ((lst '(1 2 3 128 150 255)))
(equal? lst
(bytevector->u8-list (u8-list->bytevector lst)))))
(pass-if "bytevector-uint-{ref,set!} [small]"
(let ((b (make-bytevector 15)))
(bytevector-uint-set! b 0 #x1234
(endianness little) 2)
(equal? (bytevector-uint-ref b 0 (endianness big) 2)
#x3412)))
(pass-if "bytevector-uint-set! [large]"
(let ((b (make-bytevector 16)))
(bytevector-uint-set! b 0 (- (expt 2 128) 3)
(endianness little) 16)
(equal? (bytevector->u8-list b)
'(253 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255))))
(pass-if "bytevector-uint-{ref,set!} [large]"
(let ((b (make-bytevector 120)))
(bytevector-uint-set! b 0 (- (expt 2 128) 3)
(endianness little) 16)
(equal? (bytevector-uint-ref b 0 (endianness little) 16)
#xfffffffffffffffffffffffffffffffd)))
(pass-if "bytevector-sint-ref [small]"
(let ((b (u8-list->bytevector '(#xff #xf0 #xff))))
(equal? (bytevector-sint-ref b 0 (endianness big) 2)
(bytevector-sint-ref b 1 (endianness little) 2)
-16)))
(pass-if "bytevector-sint-ref [large]"
(let ((b (make-bytevector 50)))
(bytevector-uint-set! b 0 (- (expt 2 128) 3)
(endianness little) 16)
(equal? (bytevector-sint-ref b 0 (endianness little) 16)
-3)))
(pass-if "bytevector-sint-set! [small]"
(let ((b (make-bytevector 3)))
(bytevector-sint-set! b 0 -16 (endianness big) 2)
(bytevector-sint-set! b 1 -16 (endianness little) 2)
(equal? (bytevector->u8-list b)
'(#xff #xf0 #xff))))
(pass-if "equal?"
(let ((bv1 (u8-list->bytevector (iota 123)))
(bv2 (u8-list->bytevector (iota 123))))
(equal? bv1 bv2))))
(with-test-prefix/c&e "2.4 Operations on Integers of Arbitrary Size"
(pass-if "bytevector->sint-list"
(let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
(equal? (bytevector->sint-list b (endianness little) 2)
'(513 -253 513 513))))
(pass-if "bytevector->uint-list"
(let ((b (u8-list->bytevector '(2 1 255 3 2 1 2 1))))
(equal? (bytevector->uint-list b (endianness big) 2)
'(513 65283 513 513))))
(pass-if "bytevector->uint-list [empty]"
(let ((b (make-bytevector 0)))
(null? (bytevector->uint-list b (endianness big) 2))))
(pass-if-exception "bytevector->sint-list [out-of-range]"
exception:out-of-range
(bytevector->sint-list (make-bytevector 6) (endianness little) 8))
(pass-if "bytevector->sint-list [off-by-one]"
(equal? (bytevector->sint-list (make-bytevector 31 #xff)
(endianness little) 8)
'(-1 -1 -1)))
(pass-if "{sint,uint}-list->bytevector"
(let ((b1 (sint-list->bytevector '(513 -253 513 513)
(endianness little) 2))
(b2 (uint-list->bytevector '(513 65283 513 513)
(endianness little) 2))
(b3 (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
(and (bytevector=? b1 b2)
(bytevector=? b2 b3))))
(pass-if "sint-list->bytevector [limits]"
(bytevector=? (sint-list->bytevector '(-32768 32767)
(endianness big) 2)
(let ((bv (make-bytevector 4)))
(bytevector-u8-set! bv 0 #x80)
(bytevector-u8-set! bv 1 #x00)
(bytevector-u8-set! bv 2 #x7f)
(bytevector-u8-set! bv 3 #xff)
bv)))
(pass-if-exception "sint-list->bytevector [out-of-range]"
exception:out-of-range
(sint-list->bytevector (list 0 0 (expt 2 16)) (endianness big)
2))
(pass-if-exception "uint-list->bytevector [out-of-range]"
exception:out-of-range
(uint-list->bytevector '(0 -1) (endianness big) 2)))
(with-test-prefix/c&e "2.5 Operations on 16-Bit Integers"
(pass-if "bytevector-u16-ref"
(let ((b (u8-list->bytevector
'(255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 253))))
(and (equal? (bytevector-u16-ref b 14 (endianness little))
#xfdff)
(equal? (bytevector-u16-ref b 14 (endianness big))
#xfffd))))
(pass-if "bytevector-s16-ref"
(let ((b (u8-list->bytevector
'(255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 253))))
(and (equal? (bytevector-s16-ref b 14 (endianness little))
-513)
(equal? (bytevector-s16-ref b 14 (endianness big))
-3))))
(pass-if "bytevector-s16-ref [unaligned]"
(let ((b (u8-list->bytevector '(#xff #xf0 #xff))))
(equal? (bytevector-s16-ref b 1 (endianness little))
-16)))
(pass-if "bytevector-{u16,s16}-ref"
(let ((b (make-bytevector 2)))
(bytevector-u16-set! b 0 44444 (endianness little))
(and (equal? (bytevector-u16-ref b 0 (endianness little))
44444)
(equal? (bytevector-s16-ref b 0 (endianness little))
(- 44444 65536)))))
(pass-if "bytevector-native-{u16,s16}-{ref,set!}"
(let ((b (make-bytevector 2)))
(bytevector-u16-native-set! b 0 44444)
(and (equal? (bytevector-u16-native-ref b 0)
44444)
(equal? (bytevector-s16-native-ref b 0)
(- 44444 65536)))))
(pass-if "bytevector-s16-{ref,set!} [unaligned]"
(let ((b (make-bytevector 3)))
(bytevector-s16-set! b 1 -77 (endianness little))
(equal? (bytevector-s16-ref b 1 (endianness little))
-77))))
(with-test-prefix/c&e "2.6 Operations on 32-bit Integers"
(pass-if "bytevector-u32-ref"
(let ((b (u8-list->bytevector
'(255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 253))))
(and (equal? (bytevector-u32-ref b 12 (endianness little))
#xfdffffff)
(equal? (bytevector-u32-ref b 12 (endianness big))
#xfffffffd))))
(pass-if "bytevector-s32-ref"
(let ((b (u8-list->bytevector
'(255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 253))))
(and (equal? (bytevector-s32-ref b 12 (endianness little))
-33554433)
(equal? (bytevector-s32-ref b 12 (endianness big))
-3))))
(pass-if "bytevector-{u32,s32}-ref"
(let ((b (make-bytevector 4)))
(bytevector-u32-set! b 0 2222222222 (endianness little))
(and (equal? (bytevector-u32-ref b 0 (endianness little))
2222222222)
(equal? (bytevector-s32-ref b 0 (endianness little))
(- 2222222222 (expt 2 32))))))
(pass-if "bytevector-{u32,s32}-native-{ref,set!}"
(let ((b (make-bytevector 4)))
(bytevector-u32-native-set! b 0 2222222222)
(and (equal? (bytevector-u32-native-ref b 0)
2222222222)
(equal? (bytevector-s32-native-ref b 0)
(- 2222222222 (expt 2 32)))))))
(with-test-prefix/c&e "2.7 Operations on 64-bit Integers"
(pass-if "bytevector-u64-ref"
(let ((b (u8-list->bytevector
'(255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 253))))
(and (equal? (bytevector-u64-ref b 8 (endianness little))
#xfdffffffffffffff)
(equal? (bytevector-u64-ref b 8 (endianness big))
#xfffffffffffffffd))))
(pass-if "bytevector-s64-ref"
(let ((b (u8-list->bytevector
'(255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 253))))
(and (equal? (bytevector-s64-ref b 8 (endianness little))
-144115188075855873)
(equal? (bytevector-s64-ref b 8 (endianness big))
-3))))
(pass-if "bytevector-{u64,s64}-ref"
(let ((b (make-bytevector 8))
(big 9333333333333333333))
(bytevector-u64-set! b 0 big (endianness little))
(and (equal? (bytevector-u64-ref b 0 (endianness little))
big)
(equal? (bytevector-s64-ref b 0 (endianness little))
(- big (expt 2 64))))))
(pass-if "bytevector-{u64,s64}-native-{ref,set!}"
(let ((b (make-bytevector 8))
(big 9333333333333333333))
(bytevector-u64-native-set! b 0 big)
(and (equal? (bytevector-u64-native-ref b 0)
big)
(equal? (bytevector-s64-native-ref b 0)
(- big (expt 2 64))))))
(pass-if "ref/set! with zero"
(let ((b (make-bytevector 8)))
(bytevector-s64-set! b 0 -1 (endianness big))
(bytevector-u64-set! b 0 0 (endianness big))
(= 0 (bytevector-u64-ref b 0 (endianness big))))))
(with-test-prefix/c&e "2.8 Operations on IEEE-754 Representations"
(pass-if "bytevector-ieee-single-native-{ref,set!}"
(let ((b (make-bytevector 4))
(number 3.00))
(bytevector-ieee-single-native-set! b 0 number)
(equal? (bytevector-ieee-single-native-ref b 0)
number)))
(pass-if "bytevector-ieee-single-{ref,set!}"
(let ((b (make-bytevector 8))
(number 3.14))
(bytevector-ieee-single-set! b 0 number (endianness little))
(bytevector-ieee-single-set! b 4 number (endianness big))
(equal? (bytevector-ieee-single-ref b 0 (endianness little))
(bytevector-ieee-single-ref b 4 (endianness big)))))
(pass-if "bytevector-ieee-single-{ref,set!} [unaligned]"
(let ((b (make-bytevector 9))
(number 3.14))
(bytevector-ieee-single-set! b 1 number (endianness little))
(bytevector-ieee-single-set! b 5 number (endianness big))
(equal? (bytevector-ieee-single-ref b 1 (endianness little))
(bytevector-ieee-single-ref b 5 (endianness big)))))
(pass-if "bytevector-ieee-double-native-{ref,set!}"
(let ((b (make-bytevector 8))
(number 3.14))
(bytevector-ieee-double-native-set! b 0 number)
(equal? (bytevector-ieee-double-native-ref b 0)
number)))
(pass-if "bytevector-ieee-double-{ref,set!}"
(let ((b (make-bytevector 16))
(number 3.14))
(bytevector-ieee-double-set! b 0 number (endianness little))
(bytevector-ieee-double-set! b 8 number (endianness big))
(equal? (bytevector-ieee-double-ref b 0 (endianness little))
(bytevector-ieee-double-ref b 8 (endianness big))))))
(define (with-locale locale thunk)
;; Run THUNK under LOCALE.
(let ((original-locale (setlocale LC_ALL)))
(catch 'system-error
(lambda ()
(setlocale LC_ALL locale))
(lambda (key . args)
(throw 'unresolved)))
(dynamic-wind
(lambda ()
#t)
thunk
(lambda ()
(setlocale LC_ALL original-locale)))))
(define (with-latin1-locale thunk)
;; Try out several ISO-8859-1 locales and run THUNK under the one that
;; works (if any).
(define %locales
(map (lambda (name)
(string-append name ".ISO-8859-1"))
'("fr_FR" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT")))
(let loop ((locales %locales))
(if (null? locales)
(throw 'unresolved)
(catch 'unresolved
(lambda ()
(with-locale (car locales) thunk))
(lambda (key . args)
(loop (cdr locales)))))))
;; Default to the C locale for the following tests.
(setlocale LC_ALL "C")
(with-test-prefix "2.9 Operations on Strings"
(pass-if "string->utf8"
(let* ((str "hello, world")
(utf8 (string->utf8 str)))
(and (bytevector? utf8)
(= (bytevector-length utf8)
(string-length str))
(equal? (string->list str)
(map integer->char (bytevector->u8-list utf8))))))
(pass-if "string->utf8 [latin-1]"
(with-latin1-locale
(lambda ()
(let* ((str "hé, ça va bien ?")
(utf8 (string->utf8 str)))
(and (bytevector? utf8)
(= (bytevector-length utf8)
(+ 2 (string-length str))))))))
(pass-if "string->utf16"
(let* ((str "hello, world")
(utf16 (string->utf16 str)))
(and (bytevector? utf16)
(= (bytevector-length utf16)
(* 2 (string-length str)))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf16
(endianness big) 2))))))
(pass-if "string->utf16 [little]"
(let* ((str "hello, world")
(utf16 (string->utf16 str (endianness little))))
(and (bytevector? utf16)
(= (bytevector-length utf16)
(* 2 (string-length str)))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf16
(endianness little) 2))))))
(pass-if "string->utf32"
(let* ((str "hello, world")
(utf32 (string->utf32 str)))
(and (bytevector? utf32)
(= (bytevector-length utf32)
(* 4 (string-length str)))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf32
(endianness big) 4))))))
(pass-if "string->utf32 [little]"
(let* ((str "hello, world")
(utf32 (string->utf32 str (endianness little))))
(and (bytevector? utf32)
(= (bytevector-length utf32)
(* 4 (string-length str)))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf32
(endianness little) 4))))))
(pass-if "utf8->string"
(let* ((utf8 (u8-list->bytevector (map char->integer
(string->list "hello, world"))))
(str (utf8->string utf8)))
(and (string? str)
(= (string-length str)
(bytevector-length utf8))
(equal? (string->list str)
(map integer->char (bytevector->u8-list utf8))))))
(pass-if "utf8->string [latin-1]"
(with-latin1-locale
(lambda ()
(let* ((utf8 (string->utf8 "hé, ça va bien ?"))
(str (utf8->string utf8)))
(and (string? str)
(= (string-length str)
(- (bytevector-length utf8) 2)))))))
(pass-if "utf16->string"
(let* ((utf16 (uint-list->bytevector (map char->integer
(string->list "hello, world"))
(endianness big) 2))
(str (utf16->string utf16)))
(and (string? str)
(= (* 2 (string-length str))
(bytevector-length utf16))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf16 (endianness big)
2))))))
(pass-if "utf16->string [little]"
(let* ((utf16 (uint-list->bytevector (map char->integer
(string->list "hello, world"))
(endianness little) 2))
(str (utf16->string utf16 (endianness little))))
(and (string? str)
(= (* 2 (string-length str))
(bytevector-length utf16))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf16 (endianness little)
2))))))
(pass-if "utf32->string"
(let* ((utf32 (uint-list->bytevector (map char->integer
(string->list "hello, world"))
(endianness big) 4))
(str (utf32->string utf32)))
(and (string? str)
(= (* 4 (string-length str))
(bytevector-length utf32))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf32 (endianness big)
4))))))
(pass-if "utf32->string [little]"
(let* ((utf32 (uint-list->bytevector (map char->integer
(string->list "hello, world"))
(endianness little) 4))
(str (utf32->string utf32 (endianness little))))
(and (string? str)
(= (* 4 (string-length str))
(bytevector-length utf32))
(equal? (string->list str)
(map integer->char
(bytevector->uint-list utf32 (endianness little)
4)))))))
(with-test-prefix "Datum Syntax"
(pass-if "empty"
(equal? (with-input-from-string "#vu8()" read)
(make-bytevector 0)))
(pass-if "simple"
(equal? (with-input-from-string "#vu8(1 2 3 4 5)" read)
(u8-list->bytevector '(1 2 3 4 5))))
(pass-if ">127"
(equal? (with-input-from-string "#vu8(0 255 127 128)" read)
(u8-list->bytevector '(0 255 127 128))))
(pass-if "self-evaluating"
(equal? (eval (with-input-from-string "#vu8(1 2 3 4 5)" read)
(current-module))
(u8-list->bytevector '(1 2 3 4 5))))
(pass-if "quoted"
(equal? (eval (with-input-from-string "'#vu8(1 2 3 4 5)" read)
(current-module))
(u8-list->bytevector '(1 2 3 4 5))))
(pass-if "literal simple"
(equal? #vu8(1 2 3 4 5)
(u8-list->bytevector '(1 2 3 4 5))))
(pass-if "literal >127"
(equal? #vu8(0 255 127 128)
(u8-list->bytevector '(0 255 127 128))))
(pass-if "literal quoted"
(equal? '#vu8(1 2 3 4 5)
(u8-list->bytevector '(1 2 3 4 5))))
(pass-if-exception "incorrect prefix"
exception:read-error
(with-input-from-string "#vi8(1 2 3)" read))
(pass-if-exception "extraneous space"
exception:read-error
(with-input-from-string "#vu8 (1 2 3)" read))
(pass-if-exception "negative integers"
exception:wrong-type-arg
(with-input-from-string "#vu8(-1 -2 -3)" read))
(pass-if-exception "out-of-range integers"
exception:wrong-type-arg
(with-input-from-string "#vu8(0 256)" read)))
(with-test-prefix "Generalized Vectors"
(pass-if "generalized-vector?"
(generalized-vector? #vu8(1 2 3)))
(pass-if "generalized-vector-length"
(equal? (iota 16)
(map generalized-vector-length
(map make-bytevector (iota 16)))))
(pass-if "generalized-vector-ref"
(let ((bv #vu8(255 127)))
(and (= 255 (generalized-vector-ref bv 0))
(= 127 (generalized-vector-ref bv 1)))))
(pass-if-exception "generalized-vector-ref [index out-of-range]"
exception:out-of-range
(let ((bv #vu8(1 2)))
(generalized-vector-ref bv 2)))
(pass-if "generalized-vector-set!"
(let ((bv (make-bytevector 2)))
(generalized-vector-set! bv 0 255)
(generalized-vector-set! bv 1 77)
(equal? '(255 77)
(bytevector->u8-list bv))))
(pass-if-exception "generalized-vector-set! [index out-of-range]"
exception:out-of-range
(let ((bv (make-bytevector 2)))
(generalized-vector-set! bv 2 0)))
(pass-if-exception "generalized-vector-set! [value out-of-range]"
exception:out-of-range
(let ((bv (make-bytevector 2)))
(generalized-vector-set! bv 0 256)))
(pass-if "array-type"
(eq? 'vu8 (array-type #vu8())))
(pass-if "array-contents"
(let ((bv (u8-list->bytevector (iota 10))))
(eq? bv (array-contents bv))))
(pass-if "array-ref"
(let ((bv (u8-list->bytevector (iota 10))))
(equal? (iota 10)
(map (lambda (i) (array-ref bv i))
(iota 10)))))
(pass-if "array-set!"
(let ((bv (make-bytevector 10)))
(for-each (lambda (i)
(array-set! bv i i))
(iota 10))
(equal? (iota 10)
(bytevector->u8-list bv))))
(pass-if "make-typed-array"
(let ((bv (make-typed-array 'vu8 77 33)))
(equal? bv (u8-list->bytevector (make-list 33 77)))))
(pass-if-exception "make-typed-array [out-of-range]"
exception:out-of-range
(make-typed-array 'vu8 256 77))
(pass-if "uniform-array->bytevector"
(let ((bv #vu8(0 1 128 255)))
(equal? bv (uniform-array->bytevector bv)))))
;;; Local Variables:
;;; coding: latin-1
;;; mode: scheme
;;; End:

21
test-suite/tests/c-api.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 1999, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define srcdir (cdr (assq 'srcdir %guile-build-info)))

22
test-suite/tests/chars.test
View file

@ -3,21 +3,19 @@
;;;;
;;;; Copyright (C) 2000, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (test-suite lib))

2
test-suite/tests/common-list.test
View file

@ -4,7 +4,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

67
test-suite/tests/compiler.test
View file

@ -1,10 +1,10 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001, 2006 Free Software Foundation, Inc.
;;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@ -18,45 +18,38 @@
(define-module (test-suite tests compiler)
:use-module (test-suite lib)
:use-module (test-suite guile-test)
:use-module (system vm program))
:use-module (system base compile))
(with-test-prefix "environments"
(pass-if "compile-time-environment in evaluator"
(eq? (primitive-eval '(compile-time-environment)) #f))
(with-test-prefix "basic"
(pass-if "compile-time-environment in compiler"
(equal? (compile '(compile-time-environment))
(cons (current-module)
(cons '() '()))))
(pass-if "compile to value"
(equal? (compile 1) 1)))
(let ((env (compile
'(let ((x 0)) (set! x 1) (compile-time-environment)))))
(pass-if "compile-time-environment in compiler, heap-allocated var"
(equal? env
(cons (current-module)
(cons '((x . 0)) '(1)))))
(with-test-prefix "psyntax"
;; fixme: compiling with #t or module
(pass-if "recompiling with environment"
(equal? ((compile '(lambda () x) #:env env))
1))
(pass-if "redefinition"
;; In this case the locally-bound `round' must have the same value as the
;; imported `round'. See the same test in `syntax.test' for details.
(begin
(compile '(define round round))
(compile '(eq? round (@@ (guile) round)))))
(pass-if "recompiling with environment/2"
(equal? ((compile '(lambda () (set! x (1+ x)) x) #:env env))
2))
(pass-if "compile in current module"
(let ((o (begin
(compile '(define-macro (foo) 'bar))
(compile '(let ((bar 'ok)) (foo))))))
(and (module-ref (current-module) 'foo)
(eq? o 'ok))))
(pass-if "recompiling with environment/3"
(equal? ((compile '(lambda () x) #:env env))
2))
)
(pass-if "compile environment is #f"
(equal? ((compile '(lambda () 10)))
10))
(pass-if "compile environment is a module"
(equal? ((compile '(lambda () 10) #:env (current-module)))
10))
)
(pass-if "compile in fresh module"
(let* ((m (let ((m (make-module)))
(beautify-user-module! m)
m))
(o (begin
(compile '(define-macro (foo) 'bar) #:env m)
(compile '(let ((bar 'ok)) (foo)) #:env m))))
(and (module-ref m 'foo)
(eq? o 'ok)))))

21
test-suite/tests/continuations.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2003, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-continuations)
:use-module (test-suite lib))

21
test-suite/tests/dynamic-scope.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2001, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-dynamic-scope)
:use-module (test-suite lib))

6
test-suite/tests/elisp.test
View file

@ -4,7 +4,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@ -23,6 +23,9 @@
(if *old-stack-level*
(debug-set! stack (* 2 *old-stack-level*)))
(define *old-%load-should-autocompile* %load-should-autocompile)
(set! %load-should-autocompile #f)
;;;
;;; elisp
;;;
@ -350,6 +353,7 @@
))
(set! %load-should-autocompile *old-%load-should-autocompile*)
(debug-set! stack *old-stack-level*)
;;; elisp.test ends here

2
test-suite/tests/environments.nottest
View file

@ -4,7 +4,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

27
test-suite/tests/eval.test
View file

@ -4,7 +4,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@ -24,6 +24,9 @@
(define exception:bad-expression
(cons 'syntax-error "Bad expression"))
(define exception:failed-match
(cons 'syntax-error "failed to match any pattern"))
;;;
;;; miscellaneous
@ -85,17 +88,19 @@
;; Macros are accepted as function parameters.
;; Functions that 'apply' macros are rewritten!!!
(expect-fail-exception "macro as argument"
exception:wrong-type-arg
(let ((f (lambda (p a b) (p a b))))
(f and #t #t)))
(pass-if-exception "macro as argument"
exception:failed-match
(primitive-eval
'(let ((f (lambda (p a b) (p a b))))
(f and #t #t))))
(expect-fail-exception "passing macro as parameter"
exception:wrong-type-arg
(let* ((f (lambda (p a b) (p a b)))
(foo (procedure-source f)))
(f and #t #t)
(equal? (procedure-source f) foo)))
(pass-if-exception "passing macro as parameter"
exception:failed-match
(primitive-eval
'(let* ((f (lambda (p a b) (p a b)))
(foo (procedure-source f)))
(f and #t #t)
(equal? (procedure-source f) foo))))
))

2
test-suite/tests/exceptions.test
View file

@ -4,7 +4,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

2
test-suite/tests/filesys.test
View file

@ -5,7 +5,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

21
test-suite/tests/format.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2001, 2003, 2004, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-format)
#:use-module (test-suite lib)

23
test-suite/tests/fractions.test
View file

@ -1,17 +1,18 @@
;;;; Copyright (C) 2004, 2005, 2006 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 version 2 as
;;;; published by the Free Software Foundation; see file GNU-GPL.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software Foundation,
;;;; Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;; Based in part on code from GNU CLISP, Copyright (C) 1993 Michael Stoll

2
test-suite/tests/ftw.test
View file

@ -5,7 +5,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

2
test-suite/tests/gc.test
View file

@ -4,7 +4,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

25
test-suite/tests/getopt-long.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2001, 2006 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (test-suite lib)
(ice-9 getopt-long)

34
test-suite/tests/goops.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-goops)
#:use-module (test-suite lib)
@ -261,6 +260,19 @@
(method-more-specific? m1 m2 '()))
(current-module))))
(with-test-prefix "the method cache"
(pass-if "defining a method with a rest arg"
(let ((m (current-module)))
(eval '(define-method (foo bar . baz)
(cons bar baz))
m)
(eval '(foo 1)
m)
(eval '(foo 1 2)
m)
(eval '(equal? (foo 1 2) '(1 2))
m))))
(with-test-prefix "defining accessors"
(with-test-prefix "define-accessor"

21
test-suite/tests/guardians.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 1999, 2001, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; These tests make some questionable assumptions.
;;;

2
test-suite/tests/hash.test
View file

@ -5,7 +5,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

2
test-suite/tests/hooks.test
View file

@ -4,7 +4,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

6
test-suite/tests/i18n.test
View file

@ -6,13 +6,13 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

2
test-suite/tests/import.test
View file

@ -4,7 +4,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

21
test-suite/tests/interp.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 1999, 2001, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(pass-if "Internal defines 1"
(letrec ((foo (lambda (arg)

2
test-suite/tests/list.test
View file

@ -4,7 +4,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

21
test-suite/tests/load.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 1999, 2001, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-load)
:use-module (test-suite lib)

15
test-suite/tests/modules.test
View file

@ -1,17 +1,17 @@
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
;;;; Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
@ -34,6 +34,13 @@
(with-test-prefix "foundations"
(pass-if "modules don't remain anonymous"
;; This is a requirement for `psyntax': it stores module names and relies
;; on being able to `resolve-module' them.
(let ((m (make-module)))
(and (module-name m)
(eq? m (resolve-module (module-name m))))))
(pass-if "module-add!"
(let ((m (make-module))
(value (cons 'x 'y)))

21
test-suite/tests/multilingual.nottest
View file

@ -4,20 +4,19 @@
;;;;
;;;; Copyright (C) 1999, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (test-suite lib))

11
test-suite/tests/numbers.test
View file

@ -4,7 +4,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@ -1365,7 +1365,14 @@
("1@0" 1.0) ("1@+0" 1.0) ("1@-0" 1.0)
("2+3i" ,(+ 2 (* 3 +i))) ("4-5i" ,(- 4 (* 5 +i)))
("1+i" 1+1i) ("1-i" 1-1i) ("+1i" 0+1i) ("-1i" 0-1i)
("+i" +1i) ("-i" -1i)))
("+i" +1i) ("-i" -1i)
("1.0+.1i" 1.0+0.1i)
("1.0-.1i" 1.0-0.1i)
(".1+.0i" 0.1)
("1.+.0i" 1.0)
(".1+.1i" 0.1+0.1i)
("1e1+.1i" 10+0.1i)
))
#t)
(pass-if-exception "exponent too big"

21
test-suite/tests/optargs.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2001, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-optargs)
:use-module (test-suite lib)

21
test-suite/tests/options.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 2002, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (test-suite lib))

21
test-suite/tests/pairs.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 2003, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (test-suite lib))

2
test-suite/tests/poe.test
View file

@ -5,7 +5,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

110
test-suite/tests/popen.test
View file

@ -5,7 +5,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@ -73,20 +73,46 @@
(open-input-pipe "echo hello"))))))
#t)
(pass-if "open-input-pipe process gets (current-input-port) as stdin"
(let* ((p2c (pipe))
(port (with-input-from-port (car p2c)
(lambda ()
(open-input-pipe "read line && echo $line")))))
(display "hello\n" (cdr p2c))
(force-output (cdr p2c))
(let ((result (eq? (read port) 'hello)))
(close-port (cdr p2c))
(close-pipe port)
result)))
;; After the child closes stdout (which it indicates here by writing
;; "closed" to stderr), the parent should see eof. In Guile 1.6.4 and
;; earlier a duplicate of stdout existed in the child, meaning eof was not
;; seen.
;; "closed" to stderr), the parent should see eof. In Guile 1.6.4
;; and earlier a duplicate of stdout existed in the child, meaning
;; eof was not seen.
;;
;; Note that the objective here is to test that the parent sees EOF
;; while the child is still alive. (It is obvious that the parent
;; must see EOF once the child has died.) The use of the `p2c'
;; pipe, and `echo closed' and `read' in the child, allows us to be
;; sure that we are testing what the parent sees at a point where
;; the child has closed stdout but is still alive.
(pass-if "no duplicate"
(let* ((pair (pipe))
(port (with-error-to-port (cdr pair)
(let* ((c2p (pipe))
(p2c (pipe))
(port (with-error-to-port (cdr c2p)
(lambda ()
(open-input-pipe
"exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999")))))
(close-port (cdr pair)) ;; write side
(and (char? (read-char (car pair))) ;; wait for child to do its thing
(char-ready? port)
(eof-object? (read-char port))))))
(with-input-from-port (car p2c)
(lambda ()
(open-input-pipe
"exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; read")))))))
(close-port (cdr c2p)) ;; write side
(let ((result (eof-object? (read-char port))))
(display "hello!\n" (cdr p2c))
(force-output (cdr p2c))
(close-pipe port)
result)))
)
;;
;; open-output-pipe
@ -121,27 +147,47 @@
#t)
;; After the child closes stdin (which it indicates here by writing
;; "closed" to stderr), the parent should see a broken pipe. We setup to
;; see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4 and earlier a
;; duplicate of stdin existed in the child, preventing the broken pipe
;; occurring.
;; "closed" to stderr), the parent should see a broken pipe. We
;; setup to see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4
;; and earlier a duplicate of stdin existed in the child, preventing
;; the broken pipe occurring.
;;
;; Note that the objective here is to test that the parent sees a
;; broken pipe while the child is still alive. (It is obvious that
;; the parent will see a broken pipe once the child has died.) The
;; use of the `c2p' pipe, and the repeated `echo closed' in the
;; child, allows us to be sure that we are testing what the parent
;; sees at a point where the child has closed stdin but is still
;; alive.
;;
;; Note that `with-epipe' must apply only to the parent and not to
;; the child process; we rely on the child getting SIGPIPE, to
;; terminate it (and avoid leaving a zombie).
(pass-if "no duplicate"
(with-epipe
(lambda ()
(let* ((pair (pipe))
(port (with-error-to-port (cdr pair)
(lambda ()
(open-output-pipe
"exec 0</dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999")))))
(close-port (cdr pair)) ;; write side
(and (char? (read-char (car pair))) ;; wait for child to do its thing
(catch 'system-error
(lambda ()
(write-char #\x port)
(force-output port)
#f)
(lambda (key name fmt args errno-list)
(= (car errno-list) EPIPE)))))))))
(let* ((c2p (pipe))
(port (with-error-to-port (cdr c2p)
(lambda ()
(open-output-pipe
"exec 0</dev/null; while true; do echo closed 1>&2; done")))))
(close-port (cdr c2p)) ;; write side
(with-epipe
(lambda ()
(let ((result
(and (char? (read-char (car c2p))) ;; wait for child to do its thing
(catch 'system-error
(lambda ()
(write-char #\x port)
(force-output port)
#f)
(lambda (key name fmt args errno-list)
(= (car errno-list) EPIPE))))))
;; Now close our reading end of the pipe. This should give
;; the child a broken pipe and so allow it to exit.
(close-port (car c2p))
(close-pipe port)
result)))))
)
;;
;; close-pipe

21
test-suite/tests/ports.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-ports)
:use-module (test-suite lib)

25
test-suite/tests/posix.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright 2003, 2004, 2006, 2007 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-posix)
:use-module (test-suite lib))

25
test-suite/tests/procprop.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2009 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-procpop)
:use-module (test-suite lib))

2
test-suite/tests/q.test
View file

@ -5,7 +5,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

2
test-suite/tests/r4rs.test
View file

@ -4,7 +4,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

2
test-suite/tests/r5rs_pitfall.test
View file

@ -4,7 +4,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

456
test-suite/tests/r6rs-ports.test Normal file
View file

@ -0,0 +1,456 @@
;;;; r6rs-ports.test --- Exercise the R6RS I/O port API.
;;;;
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-io-ports)
:use-module (test-suite lib)
:use-module (srfi srfi-1)
:use-module (srfi srfi-11)
:use-module (rnrs io ports)
:use-module (rnrs bytevector))
;;; All these tests assume Guile 1.8's port system, where characters are
;;; treated as octets.
(with-test-prefix "7.2.5 End-of-File Object"
(pass-if "eof-object"
(and (eqv? (eof-object) (eof-object))
(eq? (eof-object) (eof-object)))))
(with-test-prefix "7.2.8 Binary Input"
(pass-if "get-u8"
(let ((port (open-input-string "A")))
(and (= (char->integer #\A) (get-u8 port))
(eof-object? (get-u8 port)))))
(pass-if "lookahead-u8"
(let ((port (open-input-string "A")))
(and (= (char->integer #\A) (lookahead-u8 port))
(not (eof-object? port))
(= (char->integer #\A) (get-u8 port))
(eof-object? (get-u8 port)))))
(pass-if "get-bytevector-n [short]"
(let* ((port (open-input-string "GNU Guile"))
(bv (get-bytevector-n port 4)))
(and (bytevector? bv)
(equal? (bytevector->u8-list bv)
(map char->integer (string->list "GNU "))))))
(pass-if "get-bytevector-n [long]"
(let* ((port (open-input-string "GNU Guile"))
(bv (get-bytevector-n port 256)))
(and (bytevector? bv)
(equal? (bytevector->u8-list bv)
(map char->integer (string->list "GNU Guile"))))))
(pass-if-exception "get-bytevector-n with closed port"
exception:wrong-type-arg
(let ((port (%make-void-port "r")))
(close-port port)
(get-bytevector-n port 3)))
(pass-if "get-bytevector-n! [short]"
(let* ((port (open-input-string "GNU Guile"))
(bv (make-bytevector 4))
(read (get-bytevector-n! port bv 0 4)))
(and (equal? read 4)
(equal? (bytevector->u8-list bv)
(map char->integer (string->list "GNU "))))))
(pass-if "get-bytevector-n! [long]"
(let* ((str "GNU Guile")
(port (open-input-string str))
(bv (make-bytevector 256))
(read (get-bytevector-n! port bv 0 256)))
(and (equal? read (string-length str))
(equal? (map (lambda (i)
(bytevector-u8-ref bv i))
(iota read))
(map char->integer (string->list str))))))
(pass-if "get-bytevector-some [simple]"
(let* ((str "GNU Guile")
(port (open-input-string str))
(bv (get-bytevector-some port)))
(and (bytevector? bv)
(equal? (bytevector->u8-list bv)
(map char->integer (string->list str))))))
(pass-if "get-bytevector-some [only-some]"
(let* ((str "GNU Guile")
(index 0)
(port (make-soft-port
(vector #f #f #f
(lambda ()
(if (>= index (string-length str))
(eof-object)
(let ((c (string-ref str index)))
(set! index (+ index 1))
c)))
(lambda () #t)
(lambda ()
;; Number of readily available octets: falls to
;; zero after 4 octets have been read.
(- 4 (modulo index 5))))
"r"))
(bv (get-bytevector-some port)))
(and (bytevector? bv)
(= index 4)
(= (bytevector-length bv) index)
(equal? (bytevector->u8-list bv)
(map char->integer (string->list "GNU "))))))
(pass-if "get-bytevector-all"
(let* ((str "GNU Guile")
(index 0)
(port (make-soft-port
(vector #f #f #f
(lambda ()
(if (>= index (string-length str))
(eof-object)
(let ((c (string-ref str index)))
(set! index (+ index 1))
c)))
(lambda () #t)
(let ((cont? #f))
(lambda ()
;; Number of readily available octets: falls to
;; zero after 4 octets have been read and then
;; starts again.
(let ((a (if cont?
(- (string-length str) index)
(- 4 (modulo index 5)))))
(if (= 0 a) (set! cont? #t))
a))))
"r"))
(bv (get-bytevector-all port)))
(and (bytevector? bv)
(= index (string-length str))
(= (bytevector-length bv) (string-length str))
(equal? (bytevector->u8-list bv)
(map char->integer (string->list str)))))))
(define (make-soft-output-port)
(let* ((bv (make-bytevector 1024))
(read-index 0)
(write-index 0)
(write-char (lambda (chr)
(bytevector-u8-set! bv write-index
(char->integer chr))
(set! write-index (+ 1 write-index)))))
(make-soft-port
(vector write-char
(lambda (str) ;; write-string
(for-each write-char (string->list str)))
(lambda () #t) ;; flush-output
(lambda () ;; read-char
(if (>= read-index (bytevector-length bv))
(eof-object)
(let ((c (bytevector-u8-ref bv read-index)))
(set! read-index (+ read-index 1))
(integer->char c))))
(lambda () #t)) ;; close-port
"rw")))
(with-test-prefix "7.2.11 Binary Output"
(pass-if "put-u8"
(let ((port (make-soft-output-port)))
(put-u8 port 77)
(equal? (get-u8 port) 77)))
(pass-if "put-bytevector [2 args]"
(let ((port (make-soft-output-port))
(bv (make-bytevector 256)))
(put-bytevector port bv)
(equal? (bytevector->u8-list bv)
(bytevector->u8-list
(get-bytevector-n port (bytevector-length bv))))))
(pass-if "put-bytevector [3 args]"
(let ((port (make-soft-output-port))
(bv (make-bytevector 256))
(start 10))
(put-bytevector port bv start)
(equal? (drop (bytevector->u8-list bv) start)
(bytevector->u8-list
(get-bytevector-n port (- (bytevector-length bv) start))))))
(pass-if "put-bytevector [4 args]"
(let ((port (make-soft-output-port))
(bv (make-bytevector 256))
(start 10)
(count 77))
(put-bytevector port bv start count)
(equal? (take (drop (bytevector->u8-list bv) start) count)
(bytevector->u8-list
(get-bytevector-n port count)))))
(pass-if-exception "put-bytevector with closed port"
exception:wrong-type-arg
(let* ((bv (make-bytevector 4))
(port (%make-void-port "w")))
(close-port port)
(put-bytevector port bv))))
(with-test-prefix "7.2.7 Input Ports"
;; This section appears here so that it can use the binary input
;; primitives.
(pass-if "open-bytevector-input-port [1 arg]"
(let* ((str "Hello Port!")
(bv (u8-list->bytevector (map char->integer
(string->list str))))
(port (open-bytevector-input-port bv))
(read-to-string
(lambda (port)
(let loop ((chr (read-char port))
(result '()))
(if (eof-object? chr)
(apply string (reverse! result))
(loop (read-char port)
(cons chr result)))))))
(equal? (read-to-string port) str)))
(pass-if-exception "bytevector-input-port is read-only"
exception:wrong-type-arg
(let* ((str "Hello Port!")
(bv (u8-list->bytevector (map char->integer
(string->list str))))
(port (open-bytevector-input-port bv #f)))
(write "hello" port)))
(pass-if "bytevector input port supports seeking"
(let* ((str "Hello Port!")
(bv (u8-list->bytevector (map char->integer
(string->list str))))
(port (open-bytevector-input-port bv #f)))
(and (port-has-port-position? port)
(= 0 (port-position port))
(port-has-set-port-position!? port)
(begin
(set-port-position! port 6)
(= 6 (port-position port)))
(bytevector=? (get-bytevector-all port)
(u8-list->bytevector
(map char->integer (string->list "Port!")))))))
(pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
exception:wrong-num-args
;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
;; optional.
(make-custom-binary-input-port "port" (lambda args #t)))
(pass-if "make-custom-binary-input-port"
(let* ((source (make-bytevector 7777))
(read! (let ((pos 0)
(len (bytevector-length source)))
(lambda (bv start count)
(let ((amount (min count (- len pos))))
(if (> amount 0)
(bytevector-copy! source pos
bv start amount))
(set! pos (+ pos amount))
amount))))
(port (make-custom-binary-input-port "the port" read!
#f #f #f)))
(bytevector=? (get-bytevector-all port) source)))
(pass-if "custom binary input port does not support `port-position'"
(let* ((str "Hello Port!")
(source (open-bytevector-input-port
(u8-list->bytevector
(map char->integer (string->list str)))))
(read! (lambda (bv start count)
(let ((r (get-bytevector-n! source bv start count)))
(if (eof-object? r)
0
r))))
(port (make-custom-binary-input-port "the port" read!
#f #f #f)))
(not (or (port-has-port-position? port)
(port-has-set-port-position!? port)))))
(pass-if "custom binary input port supports `port-position'"
(let* ((str "Hello Port!")
(source (open-bytevector-input-port
(u8-list->bytevector
(map char->integer (string->list str)))))
(read! (lambda (bv start count)
(let ((r (get-bytevector-n! source bv start count)))
(if (eof-object? r)
0
r))))
(get-pos (lambda ()
(port-position source)))
(set-pos! (lambda (pos)
(set-port-position! source pos)))
(port (make-custom-binary-input-port "the port" read!
get-pos set-pos! #f)))
(and (port-has-port-position? port)
(= 0 (port-position port))
(port-has-set-port-position!? port)
(begin
(set-port-position! port 6)
(= 6 (port-position port)))
(bytevector=? (get-bytevector-all port)
(u8-list->bytevector
(map char->integer (string->list "Port!")))))))
(pass-if "custom binary input port `close-proc' is called"
(let* ((closed? #f)
(read! (lambda (bv start count) 0))
(get-pos (lambda () 0))
(set-pos! (lambda (pos) #f))
(close! (lambda () (set! closed? #t)))
(port (make-custom-binary-input-port "the port" read!
get-pos set-pos!
close!)))
(close-port port)
(gc) ; Test for marking a closed port.
closed?)))
(with-test-prefix "8.2.10 Output ports"
(pass-if "open-bytevector-output-port"
(let-values (((port get-content)
(open-bytevector-output-port #f)))
(let ((source (make-bytevector 7777)))
(put-bytevector port source)
(and (bytevector=? (get-content) source)
(bytevector=? (get-content) (make-bytevector 0))))))
(pass-if "open-bytevector-output-port [put-u8]"
(let-values (((port get-content)
(open-bytevector-output-port)))
(put-u8 port 77)
(and (bytevector=? (get-content) (make-bytevector 1 77))
(bytevector=? (get-content) (make-bytevector 0)))))
(pass-if "open-bytevector-output-port [display]"
(let-values (((port get-content)
(open-bytevector-output-port)))
(display "hello" port)
(and (bytevector=? (get-content) (string->utf8 "hello"))
(bytevector=? (get-content) (make-bytevector 0)))))
(pass-if "bytevector output port supports `port-position'"
(let-values (((port get-content)
(open-bytevector-output-port)))
(let ((source (make-bytevector 7777))
(overwrite (make-bytevector 33)))
(and (port-has-port-position? port)
(port-has-set-port-position!? port)
(begin
(put-bytevector port source)
(= (bytevector-length source)
(port-position port)))
(begin
(set-port-position! port 10)
(= 10 (port-position port)))
(begin
(put-bytevector port overwrite)
(bytevector-copy! overwrite 0 source 10
(bytevector-length overwrite))
(= (port-position port)
(+ 10 (bytevector-length overwrite))))
(bytevector=? (get-content) source)
(bytevector=? (get-content) (make-bytevector 0))))))
(pass-if "make-custom-binary-output"
(let ((port (make-custom-binary-output-port "cbop"
(lambda (x y z) 0)
#f #f #f)))
(and (output-port? port)
(binary-port? port)
(not (port-has-port-position? port))
(not (port-has-set-port-position!? port)))))
(pass-if "make-custom-binary-output-port [partial writes]"
(let* ((source (uint-list->bytevector (iota 333)
(native-endianness) 2))
(sink (make-bytevector (bytevector-length source)))
(sink-pos 0)
(eof? #f)
(write! (lambda (bv start count)
(if (= 0 count)
(begin
(set! eof? #t)
0)
(let ((u8 (bytevector-u8-ref bv start)))
;; Get one byte at a time.
(bytevector-u8-set! sink sink-pos u8)
(set! sink-pos (+ 1 sink-pos))
1))))
(port (make-custom-binary-output-port "cbop" write!
#f #f #f)))
(put-bytevector port source)
(and (= sink-pos (bytevector-length source))
(not eof?)
(bytevector=? sink source))))
(pass-if "make-custom-binary-output-port [full writes]"
(let* ((source (uint-list->bytevector (iota 333)
(native-endianness) 2))
(sink (make-bytevector (bytevector-length source)))
(sink-pos 0)
(eof? #f)
(write! (lambda (bv start count)
(if (= 0 count)
(begin
(set! eof? #t)
0)
(begin
(bytevector-copy! bv start
sink sink-pos
count)
(set! sink-pos (+ sink-pos count))
count))))
(port (make-custom-binary-output-port "cbop" write!
#f #f #f)))
(put-bytevector port source)
(and (= sink-pos (bytevector-length source))
(not eof?)
(bytevector=? sink source)))))
;;; Local Variables:
;;; coding: latin-1
;;; mode: scheme
;;; End:

2
test-suite/tests/ramap.test
View file

@ -5,7 +5,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

46
test-suite/tests/reader.test
View file

@ -6,13 +6,13 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
@ -35,6 +35,8 @@
(cons 'read-error "end of file in string constant$"))
(define exception:illegal-escape
(cons 'read-error "illegal character in escape sequence: .*$"))
(define exception:missing-expression
(cons 'read-error "no expression after #;"))
(define (read-string s)
@ -165,6 +167,11 @@
(with-read-options '(keywords postfix)
(lambda ()
(read-string "keyword:")))))
(pass-if "long postfix keywords"
(eq? #:keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789
(with-read-options '(keywords postfix)
(lambda ()
(read-string "keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789:")))))
(pass-if "`:' is not a postfix keyword (per SRFI-88)"
(eq? ':
(with-read-options '(keywords postfix)
@ -189,3 +196,36 @@
(and (equal? (source-property sexp 'line) 0)
(equal? (source-property sexp 'column) 0)))))
(with-test-prefix "#;"
(for-each
(lambda (pair)
(pass-if (car pair)
(equal? (with-input-from-string (car pair) read) (cdr pair))))
'(("#;foo 10". 10)
("#;(10 20 30) foo" . foo)
("#; (10 20 30) foo" . foo)
("#;\n10\n20" . 20)))
(pass-if "#;foo"
(eof-object? (with-input-from-string "#;foo" read)))
(pass-if-exception "#;"
exception:missing-expression
(with-input-from-string "#;" read))
(pass-if-exception "#;("
exception:eof
(with-input-from-string "#;(" read)))
(with-test-prefix "#'"
(for-each
(lambda (pair)
(pass-if (car pair)
(equal? (with-input-from-string (car pair) read) (cdr pair))))
'(("#'foo". (syntax foo))
("#`foo" . (quasisyntax foo))
("#,foo" . (unsyntax foo))
("#,@foo" . (unsyntax-splicing foo)))))

25
test-suite/tests/receive.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 2004, 2006 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-receive)
#:use-module (test-suite lib)

21
test-suite/tests/regexp.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-regexp)
#:use-module (test-suite lib)

2
test-suite/tests/socket.test
View file

@ -5,7 +5,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

21
test-suite/tests/sort.test
View file

@ -1,20 +1,19 @@
;;;; sort.test --- tests Guile's sort functions -*- scheme -*-
;;;; Copyright (C) 2003, 2006, 2007 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (test-suite lib))

2
test-suite/tests/srcprop.test
View file

@ -5,7 +5,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

25
test-suite/tests/srfi-1.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright 2003, 2004, 2005, 2006, 2008 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-srfi-1)
#:use-module (test-suite lib)

21
test-suite/tests/srfi-10.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2001, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (srfi srfi-10))

25
test-suite/tests/srfi-11.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright 2004, 2006 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-srfi-11)
#:use-module (test-suite lib)

25
test-suite/tests/srfi-13.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2001, 2004, 2005, 2006 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-strings)
#:use-module (test-suite lib)

21
test-suite/tests/srfi-14.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2001, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-srfi-14)
:use-module (srfi srfi-14)

28
test-suite/tests/srfi-17.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 2001, 2003, 2005, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-srfi-17)
:use-module (test-suite lib)
@ -50,6 +49,9 @@
(define %some-variable #f)
(define exception:bad-quote
'(syntax-error . "quote: bad syntax"))
(with-test-prefix "set!"
(with-test-prefix "target is not procedure with setter"
@ -59,7 +61,7 @@
(set! (symbol->string 'x) 1))
(pass-if-exception "(set! '#f 1)"
exception:bad-variable
exception:bad-quote
(eval '(set! '#f 1) (interaction-environment))))
(with-test-prefix "target uses macro"
@ -72,7 +74,7 @@
;; The `(quote x)' below used to be memoized as an infinite list before
;; Guile 1.8.3.
(pass-if-exception "(set! 'x 1)"
exception:bad-variable
exception:bad-quote
(eval '(set! 'x 1) (interaction-environment)))))
;;

30
test-suite/tests/srfi-18.test
View file

@ -3,26 +3,30 @@
;;;;
;;;; Copyright (C) 2007, 2008 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-srfi-18)
#:use-module (test-suite lib))
(and (provided? 'threads)
(use-modules (srfi srfi-18))
;; two expressions so that the srfi-18 import is in effect for expansion
;; of the rest
(if (provided? 'threads)
(use-modules (srfi srfi-18)))
(and
(provided? 'threads)
(with-test-prefix "current-thread"

25
test-suite/tests/srfi-19.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007, 2008 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;; SRFI-19 overrides current-date, so we have to do the test in a
;; separate module, or later tests will fail.

4
test-suite/tests/srfi-31.test
View file

@ -5,7 +5,7 @@
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@ -23,7 +23,7 @@
(with-test-prefix "rec special form"
(pass-if-exception "bogus variable" '(misc-error . ".*")
(rec #:foo))
(sc-expand '(rec #:foo)))
(pass-if "rec expressions"
(let ((ones-list (rec ones (cons 1 (delay ones)))))

25
test-suite/tests/srfi-34.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 2003, 2004, 2006, 2008 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-srfi-34)
:duplicates (last) ;; avoid warning about srfi-34 replacing `raise'

25
test-suite/tests/srfi-35.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2007, 2008 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-srfi-35)
:use-module (test-suite lib)

25
test-suite/tests/srfi-37.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 2007, 2008 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-srfi-37)
#:use-module (test-suite lib)

21
test-suite/tests/srfi-39.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 2004, 2005, 2006, 2008 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-srfi-39)
#:use-module (test-suite lib)

21
test-suite/tests/srfi-4.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2001, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (srfi srfi-4)
(test-suite lib))

25
test-suite/tests/srfi-6.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 2003, 2006 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (test-suite lib))

25
test-suite/tests/srfi-60.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright 2005, 2006 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-srfi-60)
#:duplicates (last) ;; avoid warning about srfi-60 replacing `bit-count'

25
test-suite/tests/srfi-69.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 2007 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-srfi-69)
#:use-module (test-suite lib)

25
test-suite/tests/srfi-88.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2008 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-srfi-88)
:use-module (test-suite lib)

21
test-suite/tests/srfi-9.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2001, 2006, 2007 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-numbers)
#:use-module (test-suite lib)

37
test-suite/tests/srfi-98.test Normal file
View file

@ -0,0 +1,37 @@
;;;; srfi-98.test --- Test suite for Guile's SRFI-98 functions. -*- scheme -*-
;;;;
;;;; Copyright 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-srfi-98)
#:use-module (srfi srfi-98)
#:use-module (test-suite lib))
(with-test-prefix "get-environment-variable"
(pass-if "get-environment-variable retrieves binding"
(putenv "foo=bar")
(equal? (get-environment-variable "foo") "bar"))
(pass-if "get-environment-variable #f on unbound name"
(unsetenv "foo")
(not (get-environment-variable "foo"))))
(with-test-prefix "get-environment-variables"
(pass-if "get-environment-variables contains binding"
(putenv "foo=bar")
(equal? (assoc-ref (get-environment-variables) "foo") "bar")))

21
test-suite/tests/streams.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 2004, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-streams)
:use-module (test-suite lib)

275
test-suite/tests/strings.test
View file

@ -1,34 +1,238 @@
;;;; strings.test --- test suite for Guile's string functions -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- August 1999
;;;;
;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008, 2009 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-strings)
#:use-module (test-suite lib))
(define exception:read-only-string
(cons 'misc-error "^string is read-only"))
(define exception:illegal-escape
(cons 'read-error "illegal character in escape sequence"))
;; Create a string from integer char values, eg. (string-ints 65) => "A"
(define (string-ints . args)
(apply string (map integer->char args)))
;;
;; string internals
;;
;; Some abbreviations
;; BMP - Basic Multilingual Plane (codepoints below U+FFFF)
;; SMP - Suplementary Multilingual Plane (codebpoints from U+10000 to U+1FFFF)
(with-test-prefix "string internals"
(pass-if "new string starts at 1st char in stringbuf"
(let ((s "abc"))
(= 0 (assq-ref (%string-dump s) 'start))))
(pass-if "length of new string same as stringbuf"
(let ((s "def"))
(= (string-length s) (assq-ref (%string-dump s) 'stringbuf-length))))
(pass-if "contents of new string same as stringbuf"
(let ((s "ghi"))
(string=? s (assq-ref (%string-dump s) 'stringbuf-chars))))
(pass-if "writable strings are not read-only"
(let ((s "zyx"))
(not (assq-ref (%string-dump s) 'read-only))))
(pass-if "read-only strings are read-only"
(let ((s (substring/read-only "zyx" 0)))
(assq-ref (%string-dump s) 'read-only)))
(pass-if "null strings are inlined"
(let ((s ""))
(assq-ref (%string-dump s) 'stringbuf-inline)))
(pass-if "short Latin-1 encoded strings are inlined"
(let ((s "m"))
(assq-ref (%string-dump s) 'stringbuf-inline)))
(pass-if "long Latin-1 encoded strings are not inlined"
(let ((s "0123456789012345678901234567890123456789"))
(not (assq-ref (%string-dump s) 'stringbuf-inline))))
(pass-if "short UCS-4 encoded strings are not inlined"
(let ((s "\u0100"))
(not (assq-ref (%string-dump s) 'stringbuf-inline))))
(pass-if "long UCS-4 encoded strings are not inlined"
(let ((s "\u010012345678901234567890123456789"))
(not (assq-ref (%string-dump s) 'stringbuf-inline))))
(pass-if "new Latin-1 encoded strings are not shared"
(let ((s "abc"))
(not (assq-ref (%string-dump s) 'stringbuf-shared))))
(pass-if "new UCS-4 encoded strings are not shared"
(let ((s "\u0100bc"))
(not (assq-ref (%string-dump s) 'stringbuf-shared))))
;; Should this be true? It isn't currently true.
(pass-if "null shared substrings are shared"
(let* ((s1 "")
(s2 (substring/shared s1 0 0)))
(throw 'untested)
(eq? (assq-ref (%string-dump s2) 'shared)
s1)))
(pass-if "ASCII shared substrings are shared"
(let* ((s1 "foobar")
(s2 (substring/shared s1 0 3)))
(eq? (assq-ref (%string-dump s2) 'shared)
s1)))
(pass-if "BMP shared substrings are shared"
(let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105")
(s2 (substring/shared s1 0 3)))
(eq? (assq-ref (%string-dump s2) 'shared)
s1)))
(pass-if "null substrings are not shared"
(let* ((s1 "")
(s2 (substring s1 0 0)))
(not (eq? (assq-ref (%string-dump s2) 'shared)
s1))))
(pass-if "ASCII substrings are not shared"
(let* ((s1 "foobar")
(s2 (substring s1 0 3)))
(not (eq? (assq-ref (%string-dump s2) 'shared)
s1))))
(pass-if "BMP substrings are not shared"
(let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105")
(s2 (substring s1 0 3)))
(not (eq? (assq-ref (%string-dump s2) 'shared)
s1))))
(pass-if "ASCII substrings share stringbufs before copy-on-write"
(let* ((s1 "foobar")
(s2 (substring s1 0 3)))
(assq-ref (%string-dump s1) 'stringbuf-shared)))
(pass-if "BMP substrings share stringbufs before copy-on-write"
(let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105")
(s2 (substring s1 0 3)))
(assq-ref (%string-dump s1) 'stringbuf-shared)))
(pass-if "ASCII substrings don't share stringbufs after copy-on-write"
(let* ((s1 "foobar")
(s2 (substring s1 0 3)))
(string-set! s2 0 #\F)
(not (assq-ref (%string-dump s2) 'stringbuf-shared))))
(pass-if "BMP substrings don't share stringbufs after copy-on-write"
(let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105")
(s2 (substring s1 0 3)))
(string-set! s2 0 #\F)
(not (assq-ref (%string-dump s2) 'stringbuf-shared))))
(with-test-prefix "encodings"
(pass-if "null strings are Latin-1 encoded"
(let ((s ""))
(not (assq-ref (%string-dump s) 'stringbuf-wide))))
(pass-if "ASCII strings are Latin-1 encoded"
(let ((s "jkl"))
(not (assq-ref (%string-dump s) 'stringbuf-wide))))
(pass-if "Latin-1 strings are Latin-1 encoded"
(let ((s "\xC0\xC1\xC2"))
(not (assq-ref (%string-dump s) 'stringbuf-wide))))
(pass-if "BMP strings are UCS-4 encoded"
(let ((s "\u0100\u0101\x0102"))
(assq-ref (%string-dump s) 'stringbuf-wide)))
(pass-if "SMP strings are UCS-4 encoded"
(let ((s "\U010300\u010301\x010302"))
(assq-ref (%string-dump s) 'stringbuf-wide)))
(pass-if "null list->string is Latin-1 encoded"
(let ((s (string-ints)))
(not (assq-ref (%string-dump s) 'stringbuf-wide))))
(pass-if "ASCII list->string is Latin-1 encoded"
(let ((s (string-ints 65 66 67)))
(not (assq-ref (%string-dump s) 'stringbuf-wide))))
(pass-if "Latin-1 list->string is Latin-1 encoded"
(let ((s (string-ints #xc0 #xc1 #xc2)))
(not (assq-ref (%string-dump s) 'stringbuf-wide))))
(pass-if "BMP list->string is UCS-4 encoded"
(let ((s (string-ints #x0100 #x0101 #x0102)))
(assq-ref (%string-dump s) 'stringbuf-wide)))
(pass-if "SMP list->string is UCS-4 encoded"
(let ((s (string-ints #x010300 #x010301 #x010302)))
(assq-ref (%string-dump s) 'stringbuf-wide)))
(pass-if "encoding of string not based on escape style"
(let ((s "\U000040"))
(not (assq-ref (%string-dump s) 'stringbuf-wide))))))
(with-test-prefix "hex escapes"
(pass-if-exception "non-hex char in two-digit hex-escape"
exception:illegal-escape
(with-input-from-string "\"\\x0g\"" read))
(pass-if-exception "non-hex char in four-digit hex-escape"
exception:illegal-escape
(with-input-from-string "\"\\u000g\"" read))
(pass-if-exception "non-hex char in six-digit hex-escape"
exception:illegal-escape
(with-input-from-string "\"\\U00000g\"" read))
(pass-if-exception "premature termination of two-digit hex-escape"
exception:illegal-escape
(with-input-from-string "\"\\x0\"" read))
(pass-if-exception "premature termination of four-digit hex-escape"
exception:illegal-escape
(with-input-from-string "\"\\u000\"" read))
(pass-if-exception "premature termination of six-digit hex-escape"
exception:illegal-escape
(with-input-from-string "\"\\U00000\"" read))
(pass-if "extra hex digits ignored for two-digit hex escape"
(eqv? (string-ref "--\xfff--" 2)
(integer->char #xff)))
(pass-if "extra hex digits ignored for four-digit hex escape"
(eqv? (string-ref "--\u0100f--" 2)
(integer->char #x0100)))
(pass-if "extra hex digits ignored for six-digit hex escape"
(eqv? (string-ref "--\U010300f--" 2)
(integer->char #x010300)))
(pass-if "escaped characters match non-escaped ASCII characters"
(string=? "ABC" "\x41\u0042\U000043")))
;;
;; string=?
@ -182,8 +386,20 @@
exception:out-of-range
(string-ref "hello" -1))
(pass-if "regular string"
(char=? (string-ref "GNU Guile" 4) #\G)))
(pass-if "regular string, ASCII char"
(char=? (string-ref "GNU Guile" 4) #\G))
(pass-if "regular string, hex escaped Latin-1 char"
(char=? (string-ref "--\xff--" 2)
(integer->char #xff)))
(pass-if "regular string, hex escaped BMP char"
(char=? (string-ref "--\u0100--" 2)
(integer->char #x0100)))
(pass-if "regular string, hex escaped SMP char"
(char=? (string-ref "--\U010300--" 2)
(integer->char #x010300))))
;;
;; string-set!
@ -211,12 +427,37 @@
exception:read-only-string
(string-set! (substring/read-only "abc" 0) 1 #\space))
(pass-if "regular string"
(pass-if "regular string, ASCII char"
(let ((s (string-copy "GNU guile")))
(string-set! s 4 #\G)
(char=? (string-ref s 4) #\G))))
(char=? (string-ref s 4) #\G)))
(pass-if "regular string, Latin-1 char"
(let ((s (string-copy "GNU guile")))
(string-set! s 4 (integer->char #xfe))
(char=? (string-ref s 4) (integer->char #xfe))))
(pass-if "regular string, BMP char"
(let ((s (string-copy "GNU guile")))
(string-set! s 4 (integer->char #x0100))
(char=? (string-ref s 4) (integer->char #x0100))))
(pass-if "regular string, SMP char"
(let ((s (string-copy "GNU guile")))
(string-set! s 4 (integer->char #x010300))
(char=? (string-ref s 4) (integer->char #x010300)))))
;;
;; list->string
;;
(with-test-prefix "string"
(pass-if-exception "convert circular list to string"
exception:wrong-type-arg
(let ((foo (list #\a #\b #\c)))
(set-cdr! (cddr foo) (cdr foo))
(apply string foo))))
(with-test-prefix "string-split"
;; in guile 1.6.7 and earlier, character >=128 wasn't matched in the string

25
test-suite/tests/structs.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 2006, 2007 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-structs)
:use-module (test-suite lib))

101
test-suite/tests/symbols.test
View file

@ -1,21 +1,20 @@
;;;; symbols.test --- test suite for Guile's symbols -*- scheme -*-
;;;;
;;;; Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
;;;; Copyright (C) 2001, 2006, 2008, 2009 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-symbols)
#:use-module (test-suite lib)
@ -32,6 +31,84 @@
(define (documented? object)
(not (not (object-documentation object))))
(define (symbol-length s)
(string-length (symbol->string s)))
;;
;; symbol internals
;;
(with-test-prefix "symbol internals"
(pass-if "length of new symbol same as stringbuf"
(let ((s 'def))
(= (symbol-length s) (assq-ref (%symbol-dump s) 'stringbuf-length))))
(pass-if "contents of new symbol same as stringbuf"
(let ((s 'ghi))
(string=? (symbol->string s)
(assq-ref (%symbol-dump s) 'stringbuf-chars))))
(pass-if "the null symbol is inlined"
(let ((s '#{}#))
(assq-ref (%symbol-dump s) 'stringbuf-inline)))
(pass-if "short Latin-1-encoded symbols are inlined"
(let ((s 'm))
(assq-ref (%symbol-dump s) 'stringbuf-inline)))
(pass-if "long Latin-1-encoded symbols are not inlined"
(let ((s 'x0123456789012345678901234567890123456789))
(not (assq-ref (%symbol-dump s) 'stringbuf-inline))))
;; symbol->string isn't ready for UCS-4 yet
;;(pass-if "short UCS-4-encoded symbols are not inlined"
;; (let ((s (string->symbol "\u0100")))
;; (not (assq-ref (%symbol-dump s) 'stringbuf-inline))))
;;(pass-if "long UCS-4-encoded symbols are not inlined"
;; (let ((s (string->symbol "\u010012345678901234567890123456789")))
;; (not (assq-ref (%symbol-dump s) 'stringbuf-inline))))
(with-test-prefix "hashes"
(pass-if "equal symbols have equal hashes"
(let ((s1 'mux)
(s2 'mux))
(= (assq-ref (%symbol-dump s1) 'hash)
(assq-ref (%symbol-dump s2) 'hash))))
(pass-if "different symbols have different hashes"
(let ((s1 'mux)
(s2 'muy))
(not (= (assq-ref (%symbol-dump s1) 'hash)
(assq-ref (%symbol-dump s2) 'hash))))))
(with-test-prefix "encodings"
(pass-if "the null symbol is Latin-1 encoded"
(let ((s '#{}#))
(not (assq-ref (%symbol-dump s) 'stringbuf-wide))))
(pass-if "ASCII symbols are Latin-1 encoded"
(let ((s 'jkl))
(not (assq-ref (%symbol-dump s) 'stringbuf-wide))))
(pass-if "Latin-1 symbols are Latin-1 encoded"
(let ((s (string->symbol "\xC0\xC1\xC2")))
(not (assq-ref (%symbol-dump s) 'stringbuf-wide))))
;; symbol->string isn't ready for UCS-4 yet
;;(pass-if "BMP symbols are UCS-4 encoded"
;; (let ((s (string->symbol "\u0100\u0101\x0102")))
;; (assq-ref (%symbol-dump s) 'stringbuf-wide)))
;;(pass-if "SMP symbols are UCS-4 encoded"
;; (let ((s (string->symbol "\U010300\u010301\x010302")))
;; (assq-ref (%symbol-dump s) 'stringbuf-wide)))
))
;;;
;;; symbol?

21
test-suite/tests/syncase.test
View file

@ -2,20 +2,19 @@
;;;;
;;;; Copyright (C) 2001, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;; These tests are in a module so that the syntax transformer does not
;; affect code outside of this file.

435
test-suite/tests/syntax.test
View file

@ -2,25 +2,29 @@
;;;;
;;;; Copyright (C) 2001,2003,2004, 2005, 2006 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-syntax)
:use-module (test-suite lib))
(define exception:generic-syncase-error
(cons 'syntax-error "source expression failed to match"))
(define exception:unexpected-syntax
(cons 'syntax-error "unexpected syntax"))
(define exception:bad-expression
(cons 'syntax-error "Bad expression"))
@ -29,22 +33,32 @@
(define exception:missing-expr
(cons 'syntax-error "Missing expression"))
(define exception:missing-body-expr
(cons 'syntax-error "Missing body expression"))
(cons 'syntax-error "no expressions in body"))
(define exception:extra-expr
(cons 'syntax-error "Extra expression"))
(define exception:illegal-empty-combination
(cons 'syntax-error "Illegal empty combination"))
(define exception:bad-lambda
'(syntax-error . "bad lambda"))
(define exception:bad-let
'(syntax-error . "bad let "))
(define exception:bad-letrec
'(syntax-error . "bad letrec "))
(define exception:bad-set!
'(syntax-error . "bad set!"))
(define exception:bad-quote
'(syntax-error . "quote: bad syntax"))
(define exception:bad-bindings
(cons 'syntax-error "Bad bindings"))
(define exception:bad-binding
(cons 'syntax-error "Bad binding"))
(define exception:duplicate-binding
(cons 'syntax-error "Duplicate binding"))
(cons 'syntax-error "duplicate bound variable"))
(define exception:bad-body
(cons 'misc-error "^bad body"))
(define exception:bad-formals
(cons 'syntax-error "Bad formals"))
'(syntax-error . "invalid parameter list"))
(define exception:bad-formal
(cons 'syntax-error "Bad formal"))
(define exception:duplicate-formal
@ -67,13 +81,13 @@
(with-test-prefix "Bad argument list"
(pass-if-exception "improper argument list of length 1"
exception:wrong-num-args
exception:generic-syncase-error
(eval '(let ((foo (lambda (x y) #t)))
(foo . 1))
(interaction-environment)))
(pass-if-exception "improper argument list of length 2"
exception:wrong-num-args
exception:generic-syncase-error
(eval '(let ((foo (lambda (x y) #t)))
(foo 1 . 2))
(interaction-environment))))
@ -88,7 +102,7 @@
;; Fixed on 2001-3-3
(pass-if-exception "empty parentheses \"()\""
exception:illegal-empty-combination
exception:unexpected-syntax
(eval '()
(interaction-environment)))))
@ -106,28 +120,32 @@
(with-test-prefix "unquote-splicing"
(pass-if-exception "extra arguments"
exception:missing/extra-expr
(quasiquote ((unquote-splicing (list 1 2) (list 3 4)))))))
'(syntax-error . "unquote-splicing takes exactly one argument")
(eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4))))
(interaction-environment)))))
(with-test-prefix "begin"
(pass-if "legal (begin)"
(begin)
#t)
(eval '(begin (begin) #t) (interaction-environment)))
(with-test-prefix "unmemoization"
;; FIXME. I have no idea why, but the expander is filling in (if #f
;; #f) as the second arm of the if, if the second arm is missing. I
;; thought I made it not do that. But in the meantime, let's adapt,
;; since that's not what we're testing.
(pass-if "normal begin"
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))
(foo) ; make sure, memoization has been performed
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))
(equal? (procedure-source foo)
'(lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))))
'(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))))
(pass-if "redundant nested begin"
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))))
'(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f)))))
(pass-if "redundant begin at start of body"
(let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
@ -135,10 +153,20 @@
(equal? (procedure-source foo)
'(lambda () (begin (+ 1) (+ 2)))))))
(expect-fail-exception "illegal (begin)"
exception:bad-body
(if #t (begin))
#t))
(pass-if-exception "illegal (begin)"
exception:generic-syncase-error
(eval '(begin (if #t (begin)) #t) (interaction-environment))))
(define-syntax matches?
(syntax-rules (_)
((_ (op arg ...) pat) (let ((x (op arg ...)))
(matches? x pat)))
((_ x ()) (null? x))
((_ x (a . b)) (and (pair? x)
(matches? (car x) a)
(matches? (cdr x) b)))
((_ x _) #t)
((_ x pat) (equal? x 'pat))))
(with-test-prefix "lambda"
@ -146,30 +174,28 @@
(pass-if "normal lambda"
(let ((foo (lambda () (lambda (x y) (+ x y)))))
((foo) 1 2) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (lambda (x y) (+ x y))))))
(matches? (procedure-source foo)
(lambda () (lambda (_ _) (+ _ _))))))
(pass-if "lambda with documentation"
(let ((foo (lambda () (lambda (x y) "docstring" (+ x y)))))
((foo) 1 2) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (lambda (x y) "docstring" (+ x y)))))))
(matches? (procedure-source foo)
(lambda () (lambda (_ _) "docstring" (+ _ _)))))))
(with-test-prefix "bad formals"
(pass-if-exception "(lambda)"
exception:missing-expr
exception:bad-lambda
(eval '(lambda)
(interaction-environment)))
(pass-if-exception "(lambda . \"foo\")"
exception:bad-expression
exception:bad-lambda
(eval '(lambda . "foo")
(interaction-environment)))
(pass-if-exception "(lambda \"foo\")"
exception:missing-expr
exception:bad-lambda
(eval '(lambda "foo")
(interaction-environment)))
@ -179,22 +205,22 @@
(interaction-environment)))
(pass-if-exception "(lambda (x 1) 2)"
exception:bad-formal
exception:bad-formals
(eval '(lambda (x 1) 2)
(interaction-environment)))
(pass-if-exception "(lambda (1 x) 2)"
exception:bad-formal
exception:bad-formals
(eval '(lambda (1 x) 2)
(interaction-environment)))
(pass-if-exception "(lambda (x \"a\") 2)"
exception:bad-formal
exception:bad-formals
(eval '(lambda (x "a") 2)
(interaction-environment)))
(pass-if-exception "(lambda (\"a\" x) 2)"
exception:bad-formal
exception:bad-formals
(eval '(lambda ("a" x) 2)
(interaction-environment))))
@ -202,20 +228,20 @@
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x) 1)"
exception:duplicate-formal
exception:bad-formals
(eval '(lambda (x x) 1)
(interaction-environment)))
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x x) 1)"
exception:duplicate-formal
exception:bad-formals
(eval '(lambda (x x x) 1)
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(lambda ())"
exception:missing-expr
exception:bad-lambda
(eval '(lambda ())
(interaction-environment)))))
@ -225,9 +251,8 @@
(pass-if "normal let"
(let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (let ((i 1) (j 2)) (+ i j)))))))
(matches? (procedure-source foo)
(lambda () (let ((_ 1) (_ 2)) (+ _ _)))))))
(with-test-prefix "bindings"
@ -238,42 +263,42 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let)"
exception:missing-expr
exception:bad-let
(eval '(let)
(interaction-environment)))
(pass-if-exception "(let 1)"
exception:missing-expr
exception:bad-let
(eval '(let 1)
(interaction-environment)))
(pass-if-exception "(let (x))"
exception:missing-expr
exception:bad-let
(eval '(let (x))
(interaction-environment)))
(pass-if-exception "(let ((x)))"
exception:missing-expr
exception:bad-let
(eval '(let ((x)))
(interaction-environment)))
(pass-if-exception "(let (x) 1)"
exception:bad-binding
exception:bad-let
(eval '(let (x) 1)
(interaction-environment)))
(pass-if-exception "(let ((x)) 3)"
exception:bad-binding
exception:bad-let
(eval '(let ((x)) 3)
(interaction-environment)))
(pass-if-exception "(let ((x 1) y) x)"
exception:bad-binding
exception:bad-let
(eval '(let ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(let ((1 2)) 3)"
exception:bad-variable
exception:bad-let
(eval '(let ((1 2)) 3)
(interaction-environment))))
@ -287,12 +312,12 @@
(with-test-prefix "bad body"
(pass-if-exception "(let ())"
exception:missing-expr
exception:bad-let
(eval '(let ())
(interaction-environment)))
(pass-if-exception "(let ((x 1)))"
exception:missing-expr
exception:bad-let
(eval '(let ((x 1)))
(interaction-environment)))))
@ -307,19 +332,19 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let x (y))"
exception:missing-expr
exception:bad-let
(eval '(let x (y))
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(let x ())"
exception:missing-expr
exception:bad-let
(eval '(let x ())
(interaction-environment)))
(pass-if-exception "(let x ((y 1)))"
exception:missing-expr
exception:bad-let
(eval '(let x ((y 1)))
(interaction-environment)))))
@ -329,19 +354,16 @@
(pass-if "normal let*"
(let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (let* ((x 1) (y 2)) (+ x y))))))
(matches? (procedure-source foo)
(lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _)))))))
(pass-if "let* without bindings"
(let ((foo (lambda () (let ((x 1) (y 2))
(let* ()
(and (= x 1) (= y 2)))))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (let ((x 1) (y 2))
(let* ()
(and (= x 1) (= y 2)))))))))
(matches? (procedure-source foo)
(lambda () (let ((_ 1) (_ 2))
(if (= _ 1) (= _ 2) #f)))))))
(with-test-prefix "bindings"
@ -361,59 +383,59 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let*)"
exception:missing-expr
exception:generic-syncase-error
(eval '(let*)
(interaction-environment)))
(pass-if-exception "(let* 1)"
exception:missing-expr
exception:generic-syncase-error
(eval '(let* 1)
(interaction-environment)))
(pass-if-exception "(let* (x))"
exception:missing-expr
exception:generic-syncase-error
(eval '(let* (x))
(interaction-environment)))
(pass-if-exception "(let* (x) 1)"
exception:bad-binding
exception:generic-syncase-error
(eval '(let* (x) 1)
(interaction-environment)))
(pass-if-exception "(let* ((x)) 3)"
exception:bad-binding
exception:generic-syncase-error
(eval '(let* ((x)) 3)
(interaction-environment)))
(pass-if-exception "(let* ((x 1) y) x)"
exception:bad-binding
exception:generic-syncase-error
(eval '(let* ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(let* x ())"
exception:bad-bindings
exception:generic-syncase-error
(eval '(let* x ())
(interaction-environment)))
(pass-if-exception "(let* x (y))"
exception:bad-bindings
exception:generic-syncase-error
(eval '(let* x (y))
(interaction-environment)))
(pass-if-exception "(let* ((1 2)) 3)"
exception:bad-variable
exception:generic-syncase-error
(eval '(let* ((1 2)) 3)
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(let* ())"
exception:missing-expr
exception:generic-syncase-error
(eval '(let* ())
(interaction-environment)))
(pass-if-exception "(let* ((x 1)))"
exception:missing-expr
exception:generic-syncase-error
(eval '(let* ((x 1)))
(interaction-environment)))))
@ -423,9 +445,8 @@
(pass-if "normal letrec"
(let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (letrec ((i 1) (j 2)) (+ i j)))))))
(matches? (procedure-source foo)
(lambda () (letrec ((_ 1) (_ 2)) (+ _ _)))))))
(with-test-prefix "bindings"
@ -437,47 +458,47 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(letrec)"
exception:missing-expr
exception:bad-letrec
(eval '(letrec)
(interaction-environment)))
(pass-if-exception "(letrec 1)"
exception:missing-expr
exception:bad-letrec
(eval '(letrec 1)
(interaction-environment)))
(pass-if-exception "(letrec (x))"
exception:missing-expr
exception:bad-letrec
(eval '(letrec (x))
(interaction-environment)))
(pass-if-exception "(letrec (x) 1)"
exception:bad-binding
exception:bad-letrec
(eval '(letrec (x) 1)
(interaction-environment)))
(pass-if-exception "(letrec ((x)) 3)"
exception:bad-binding
exception:bad-letrec
(eval '(letrec ((x)) 3)
(interaction-environment)))
(pass-if-exception "(letrec ((x 1) y) x)"
exception:bad-binding
exception:bad-letrec
(eval '(letrec ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(letrec x ())"
exception:bad-bindings
exception:bad-letrec
(eval '(letrec x ())
(interaction-environment)))
(pass-if-exception "(letrec x (y))"
exception:bad-bindings
exception:bad-letrec
(eval '(letrec x (y))
(interaction-environment)))
(pass-if-exception "(letrec ((1 2)) 3)"
exception:bad-variable
exception:bad-letrec
(eval '(letrec ((1 2)) 3)
(interaction-environment))))
@ -491,12 +512,12 @@
(with-test-prefix "bad body"
(pass-if-exception "(letrec ())"
exception:missing-expr
exception:bad-letrec
(eval '(letrec ())
(interaction-environment)))
(pass-if-exception "(letrec ((x 1)))"
exception:missing-expr
exception:bad-letrec
(eval '(letrec ((x 1)))
(interaction-environment)))))
@ -508,17 +529,17 @@
(let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
(foo #t) ; make sure, memoization has been performed
(foo #f) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (if x (+ 1) (+ 2))))))
(matches? (procedure-source foo)
(lambda (_) (if _ (+ 1) (+ 2))))))
(pass-if "if without else"
(expect-fail "if without else"
(let ((foo (lambda (x) (if x (+ 1)))))
(foo #t) ; make sure, memoization has been performed
(foo #f) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (if x (+ 1))))))
(pass-if "if #f without else"
(expect-fail "if #f without else"
(let ((foo (lambda () (if #f #f))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
@ -527,12 +548,12 @@
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(if)"
exception:missing/extra-expr
exception:generic-syncase-error
(eval '(if)
(interaction-environment)))
(pass-if-exception "(if 1 2 3 4)"
exception:missing/extra-expr
exception:generic-syncase-error
(eval '(if 1 2 3 4)
(interaction-environment)))))
@ -594,78 +615,77 @@
(eq? 'ok (cond (#t identity =>) (else #f)))))
(pass-if-exception "missing recipient"
'(syntax-error . "Missing recipient")
'(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity =>)))
(pass-if-exception "extra recipient"
'(syntax-error . "Extra expression")
'(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity => identity identity))))
(with-test-prefix "unmemoization"
;; FIXME: the (if #f #f) is a hack!
(pass-if "normal clauses"
(let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
(foo 1) ; make sure, memoization has been performed
(foo 2) ; make sure, memoization has been performed
(let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
(equal? (procedure-source foo)
'(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))))
'(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f)))))))
(pass-if "else"
(let ((foo (lambda () (cond (else 'bar)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (cond (else 'bar))))))
'(lambda () 'bar))))
;; FIXME: the (if #f #f) is a hack!
(pass-if "=>"
(let ((foo (lambda () (cond (#t => identity)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (cond (#t => identity)))))))
(matches? (procedure-source foo)
(lambda () (let ((_ #t))
(if _ (identity _) (if #f #f))))))))
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(cond)"
exception:missing-clauses
exception:generic-syncase-error
(eval '(cond)
(interaction-environment)))
(pass-if-exception "(cond #t)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond #t)
(interaction-environment)))
(pass-if-exception "(cond 1)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond 1)
(interaction-environment)))
(pass-if-exception "(cond 1 2)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond 1 2)
(interaction-environment)))
(pass-if-exception "(cond 1 2 3)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond 1 2 3)
(interaction-environment)))
(pass-if-exception "(cond 1 2 3 4)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond 1 2 3 4)
(interaction-environment)))
(pass-if-exception "(cond ())"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond ())
(interaction-environment)))
(pass-if-exception "(cond () 1)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond () 1)
(interaction-environment)))
(pass-if-exception "(cond (1) 1)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond (1) 1)
(interaction-environment))))
@ -683,7 +703,7 @@
(with-test-prefix "case is hygienic"
(pass-if-exception "bound 'else is handled correctly"
exception:bad-case-labels
exception:generic-syncase-error
(eval '(let ((else #f)) (case 1 (else #f)))
(interaction-environment))))
@ -691,79 +711,83 @@
(pass-if "normal clauses"
(let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
(foo 1) ; make sure, memoization has been performed
(foo 2) ; make sure, memoization has been performed
(foo 3) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))))
(matches? (procedure-source foo)
(lambda (_)
(if ((@@ (guile) memv) _ '(1))
'bar
(if ((@@ (guile) memv) _ '(2))
'baz
'foobar))))))
(pass-if "empty labels"
(let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
(foo 1) ; make sure, memoization has been performed
(foo 2) ; make sure, memoization has been performed
(foo 3) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))))
(matches? (procedure-source foo)
(lambda (_)
(if ((@@ (guile) memv) _ '(1))
'bar
(if ((@@ (guile) memv) _ '())
'baz
'foobar)))))))
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(case)"
exception:missing-clauses
exception:generic-syncase-error
(eval '(case)
(interaction-environment)))
(pass-if-exception "(case . \"foo\")"
exception:bad-expression
exception:generic-syncase-error
(eval '(case . "foo")
(interaction-environment)))
(pass-if-exception "(case 1)"
exception:missing-clauses
exception:generic-syncase-error
(eval '(case 1)
(interaction-environment)))
(pass-if-exception "(case 1 . \"foo\")"
exception:bad-expression
exception:generic-syncase-error
(eval '(case 1 . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 \"foo\")"
exception:bad-case-clause
exception:generic-syncase-error
(eval '(case 1 "foo")
(interaction-environment)))
(pass-if-exception "(case 1 ())"
exception:bad-case-clause
exception:generic-syncase-error
(eval '(case 1 ())
(interaction-environment)))
(pass-if-exception "(case 1 (\"foo\"))"
exception:bad-case-clause
exception:generic-syncase-error
(eval '(case 1 ("foo"))
(interaction-environment)))
(pass-if-exception "(case 1 (\"foo\" \"bar\"))"
exception:bad-case-labels
exception:generic-syncase-error
(eval '(case 1 ("foo" "bar"))
(interaction-environment)))
(pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
exception:bad-expression
exception:generic-syncase-error
(eval '(case 1 ((2) "bar") . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 ((2) \"bar\") (else))"
exception:bad-case-clause
exception:generic-syncase-error
(eval '(case 1 ((2) "bar") (else))
(interaction-environment)))
(pass-if-exception "(case 1 (else #f) . \"foo\")"
exception:bad-expression
exception:generic-syncase-error
(eval '(case 1 (else #f) . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 (else #f) ((1) #t))"
exception:misplaced-else-clause
exception:generic-syncase-error
(eval '(case 1 (else #f) ((1) #t))
(interaction-environment)))))
@ -780,14 +804,6 @@
(eval '(define round round) m)
(eq? (module-ref m 'round) round)))
(with-test-prefix "currying"
(pass-if "(define ((foo)) #f)"
(eval '(begin
(define ((foo)) #t)
((foo)))
(interaction-environment))))
(with-test-prefix "unmemoization"
(pass-if "definition unmemoized without prior execution"
@ -809,7 +825,7 @@
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(define)"
exception:missing-expr
exception:generic-syncase-error
(eval '(define)
(interaction-environment)))))
@ -886,34 +902,10 @@
'ok)
(bar))
(foo)
(equal?
(matches?
(procedure-source foo)
'(lambda () (letrec ((bar (lambda () (quote ok)))) (bar)))))
(interaction-environment))))
(with-test-prefix "do"
(with-test-prefix "unmemoization"
(pass-if "normal case"
(let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2))
((> i 9) (+ i j))
(identity i)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (do ((i 1 (+ i 1)) (j 2))
((> i 9) (+ i j))
(identity i))))))
(pass-if "reduced case"
(let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j
((> i 9) (+ i j))
(identity i)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here
((> i 9) (+ i j))
(identity i))))))))
(lambda () (letrec ((_ (lambda () (quote ok)))) (_)))))
(current-module))))
(with-test-prefix "set!"
@ -922,50 +914,50 @@
(pass-if "normal set!"
(let ((foo (lambda (x) (set! x (+ 1 x)))))
(foo 1) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (set! x (+ 1 x)))))))
(matches? (procedure-source foo)
(lambda (_) (set! _ (+ 1 _)))))))
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(set!)"
exception:missing/extra-expr
exception:bad-set!
(eval '(set!)
(interaction-environment)))
(pass-if-exception "(set! 1)"
exception:missing/extra-expr
exception:bad-set!
(eval '(set! 1)
(interaction-environment)))
(pass-if-exception "(set! 1 2 3)"
exception:missing/extra-expr
exception:bad-set!
(eval '(set! 1 2 3)
(interaction-environment))))
(with-test-prefix "bad variable"
(pass-if-exception "(set! \"\" #t)"
exception:bad-variable
exception:bad-set!
(eval '(set! "" #t)
(interaction-environment)))
(pass-if-exception "(set! 1 #t)"
exception:bad-variable
exception:bad-set!
(eval '(set! 1 #t)
(interaction-environment)))
(pass-if-exception "(set! #t #f)"
exception:bad-variable
exception:bad-set!
(eval '(set! #t #f)
(interaction-environment)))
(pass-if-exception "(set! #f #t)"
exception:bad-variable
exception:bad-set!
(eval '(set! #f #t)
(interaction-environment)))
(pass-if-exception "(set! #\\space #f)"
exception:bad-variable
exception:bad-set!
(eval '(set! #\space #f)
(interaction-environment)))))
@ -974,12 +966,12 @@
(with-test-prefix "missing or extra expression"
(pass-if-exception "(quote)"
exception:missing/extra-expr
exception:bad-quote
(eval '(quote)
(interaction-environment)))
(pass-if-exception "(quote a b)"
exception:missing/extra-expr
exception:bad-quote
(eval '(quote a b)
(interaction-environment)))))
@ -1010,46 +1002,27 @@
(do ((n 0 (1+ n)))
((> n 5))
(pass-if n
(let ((cond (make-iterations-cond n)))
(while (cond)))
#t)))
(eval `(letrec ((make-iterations-cond
(lambda (n)
(lambda ()
(cond ((not n)
(error "oops, condition re-tested after giving false"))
((= 0 n)
(set! n #f)
#f)
(else
(set! n (1- n))
#t))))))
(let ((cond (make-iterations-cond ,n)))
(while (cond))
#t))
(interaction-environment)))))
(pass-if "initially false"
(while #f
(unreachable))
#t)
(with-test-prefix "in empty environment"
;; an environment with no bindings at all
(define empty-environment
(make-module 1))
;; these tests are 'unresolved because to work with ice-9 syncase it was
;; necessary to drop the unquote from `do' in the implementation, and
;; unfortunately that makes `while' depend on its evaluation environment
(pass-if "empty body"
(throw 'unresolved)
(eval `(,while #f)
empty-environment)
#t)
(pass-if "initially false"
(throw 'unresolved)
(eval `(,while #f
#f)
empty-environment)
#t)
(pass-if "iterating"
(throw 'unresolved)
(let ((cond (make-iterations-cond 3)))
(eval `(,while (,cond)
123 456)
empty-environment))
#t))
(with-test-prefix "iterations"
(do ((n 0 (1+ n)))
((> n 5))
@ -1063,8 +1036,9 @@
(with-test-prefix "break"
(pass-if-exception "too many args" exception:wrong-num-args
(while #t
(break 1)))
(eval '(while #t
(break 1))
(interaction-environment)))
(with-test-prefix "from cond"
(pass-if "first"
@ -1135,8 +1109,9 @@
(with-test-prefix "continue"
(pass-if-exception "too many args" exception:wrong-num-args
(while #t
(continue 1)))
(eval '(while #t
(continue 1))
(interaction-environment)))
(with-test-prefix "from cond"
(do ((n 0 (1+ n)))

92
test-suite/tests/threads.test
View file

@ -2,25 +2,38 @@
;;;;
;;;; Copyright 2003, 2006, 2007 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,
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-threads)
:use-module (ice-9 threads)
:use-module (test-suite lib))
(define (asyncs-still-working?)
(let ((a #f))
(system-async-mark (lambda ()
(set! a #t)))
;; The point of the following (equal? ...) is to go through
;; primitive code (scm_equal_p) that includes a SCM_TICK call and
;; hence gives system asyncs a chance to run. Of course the
;; evaluator (eval.i.c) also calls SCM_TICK regularly, but in the
;; near future we may be using the VM instead of the traditional
;; compiler, and then we will still want asyncs-still-working? to
;; work. (The VM should probably have SCM_TICK calls too, but
;; let's not rely on that here.)
(equal? '(a b c) '(a b c))
a))
(if (provided? 'threads)
(begin
@ -101,6 +114,9 @@
(with-test-prefix "n-for-each-par-map"
(pass-if "asyncs are still working 2"
(asyncs-still-working?))
(pass-if "0 in limit 10"
(n-for-each-par-map 10 noop noop '())
#t)
@ -143,12 +159,18 @@
(with-test-prefix "lock-mutex"
(pass-if "asyncs are still working 3"
(asyncs-still-working?))
(pass-if "timed locking fails if timeout exceeded"
(let ((m (make-mutex)))
(lock-mutex m)
(let ((t (begin-thread (lock-mutex m (+ (current-time) 1)))))
(not (join-thread t)))))
(pass-if "asyncs are still working 6"
(asyncs-still-working?))
(pass-if "timed locking succeeds if mutex unlocked within timeout"
(let* ((m (make-mutex))
(c (make-condition-variable))
@ -164,7 +186,12 @@
(unlock-mutex cm)
(sleep 1)
(unlock-mutex m)
(join-thread t)))))
(join-thread t))))
(pass-if "asyncs are still working 7"
(asyncs-still-working?))
)
;;
;; timed mutex unlocking
@ -172,12 +199,18 @@
(with-test-prefix "unlock-mutex"
(pass-if "asyncs are still working 5"
(asyncs-still-working?))
(pass-if "timed unlocking returns #f if timeout exceeded"
(let ((m (make-mutex))
(c (make-condition-variable)))
(lock-mutex m)
(not (unlock-mutex m c (current-time)))))
(pass-if "asyncs are still working 4"
(asyncs-still-working?))
(pass-if "timed unlocking returns #t if condition signaled"
(let ((m1 (make-mutex))
(m2 (make-mutex))
@ -226,7 +259,36 @@
(pass-if "timed joining succeeds if thread exits within timeout"
(let ((t (begin-thread (begin (sleep 1) #t))))
(join-thread t (+ (current-time) 2)))))
(join-thread t (+ (current-time) 2))))
(pass-if "asyncs are still working 1"
(asyncs-still-working?))
;; scm_join_thread_timed has a SCM_TICK in the middle of it,
;; to allow asyncs to run (including signal delivery). We
;; used to have a bug whereby if the joined thread terminated
;; at the same time as the joining thread is in this SCM_TICK,
;; scm_join_thread_timed would not notice and would hang
;; forever. So in this test we are setting up the following
;; sequence of events.
;; T=0 other thread is created and starts running
;; T=2 main thread sets up an async that will sleep for 10 seconds
;; T=2 main thread calls join-thread, which will...
;; T=2 ...call the async, which starts sleeping
;; T=5 other thread finishes its work and terminates
;; T=7 async completes, main thread continues inside join-thread.
(pass-if "don't hang when joined thread terminates in SCM_TICK"
(let ((other-thread (make-thread sleep 5)))
(letrec ((delay-count 10)
(aproc (lambda ()
(set! delay-count (- delay-count 1))
(if (zero? delay-count)
(sleep 5)
(system-async-mark aproc)))))
(sleep 2)
(system-async-mark aproc)
(join-thread other-thread)))
#t))
;;
;; thread cancellation

21
test-suite/tests/time.test
View file

@ -3,20 +3,19 @@
;;;;
;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008 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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-time)
#:use-module (test-suite lib)

Some files were not shown because too many files have changed in this diff Show more