diff options
28 files changed, 272 insertions, 196 deletions
@@ -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) |