mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 03:30:27 +02:00
Merge commit 'd10f7b572c'
Conflicts: libguile/smob.c libguile/smob.h test-suite/tests/tree-il.test
This commit is contained in:
Andy Wingo
commit
e7501d4a68
28 changed files with 272 additions and 196 deletions
1
THANKS
1
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
|
||||
|
|
|
|||
|
|
@ -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 "$@"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 "$@"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
union scm_ieee754_float input;
|
||||
|
||||
src.f = source;
|
||||
|
||||
#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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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 *
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1078,6 +1078,74 @@ test_locale_strings ()
|
|||
test_11 ("(string #\\f #\\nul)", NULL, 1, 0);
|
||||
}
|
||||
|
||||
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 ()
|
||||
{
|
||||
|
|
@ -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 ();
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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")))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -701,13 +701,6 @@
|
|||
(primcall list
|
||||
(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))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue