summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--THANKS1
-rw-r--r--benchmark-guile.in1
-rw-r--r--benchmark-suite/Makefile.am3
-rw-r--r--benchmark-suite/benchmark-suite/lib.scm (renamed from benchmark-suite/lib.scm)0
-rw-r--r--check-guile.in1
-rw-r--r--doc/ref/api-utility.texi9
-rw-r--r--libguile/Makefile.am1
-rw-r--r--libguile/bytevectors.c71
-rw-r--r--libguile/ieee-754.h90
-rw-r--r--libguile/sort.c11
-rw-r--r--libguile/strings.c89
-rw-r--r--meta/uninstalled-env.in12
-rw-r--r--module/srfi/srfi-9.scm12
-rw-r--r--test-suite/Makefile.am2
-rw-r--r--test-suite/standalone/test-conversion.c69
-rw-r--r--test-suite/test-suite/lib.scm (renamed from test-suite/lib.scm)0
-rw-r--r--test-suite/tests/asm-to-bytecode.test2
-rw-r--r--test-suite/tests/brainfuck.test2
-rw-r--r--test-suite/tests/bytevectors.test30
-rw-r--r--test-suite/tests/compiler.test4
-rw-r--r--test-suite/tests/ftw.test10
-rw-r--r--test-suite/tests/gc.test2
-rw-r--r--test-suite/tests/match.test4
-rw-r--r--test-suite/tests/rnrs-libraries.test16
-rw-r--r--test-suite/tests/rnrs-test-a.scm4
-rw-r--r--test-suite/tests/srfi-9.test11
-rw-r--r--test-suite/tests/sxml.match.test4
-rw-r--r--test-suite/tests/tree-il.test7
28 files changed, 272 insertions, 196 deletions
diff --git a/THANKS b/THANKS
index a06ba4a22..bdf11ee28 100644
--- a/THANKS
+++ b/THANKS
@@ -140,6 +140,7 @@ For fixes or providing information which led to a fix:
Daniel Skarda
Dale Smith
Cesar Strauss
+ Klaus Stehle
Rainer Tammer
Richard Todd
Issac Trotts
diff --git a/benchmark-guile.in b/benchmark-guile.in
index 572e00814..8378e9d01 100644
--- a/benchmark-guile.in
+++ b/benchmark-guile.in
@@ -41,6 +41,7 @@ if [ ! -f guile-procedures.txt ] ; then
fi
exec $guile \
+ -L "$BENCHMARK_SUITE_DIR" \
-e main -s "$BENCHMARK_SUITE_DIR/guile-benchmark" \
--benchmark-suite "$BENCHMARK_SUITE_DIR/benchmarks" \
--log-file benchmark-guile.log "$@"
diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am
index f29743f6b..9fa556891 100644
--- a/benchmark-suite/Makefile.am
+++ b/benchmark-suite/Makefile.am
@@ -18,5 +18,6 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/write.bm \
benchmarks/strings.bm
-EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS) \
+EXTRA_DIST = guile-benchmark benchmark-suite/lib.scm \
+ $(SCM_BENCHMARKS) \
ChangeLog-2008
diff --git a/benchmark-suite/lib.scm b/benchmark-suite/benchmark-suite/lib.scm
index 4ba0e3e1c..4ba0e3e1c 100644
--- a/benchmark-suite/lib.scm
+++ b/benchmark-suite/benchmark-suite/lib.scm
diff --git a/check-guile.in b/check-guile.in
index 995199d49..214deec16 100644
--- a/check-guile.in
+++ b/check-guile.in
@@ -43,6 +43,7 @@ fi
exec $guile \
--debug \
+ -L "$TEST_SUITE_DIR" \
--no-auto-compile -e main -s "$TEST_SUITE_DIR/guile-test" \
--test-suite "$TEST_SUITE_DIR/tests" \
--log-file check-guile.log "$@"
diff --git a/doc/ref/api-utility.texi b/doc/ref/api-utility.texi
index 9ab1eeea5..17694ecab 100644
--- a/doc/ref/api-utility.texi
+++ b/doc/ref/api-utility.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2011
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2011, 2012
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -308,9 +308,10 @@ input.
@deffn {Scheme Procedure} sorted? items less
@deffnx {C Function} scm_sorted_p (items, less)
-Return @code{#t} iff @var{items} is a list or a vector such that
-for all 1 <= i <= m, the predicate @var{less} returns true when
-applied to all elements i - 1 and i
+Return @code{#t} iff @var{items} is a list or vector such that,
+for each element @var{x} and the next element @var{y} of
+@var{items}, @code{(@var{less} @var{y} @var{x})} returns
+@code{#f}.
@end deffn
@deffn {Scheme Procedure} sort items less
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 6d2da6620..68d503edd 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -455,7 +455,6 @@ install-exec-hook:
## Perhaps we can deal with them normally once the merge seems to be
## working.
noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
- ieee-754.h \
srfi-14.i.c \
quicksort.i.c \
win32-uname.h win32-socket.h \
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 668c46d17..db132d43f 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -31,7 +31,6 @@
#include "libguile/bytevectors.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
-#include "libguile/ieee-754.h"
#include "libguile/arrays.h"
#include "libguile/array-handle.h"
#include "libguile/uniform.h"
@@ -1584,6 +1583,18 @@ SCM_DEFINE (scm_bytevector_s64_native_set_x, "bytevector-s64-native-set!",
Section 2.1 of R6RS-lib (in response to
http://www.r6rs.org/formal-comments/comment-187.txt). */
+union scm_ieee754_float
+{
+ float f;
+ scm_t_uint32 i;
+};
+
+union scm_ieee754_double
+{
+ double d;
+ scm_t_uint64 i;
+};
+
/* Convert to/from a floating-point number with different endianness. This
method is probably not the most efficient but it should be portable. */
@@ -1592,20 +1603,10 @@ static inline void
float_to_foreign_endianness (union scm_ieee754_float *target,
float source)
{
- union scm_ieee754_float src;
-
- src.f = source;
+ union scm_ieee754_float input;
-#ifdef WORDS_BIGENDIAN
- /* Assuming little endian for both byte and word order. */
- target->little_endian.negative = src.big_endian.negative;
- target->little_endian.exponent = src.big_endian.exponent;
- target->little_endian.mantissa = src.big_endian.mantissa;
-#else
- target->big_endian.negative = src.little_endian.negative;
- target->big_endian.exponent = src.little_endian.exponent;
- target->big_endian.mantissa = src.little_endian.mantissa;
-#endif
+ input.f = source;
+ target->i = bswap_32 (input.i);
}
static inline float
@@ -1613,16 +1614,7 @@ float_from_foreign_endianness (const union scm_ieee754_float *source)
{
union scm_ieee754_float result;
-#ifdef WORDS_BIGENDIAN
- /* Assuming little endian for both byte and word order. */
- result.big_endian.negative = source->little_endian.negative;
- result.big_endian.exponent = source->little_endian.exponent;
- result.big_endian.mantissa = source->little_endian.mantissa;
-#else
- result.little_endian.negative = source->big_endian.negative;
- result.little_endian.exponent = source->big_endian.exponent;
- result.little_endian.mantissa = source->big_endian.mantissa;
-#endif
+ result.i = bswap_32 (source->i);
return (result.f);
}
@@ -1631,22 +1623,10 @@ static inline void
double_to_foreign_endianness (union scm_ieee754_double *target,
double source)
{
- union scm_ieee754_double src;
+ union scm_ieee754_double input;
- src.d = source;
-
-#ifdef WORDS_BIGENDIAN
- /* Assuming little endian for both byte and word order. */
- target->little_little_endian.negative = src.big_endian.negative;
- target->little_little_endian.exponent = src.big_endian.exponent;
- target->little_little_endian.mantissa0 = src.big_endian.mantissa0;
- target->little_little_endian.mantissa1 = src.big_endian.mantissa1;
-#else
- target->big_endian.negative = src.little_little_endian.negative;
- target->big_endian.exponent = src.little_little_endian.exponent;
- target->big_endian.mantissa0 = src.little_little_endian.mantissa0;
- target->big_endian.mantissa1 = src.little_little_endian.mantissa1;
-#endif
+ input.d = source;
+ target->i = bswap_64 (input.i);
}
static inline double
@@ -1654,18 +1634,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
{
union scm_ieee754_double result;
-#ifdef WORDS_BIGENDIAN
- /* Assuming little endian for both byte and word order. */
- result.big_endian.negative = source->little_little_endian.negative;
- result.big_endian.exponent = source->little_little_endian.exponent;
- result.big_endian.mantissa0 = source->little_little_endian.mantissa0;
- result.big_endian.mantissa1 = source->little_little_endian.mantissa1;
-#else
- result.little_little_endian.negative = source->big_endian.negative;
- result.little_little_endian.exponent = source->big_endian.exponent;
- result.little_little_endian.mantissa0 = source->big_endian.mantissa0;
- result.little_little_endian.mantissa1 = source->big_endian.mantissa1;
-#endif
+ result.i = bswap_64 (source->i);
return (result.d);
}
diff --git a/libguile/ieee-754.h b/libguile/ieee-754.h
deleted file mode 100644
index e345efaae..000000000
--- a/libguile/ieee-754.h
+++ /dev/null
@@ -1,90 +0,0 @@
-/* Copyright (C) 1992, 1995, 1996, 1999 Free Software Foundation, Inc.
- This file is part of the GNU C Library.
-
- The GNU C 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.
-
- The GNU C 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 the GNU C Library; if not, write to the Free
- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
- 02111-1307 USA. */
-
-#ifndef SCM_IEEE_754_H
-#define SCM_IEEE_754_H 1
-
-/* Based on glibc's <ieee754.h> and modified by Ludovic Courtès to include
- all possible IEEE-754 double-precision representations. */
-
-
-/* IEEE 754 simple-precision format (32-bit). */
-
-union scm_ieee754_float
- {
- float f;
-
- struct
- {
- unsigned int negative:1;
- unsigned int exponent:8;
- unsigned int mantissa:23;
- } big_endian;
-
- struct
- {
- unsigned int mantissa:23;
- unsigned int exponent:8;
- unsigned int negative:1;
- } little_endian;
- };
-
-
-
-/* IEEE 754 double-precision format (64-bit). */
-
-union scm_ieee754_double
- {
- double d;
-
- struct
- {
- /* Big endian. */
-
- unsigned int negative:1;
- unsigned int exponent:11;
- /* Together these comprise the mantissa. */
- unsigned int mantissa0:20;
- unsigned int mantissa1:32;
- } big_endian;
-
- struct
- {
- /* Both byte order and word order are little endian. */
-
- /* Together these comprise the mantissa. */
- unsigned int mantissa1:32;
- unsigned int mantissa0:20;
- unsigned int exponent:11;
- unsigned int negative:1;
- } little_little_endian;
-
- struct
- {
- /* Byte order is little endian but word order is big endian. Not
- sure this is very wide spread. */
- unsigned int mantissa0:20;
- unsigned int exponent:11;
- unsigned int negative:1;
- unsigned int mantissa1:32;
- } little_big_endian;
-
- };
-
-
-#endif /* SCM_IEEE_754_H */
diff --git a/libguile/sort.c b/libguile/sort.c
index ecadd82ea..2a36320ec 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -1,4 +1,6 @@
-/* Copyright (C) 1999,2000,2001,2002, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1999, 2000, 2001, 2002, 2004, 2006, 2007, 2008, 2009,
+ * 2010, 2011, 2012 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
@@ -101,9 +103,10 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
* (not (less? (list-ref list i) (list-ref list (- i 1)))). */
SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
(SCM items, SCM less),
- "Return @code{#t} iff @var{items} is a list or a vector such that\n"
- "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
- "applied to all elements i - 1 and i")
+ "Return @code{#t} iff @var{items} is a list or vector such that, "
+ "for each element @var{x} and the next element @var{y} of "
+ "@var{items}, @code{(@var{less} @var{y} @var{x})} returns "
+ "@code{#f}.")
#define FUNC_NAME s_scm_sorted_p
{
long len, j; /* list/vector length, temp j */
diff --git a/libguile/strings.c b/libguile/strings.c
index c84c8301a..bc715e0c1 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -1949,6 +1949,52 @@ latin1_to_u8 (const scm_t_uint8 *str, size_t latin_len,
return u8_result;
}
+/* UTF-8 code table
+
+ (Note that this includes code points that are not allowed by Unicode,
+ but since this function has no way to report an error, and its
+ purpose is to determine the size of destination buffers for
+ libunicode conversion functions, we err on the safe side and handle
+ everything that libunicode might conceivably handle, now or in the
+ future.)
+
+ Char. number range | UTF-8 octet sequence
+ (hexadecimal) | (binary)
+ --------------------+------------------------------------------------------
+ 0000 0000-0000 007F | 0xxxxxxx
+ 0000 0080-0000 07FF | 110xxxxx 10xxxxxx
+ 0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx
+ 0001 0000-001F FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
+ 0020 0000-03FF FFFF | 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
+ 0400 0000-7FFF FFFF | 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
+*/
+
+static size_t
+u32_u8_length_in_bytes (const scm_t_uint32 *str, size_t len)
+{
+ size_t ret, i;
+
+ for (i = 0, ret = 0; i < len; i++)
+ {
+ scm_t_uint32 c = str[i];
+
+ if (c <= 0x7f)
+ ret += 1;
+ else if (c <= 0x7ff)
+ ret += 2;
+ else if (c <= 0xffff)
+ ret += 3;
+ else if (c <= 0x1fffff)
+ ret += 4;
+ else if (c <= 0x3ffffff)
+ ret += 5;
+ else
+ ret += 6;
+ }
+
+ return ret;
+}
+
char *
scm_to_utf8_stringn (SCM str, size_t *lenp)
{
@@ -1957,9 +2003,46 @@ scm_to_utf8_stringn (SCM str, size_t *lenp)
scm_i_string_length (str),
NULL, lenp);
else
- return (char *) u32_to_u8 ((scm_t_uint32*)scm_i_string_wide_chars (str),
- scm_i_string_length (str),
- NULL, lenp);
+ {
+ scm_t_uint32 *chars = (scm_t_uint32 *) scm_i_string_wide_chars (str);
+ scm_t_uint8 *buf, *ret;
+ size_t num_chars = scm_i_string_length (str);
+ size_t num_bytes_predicted, num_bytes_actual;
+
+ num_bytes_predicted = u32_u8_length_in_bytes (chars, num_chars);
+
+ if (lenp)
+ {
+ *lenp = num_bytes_predicted;
+ buf = scm_malloc (num_bytes_predicted);
+ }
+ else
+ {
+ buf = scm_malloc (num_bytes_predicted + 1);
+ buf[num_bytes_predicted] = 0;
+ }
+
+ num_bytes_actual = num_bytes_predicted;
+ ret = u32_to_u8 (chars, num_chars, buf, &num_bytes_actual);
+
+ if (SCM_LIKELY (ret == buf && num_bytes_actual == num_bytes_predicted))
+ return (char *) ret;
+
+ /* An error: a bad codepoint. */
+ {
+ int saved_errno = errno;
+
+ free (buf);
+ if (!saved_errno)
+ abort ();
+
+ scm_decoding_error ("scm_to_utf8_stringn", errno,
+ "invalid codepoint in string", str);
+
+ /* Not reached. */
+ return NULL;
+ }
+ }
}
scm_t_wchar *
diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in
index 5fa0db0cf..567c6e243 100644
--- a/meta/uninstalled-env.in
+++ b/meta/uninstalled-env.in
@@ -1,6 +1,6 @@
#!/bin/sh
-# Copyright (C) 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation
+# Copyright (C) 2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation
#
# This file is part of GUILE.
#
@@ -57,12 +57,12 @@ if test "@cross_compiling@" = "no"
then
if [ x"$GUILE_LOAD_PATH" = x ]
then
- GUILE_LOAD_PATH="${top_srcdir}/module:${top_srcdir}/guile-readline:${top_srcdir}"
+ GUILE_LOAD_PATH="${top_srcdir}/module:${top_srcdir}/guile-readline"
if test "${top_srcdir}" != "${top_builddir}"; then
- GUILE_LOAD_PATH="$GUILE_LOAD_PATH:${top_builddir}/module:${top_builddir}/guile-readline:${top_builddir}"
+ GUILE_LOAD_PATH="$GUILE_LOAD_PATH:${top_builddir}/module:${top_builddir}/guile-readline"
fi
else
- for d in "/module" "/guile-readline" ""
+ for d in "/module" "/guile-readline"
do
# This hair prevents double inclusion.
# The ":" prevents prefix aliasing.
@@ -82,9 +82,9 @@ then
if test "x$GUILE_LOAD_COMPILED_PATH" = "x"
then
- GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/guile-readline:${top_builddir}"
+ GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/guile-readline"
else
- for d in "/module" "/guile-readline" ""
+ for d in "/module" "/guile-readline"
do
# This hair prevents double inclusion.
# The ":" prevents prefix aliasing.
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index cb8dd0a19..da71d1e93 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -1,6 +1,6 @@
;;; srfi-9.scm --- define-record-type
-;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012 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
@@ -188,8 +188,12 @@
(let* ((fields (field-identifiers #'(field-spec ...)))
(field-count (length fields))
(layout (string-concatenate (make-list field-count "pw")))
- (indices (field-indices (map syntax->datum fields))))
+ (indices (field-indices (map syntax->datum fields)))
+ (ctor-name (syntax-case #'constructor-spec ()
+ ((ctor args ...) #'ctor))))
#`(begin
+ #,(constructor #'type-name #'constructor-spec indices)
+
(define type-name
(let ((rtd (make-struct/no-tail
record-type-vtable
@@ -198,13 +202,13 @@
'type-name
'#,fields)))
(set-struct-vtable-name! rtd 'type-name)
+ (struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
rtd))
+
(define-inlinable (predicate-name obj)
(and (struct? obj)
(eq? (struct-vtable obj) type-name)))
- #,(constructor #'type-name #'constructor-spec indices)
-
#,@(accessors #'type-name #'(field-spec ...) indices)))))))
;;; srfi-9.scm ends here
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 8daa2e051..bdad24a63 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -165,7 +165,7 @@ SCM_TESTS = tests/00-initial-env.test \
EXTRA_DIST = \
guile-test \
- lib.scm \
+ test-suite/lib.scm \
$(SCM_TESTS) \
tests/rnrs-test-a.scm
ChangeLog-2008
diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c
index 09b74bf17..700e5b3d4 100644
--- a/test-suite/standalone/test-conversion.c
+++ b/test-suite/standalone/test-conversion.c
@@ -1079,6 +1079,74 @@ test_locale_strings ()
}
static void
+test_to_utf8_stringn ()
+{
+ scm_t_wchar wstr[] = { 0x20, /* 0x20 */
+ 0xDF, /* 0xC3, 0x9F */
+ 0x65E5, /* 0xE6, 0x97, 0xA5 */
+ 0x1D400 }; /* 0xF0, 0x9D, 0x90, 0x80 */
+
+ SCM str0 = scm_from_utf32_stringn (wstr, 1); /* ASCII */
+ SCM str1 = scm_from_utf32_stringn (wstr, 2); /* Narrow */
+ SCM str2 = scm_from_utf32_stringn (wstr, 4); /* Wide */
+
+ char cstr0[] = { 0x20, 0 };
+ char cstr1[] = { 0x20, 0xC3, 0x9F, 0 };
+ char cstr2[] = { 0x20, 0xC3, 0x9F, 0xE6, 0x97, 0xA5,
+ 0xF0, 0x9D, 0x90, 0x80, 0 };
+ char *cstr;
+ size_t len;
+
+ /* Test conversion of ASCII string */
+ cstr = scm_to_utf8_stringn (str0, &len);
+ if (len + 1 != sizeof (cstr0) || memcmp (cstr, cstr0, len))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<ASCII>, &len)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+ cstr = scm_to_utf8_stringn (str0, NULL);
+ if (memcmp (cstr, cstr0, len + 1))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<ASCII>, NULL)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+
+ /* Test conversion of narrow string */
+ cstr = scm_to_utf8_stringn (str1, &len);
+ if (len + 1 != sizeof (cstr1) || memcmp (cstr, cstr1, len))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<NARROW>, &len)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+ cstr = scm_to_utf8_stringn (str1, NULL);
+ if (memcmp (cstr, cstr1, len + 1))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<NARROW>, NULL)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+
+ /* Test conversion of wide string */
+ cstr = scm_to_utf8_stringn (str2, &len);
+ if (len + 1 != sizeof (cstr2) || memcmp (cstr, cstr2, len))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<WIDE>, &len)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+ cstr = scm_to_utf8_stringn (str2, NULL);
+ if (memcmp (cstr, cstr2, len + 1))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<WIDE>, NULL)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+}
+
+static void
test_is_exact ()
{
if (1 != scm_is_exact (scm_c_eval_string ("3")))
@@ -1122,6 +1190,7 @@ tests (void *data, int argc, char **argv)
test_from_double ();
test_to_double ();
test_locale_strings ();
+ test_to_utf8_stringn ();
test_is_exact ();
test_is_inexact ();
}
diff --git a/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index 5785378ad..5785378ad 100644
--- a/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test
index 9a8178c70..52bc7e1a7 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -16,7 +16,7 @@
;;;; 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 tests asm-to-bytecode)
+(define-module (tests asm-to-bytecode)
#:use-module (rnrs bytevectors)
#:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
#:use-module (test-suite lib)
diff --git a/test-suite/tests/brainfuck.test b/test-suite/tests/brainfuck.test
index f612fb50a..cdbceaa3d 100644
--- a/test-suite/tests/brainfuck.test
+++ b/test-suite/tests/brainfuck.test
@@ -14,7 +14,7 @@
;;;; 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 tests brainfuck)
+(define-module (tests brainfuck)
#:use-module (test-suite lib)
#:use-module (system base compile))
diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test
index 3007434c4..4ba501217 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -1,6 +1,6 @@
;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -325,6 +325,18 @@
(with-test-prefix/c&e "2.8 Operations on IEEE-754 Representations"
+ (pass-if "single, little endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 4)))
+ (bytevector-ieee-single-set! b 0 1.0 (endianness little))
+ (equal? #vu8(0 0 128 63) b)))
+
+ (pass-if "single, big endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 4)))
+ (bytevector-ieee-single-set! b 0 1.0 (endianness big))
+ (equal? #vu8(63 128 0 0) b)))
+
(pass-if "bytevector-ieee-single-native-{ref,set!}"
(let ((b (make-bytevector 4))
(number 3.00))
@@ -348,6 +360,18 @@
(equal? (bytevector-ieee-single-ref b 1 (endianness little))
(bytevector-ieee-single-ref b 5 (endianness big)))))
+ (pass-if "double, little endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 8)))
+ (bytevector-ieee-double-set! b 0 1.0 (endianness little))
+ (equal? #vu8(0 0 0 0 0 0 240 63) b)))
+
+ (pass-if "double, big endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 8)))
+ (bytevector-ieee-double-set! b 0 1.0 (endianness big))
+ (equal? #vu8(63 240 0 0 0 0 0 0) b)))
+
(pass-if "bytevector-ieee-double-native-{ref,set!}"
(let ((b (make-bytevector 8))
(number 3.14))
@@ -653,3 +677,7 @@
(pass-if "bitvector > 8"
(let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
(= (bytevector-length bv) 2))))
+
+;;; Local Variables:
+;;; eval: (put 'with-test-prefix/c&e 'scheme-indent-function 1)
+;;; End:
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index ee688c00a..619b16740 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012 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
@@ -15,7 +15,7 @@
;;;; 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 tests compiler)
+(define-module (tests compiler)
#:use-module (test-suite lib)
#:use-module (test-suite guile-test)
#:use-module (system base compile)
diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test
index be983a16a..805c779bf 100644
--- a/test-suite/tests/ftw.test
+++ b/test-suite/tests/ftw.test
@@ -90,6 +90,9 @@
(define %test-dir
(string-append %top-srcdir "/test-suite"))
+(define %test-suite-lib-dir
+ (string-append %top-srcdir "/test-suite/test-suite"))
+
(define (make-file-tree dir tree)
"Make file system TREE at DIR."
(define (touch file)
@@ -152,7 +155,8 @@
(let ((enter? (lambda (n s r)
;; Enter only `test-suite/tests/'.
(if (member `(down ,%test-dir) r)
- (string=? (basename n) "tests")
+ (or (string=? (basename n) "tests")
+ (string=? (basename n) "test-suite"))
(string=? (basename n) "test-suite"))))
(leaf (lambda (n s r) (cons `(leaf ,n) r)))
(down (lambda (n s r) (cons `(down ,n) r)))
@@ -167,7 +171,7 @@
((('down (? (cut string=? <> %test-dir)))
between ...
('up (? (cut string=? <> %test-dir))))
- (and (any (match-lambda (('leaf (= basename "lib.scm")) #t) (_ #f))
+ (and (any (match-lambda (('down (= basename "test-suite")) #t) (_ #f))
between)
(any (match-lambda (('down (= basename "tests")) #t) (_ #f))
between)
@@ -195,7 +199,7 @@
(up (lambda (n s r) (cons `(up ,n) r)))
(skip (lambda (n s r) (cons `(skip ,n) r)))
(error (lambda (n s e r) (cons `(error ,n) r)))
- (name (string-append %test-dir "/lib.scm")))
+ (name (string-append %test-suite-lib-dir "/lib.scm")))
(equal? (file-system-fold enter? leaf down up skip error '() name)
`((leaf ,name)))))
diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index e13c8f7cd..a969752f8 100644
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -16,7 +16,7 @@
;;;; 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 tests gc)
+(define-module (tests gc)
#:use-module (ice-9 documentation)
#:use-module (test-suite lib)
#:use-module ((system base compile) #:select (compile)))
diff --git a/test-suite/tests/match.test b/test-suite/tests/match.test
index 8b19ff702..6bf5bdd2c 100644
--- a/test-suite/tests/match.test
+++ b/test-suite/tests/match.test
@@ -1,6 +1,6 @@
;;;; match.test --- (ice-9 match) -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012 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
@@ -205,4 +205,4 @@
(test-end (syntax-rules ()
((_) #t))))
(with-test-prefix "upstream tests"
- (include-from-path "test-suite/tests/match.test.upstream")))
+ (include-from-path "tests/match.test.upstream")))
diff --git a/test-suite/tests/rnrs-libraries.test b/test-suite/tests/rnrs-libraries.test
index e16271400..e961c2877 100644
--- a/test-suite/tests/rnrs-libraries.test
+++ b/test-suite/tests/rnrs-libraries.test
@@ -1,5 +1,5 @@
;;;; rnrs-libraries.test --- test library and import forms -*- scheme -*-
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2012 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
@@ -15,7 +15,7 @@
;;;; 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 tests rnrs-libraries)
+(define-module (tests rnrs-libraries)
#:use-module (test-suite lib))
;; First, check that Guile modules are r6rs modules.
@@ -71,7 +71,7 @@
(pass-if "import"
(eval '(begin
- (import (test-suite tests rnrs-test-a))
+ (import (tests rnrs-test-a))
#t)
(current-module)))
@@ -79,18 +79,18 @@
(not (module-local-variable (current-module) 'double)))
(pass-if "resolve-interface"
- (module? (resolve-interface '(test-suite tests rnrs-test-a))))
+ (module? (resolve-interface '(tests rnrs-test-a))))
- (set! iface (resolve-interface '(test-suite tests rnrs-test-a)))
+ (set! iface (resolve-interface '(tests rnrs-test-a)))
(pass-if "resolve-interface (2)"
- (eq? iface (resolve-interface '(test-suite tests rnrs-test-a))))
+ (eq? iface (resolve-interface '(tests rnrs-test-a))))
(pass-if "resolve-r6rs-interface"
- (eq? iface (resolve-r6rs-interface '(test-suite tests rnrs-test-a))))
+ (eq? iface (resolve-r6rs-interface '(tests rnrs-test-a))))
(pass-if "resolve-r6rs-interface (2)"
- (eq? iface (resolve-r6rs-interface '(library (test-suite tests rnrs-test-a)))))
+ (eq? iface (resolve-r6rs-interface '(library (tests rnrs-test-a)))))
(pass-if "module uses"
(and (memq iface (module-uses (current-module))) #t))
diff --git a/test-suite/tests/rnrs-test-a.scm b/test-suite/tests/rnrs-test-a.scm
index 7b46fd63c..474069b3e 100644
--- a/test-suite/tests/rnrs-test-a.scm
+++ b/test-suite/tests/rnrs-test-a.scm
@@ -1,6 +1,6 @@
;;; test of defining rnrs libraries
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2012 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
@@ -17,7 +17,7 @@
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-(library (test-suite tests rnrs-test-a)
+(library (tests rnrs-test-a)
(export double)
(import (guile))
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index f26a7a2cd..321fe16ac 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -1,7 +1,7 @@
;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-05-10
;;;;
-;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011, 2012 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
@@ -110,3 +110,12 @@
(let ((frotz (make-frotz 1 2)))
(and (= (frotz-a frotz) 1)
(= (frotz-b frotz) 2)))))
+
+(with-test-prefix "record compatibility"
+
+ (pass-if "record?"
+ (record? (make-foo 1)))
+
+ (pass-if "record-constructor"
+ (equal? ((record-constructor :foo) 1)
+ (make-foo 1))))
diff --git a/test-suite/tests/sxml.match.test b/test-suite/tests/sxml.match.test
index b3dbbe729..fcb089fab 100644
--- a/test-suite/tests/sxml.match.test
+++ b/test-suite/tests/sxml.match.test
@@ -1,6 +1,6 @@
;;;; sxml.simple.test --- (sxml simple) -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2012 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
@@ -42,4 +42,4 @@
;; FIXME: The `xyzpq' variable in there is originally named `x' but using that
;; name triggers a psyntax "identifier out of context" error.
-(include-from-path "test-suite/tests/sxml-match-tests.ss")
+(include-from-path "tests/sxml-match-tests.ss")
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 47289c3c9..37349d22a 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -702,13 +702,6 @@
(const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
(pass-if-peval
- ;; First order, coalesced, mutability preserved.
- (cons 0 (cons 1 (cons 2 (list 3 4 5))))
- ;; This must not be a constant.
- (primcall list
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
-
- (pass-if-peval
;; First order, coalesced, immutability preserved.
(cons 0 (cons 1 (cons 2 '(3 4 5))))
(primcall cons (const 0)