Merge commit 'd10f7b572c'

Conflicts:
	libguile/smob.c
	libguile/smob.h
	test-suite/tests/tree-il.test

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

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 "$@"

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

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 "$@"

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
+Return @code{#t} iff @var{items} is a list or vector such that,
-for all 1 <= i <= m, the predicate @var{less} returns true when
+for each element @var{x} and the next element @var{y} of
-applied to all elements i - 1 and i
+@var{items}, @code{(@var{less} @var{y} @var{x})} returns
+@code{#f}.
 @end deffn
 
 @deffn {Scheme Procedure} sort items less

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			\

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;
+  union scm_ieee754_float input;
 
-  src.f = source;
+  input.f = source;
-
+  target->i = bswap_32 (input.i);
-#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
 }
 
 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
+  result.i = bswap_32 (source->i);
-  /* 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
 
   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;
+  input.d = source;
-
+  target->i = bswap_64 (input.i);
-#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
 }
 
 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
+  result.i = bswap_64 (source->i);
-  /* 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
 
   return (result.d);
 }

libguile/ieee-754.h

@@ -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 */

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"
+	    "Return @code{#t} iff @var{items} is a list or vector such that, "
-	    "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
+	    "for each element @var{x} and the next element @var{y} of "
-	    "applied to all elements i - 1 and i")
+	    "@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 */

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),
+      scm_t_uint32 *chars = (scm_t_uint32 *) scm_i_string_wide_chars (str);
-                               NULL, lenp);
+      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 *

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.

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

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

test-suite/standalone/test-conversion.c

@@ -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 ();
 }

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)

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))
 

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:

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)

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)))))
 

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)))

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")))

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))

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))
  

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))))

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")

test-suite/tests/tree-il.test

@@ -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))))