Merge remote-tracking branch 'origin/stable-2.0'

Moved scm_i_struct_hash from struct.c to hash.c and made it static.

The port's alist is now a field of 'scm_t_port'.

Conflicts:
	libguile/arrays.c
	libguile/hash.c
	libguile/ports.c
	libguile/print.h
	libguile/read.c

THANKS

@@ -6,6 +6,7 @@ Contributors since the last release:
          Volker Grabsch
          Julian Graham
         Michael Gran
+         Daniel Hartwig
              No Itisnt
            Neil Jerram
          Daniel Kraft

configure.ac

@@ -36,7 +36,7 @@ AC_CONFIG_MACRO_DIR([m4])
 AC_CONFIG_SRCDIR(GUILE-VERSION)
 
 dnl `AM_SUBST_NOTMAKE' was introduced in Automake 1.11.
-AM_INIT_AUTOMAKE([1.11 gnu no-define -Wall -Wno-override dist-xz])
+AM_INIT_AUTOMAKE([1.11 gnu no-define -Wall -Wno-override color-tests dist-xz])
 m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])], [AC_SUBST([AM_DEFAULT_VERBOSITY],1)])
 
 AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT)

doc/ref/Makefile.am

@@ -62,6 +62,7 @@ guile_TEXINFOS = preface.texi			\
 		 web.texi			\
 		 expect.texi			\
 		 scsh.texi			\
+		 curried.texi			\
 		 sxml-match.texi		\
 		 scheme-scripts.texi		\
 		 api-overview.texi		\

doc/ref/api-data.texi

@@ -3152,12 +3152,24 @@ These procedures are useful for similar tasks.
 Convert the string @var{str} into a list of characters.
 @end deffn
 
-@deffn {Scheme Procedure} string-split str chr
+@deffn {Scheme Procedure} string-split str char_pred
-@deffnx {C Function} scm_string_split (str, chr)
+@deffnx {C Function} scm_string_split (str, char_pred)
 Split the string @var{str} into a list of substrings delimited
-by appearances of the character @var{chr}.  Note that an empty substring
+by appearances of characters that
-between separator characters will result in an empty string in the
+
-result list.
+@itemize @bullet
+@item
+equal @var{char_pred}, if it is a character,
+
+@item
+satisfy the predicate @var{char_pred}, if it is a procedure,
+
+@item
+are in the set @var{char_pred}, if it is a character set.
+@end itemize
+
+Note that an empty substring between separator characters will result in
+an empty string in the result list.
 
 @lisp
 (string-split "root:x:0:0:root:/root:/bin/bash" #\:)

doc/ref/api-evaluation.texi

@@ -254,6 +254,8 @@ Encoding of Source Files}.
 
 @node Case Sensitivity
 @subsubsection Case Sensitivity
+@cindex fold-case
+@cindex no-fold-case
 
 @c FIXME::martin: Review me!
 
@@ -275,9 +277,9 @@ options, @xref{Scheme Read}.
 (read-enable 'case-insensitive)
 @end lisp
 
-Note that this is seldom a problem, because Scheme programmers tend not
+It is also possible to disable (or enable) case sensitivity within a
-to use uppercase letters in their identifiers anyway.
+single file by placing the reader directives @code{#!fold-case} (or
-
+@code{#!no-fold-case}) within the file itself.
 
 @node Keyword Syntax
 @subsubsection Keyword Syntax
@@ -315,10 +317,10 @@ its read options.
 @cindex options - read
 @cindex read options
 @deffn {Scheme Procedure} read-options [setting]
-Display the current settings of the read options.  If @var{setting} is
+Display the current settings of the global read options.  If
-omitted, only a short form of the current read options is printed.
+@var{setting} is omitted, only a short form of the current read options
-Otherwise if @var{setting} is the symbol @code{help}, a complete options
+is printed.  Otherwise if @var{setting} is the symbol @code{help}, a
-description is displayed.
+complete options description is displayed.
 @end deffn
 
 The set of available options, and their default values, may be had by
@@ -336,8 +338,19 @@ r6rs-hex-escapes  no    Use R6RS variable-length character and string hex escape
 square-brackets   yes   Treat `[' and `]' as parentheses, for R6RS compatibility.
 hungry-eol-escapes no   In strings, consume leading whitespace after an
                         escaped end-of-line.
+curly-infix       no    Support SRFI-105 curly infix expressions.
 @end smalllisp
 
+Note that Guile also includes a preliminary mechanism for setting read
+options on a per-port basis.  For instance, the @code{case-insensitive}
+read option is set (or unset) on the port when the reader encounters the
+@code{#!fold-case} or @code{#!no-fold-case} reader directives.
+Similarly, the @code{#!curly-infix} reader directive sets the
+@code{curly-infix} read option on the port, and
+@code{#!curly-infix-and-bracket-lists} sets @code{curly-infix} and
+unsets @code{square-brackets} on the port (@pxref{SRFI-105}).  There is
+currently no other way to access or set the per-port read options.
+
 The boolean options may be toggled with @code{read-enable} and
 @code{read-disable}. The non-boolean @code{keywords} option must be set
 using @code{read-set!}.

doc/ref/api-options.texi

@@ -390,6 +390,7 @@ r6rs-hex-escapes  no    Use R6RS variable-length character and string hex escape
 square-brackets   yes   Treat `[' and `]' as parentheses, for R6RS compatibility.
 hungry-eol-escapes no   In strings, consume leading whitespace after an
                         escaped end-of-line.
+curly-infix       no    Support SRFI-105 curly infix expressions.
 scheme@@(guile-user) [1]> (read-enable 'case-insensitive)
 $2 = (square-brackets keywords #f case-insensitive positions)
 scheme@@(guile-user) [1]> ,q

doc/ref/api-regex.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, 2007, 2009, 2010
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009, 2010, 2012
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -54,11 +54,12 @@ Zero bytes (@code{#\nul}) cannot be used in regex patterns or input
 strings, since the underlying C functions treat that as the end of
 string.  If there's a zero byte an error is thrown.
 
-Patterns and input strings are treated as being in the locale
+Internally, patterns and input strings are converted to the current
-character set if @code{setlocale} has been called (@pxref{Locales}),
+locale's encoding, and then passed to the C library's regular expression
-and in a multibyte locale this includes treating multi-byte sequences
+routines (@pxref{Regular Expressions,,, libc, The GNU C Library
-as a single character.  (Guile strings are currently merely bytes,
+Reference Manual}).  The returned match structures always point to
-though this may change in the future, @xref{Conversion to/from C}.)
+characters in the strings, not to individual bytes, even in the case of
+multi-byte encodings.
 
 @deffn {Scheme Procedure} string-match pattern str [start]
 Compile the string @var{pattern} into a regular expression and compare

doc/ref/curried.texi

@@ -0,0 +1,56 @@
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 2012 Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node Curried Definitions
+@section Curried Definitions
+
+The macros in this section are provided by
+@lisp
+(use-modules (ice-9 curried-definitions))
+@end lisp
+@noindent
+and replace those provided by default.
+
+Prior to Guile 2.0, Guile provided a type of definition known colloquially
+as a ``curried definition''. The idea is to extend the syntax of
+@code{define} so that you can conveniently define procedures that return
+procedures, up to any desired depth.
+
+For example,
+@example
+(define ((foo x) y)
+  (list x y))
+@end example
+is a convenience form of
+@example
+(define foo
+  (lambda (x)
+    (lambda (y)
+      (list x y))))
+@end example
+
+@deffn {Scheme Syntax} define (@dots{} (name args @dots{}) @dots{}) body @dots{}
+@deffnx {Scheme Syntax} define* (@dots{} (name args @dots{}) @dots{}) body @dots{}
+@deffnx {Scheme Syntax} define-public (@dots{} (name args @dots{}) @dots{}) body @dots{}
+
+Create a top level variable @var{name} bound to the procedure with
+parameter list @var{args}. If @var{name} is itself a formal parameter
+list, then a higher order procedure is created using that
+formal-parameter list, and returning a procedure that has parameter list
+@var{args}. This nesting may occur to arbitrary depth.
+
+@code{define*} is similar but the formal parameter lists take additional
+options as described in @ref{lambda* and define*}. For example,
+@example
+(define* ((foo #:keys (bar 'baz) (quux 'zot)) frotz #:rest rest)
+  (list bar quux frotz rest))
+
+((foo #:quux 'foo) 1 2 3 4 5)
+@result{} (baz foo 1 (2 3 4 5))
+@end example
+
+@code{define-public} is similar to @code{define} but it also adds
+@var{name} to the list of exported bindings of the current module.
+@end deffn

doc/ref/guile.texi

@@ -370,6 +370,7 @@ available through both Scheme and C interfaces.
 * Expect::			Controlling interactive programs with Guile.
 * sxml-match::                  Pattern matching of SXML.
 * The Scheme shell (scsh)::     Using scsh interfaces in Guile.
+* Curried Definitions::         Extended @code{define} syntax.
 @end menu
 
 @include slib.texi
@@ -387,6 +388,7 @@ available through both Scheme and C interfaces.
 @include sxml-match.texi
 
 @include scsh.texi
+@include curried.texi
 
 @node Standard Library
 @chapter Standard Library

doc/ref/scheme-ideas.texi

@@ -476,6 +476,11 @@ The corresponding forms of the alternative @code{define} syntax are:
 @noindent
 For details on how these forms work, see @xref{Lambda}.
 
+Prior to Guile 2.0, Guile provided an extension to @code{define} syntax
+that allowed you to nest the previous extension up to an arbitrary
+depth. These are no longer provided by default, and instead have been
+moved to @ref{Curried Definitions}
+
 (It could be argued that the alternative @code{define} forms are rather
 confusing, especially for newcomers to the Scheme language, as they hide
 both the role of @code{lambda} and the fact that procedures are values

doc/ref/scheme-using.texi

@@ -457,7 +457,7 @@ show a short error printout.
 Default values for REPL options may be set using
 @code{repl-default-option-set!} from @code{(system repl common)}:
 
-@deffn {Scheme Procedure} repl-set-default-option! key value
+@deffn {Scheme Procedure} repl-default-option-set! key value
 Set the default value of a REPL option.  This function is particularly
 useful in a user's init file.  @xref{Init File}.
 @end deffn

doc/ref/srfi-modules.texi

@@ -54,6 +54,7 @@ get the relevant SRFI documents from the SRFI home page
 * SRFI-69::                     Basic hash tables.
 * SRFI-88::                     Keyword objects.
 * SRFI-98::                     Accessing environment variables.
+* SRFI-105::                    Curly-infix expressions.
 @end menu
 
 
@@ -3003,10 +3004,10 @@ with locale decimal point, eg.@: @samp{5.2}
 @item @nicode{~z} @tab time zone, RFC-822 style
 @item @nicode{~Z} @tab time zone symbol (not currently implemented)
 @item @nicode{~1} @tab ISO-8601 date, @samp{~Y-~m-~d}
-@item @nicode{~2} @tab ISO-8601 time+zone, @samp{~k:~M:~S~z}
+@item @nicode{~2} @tab ISO-8601 time+zone, @samp{~H:~M:~S~z}
-@item @nicode{~3} @tab ISO-8601 time, @samp{~k:~M:~S}
+@item @nicode{~3} @tab ISO-8601 time, @samp{~H:~M:~S}
-@item @nicode{~4} @tab ISO-8601 date/time+zone, @samp{~Y-~m-~dT~k:~M:~S~z}
+@item @nicode{~4} @tab ISO-8601 date/time+zone, @samp{~Y-~m-~dT~H:~M:~S~z}
-@item @nicode{~5} @tab ISO-8601 date/time, @samp{~Y-~m-~dT~k:~M:~S}
+@item @nicode{~5} @tab ISO-8601 date/time, @samp{~Y-~m-~dT~H:~M:~S}
 @end multitable
 @end defun
 
@@ -4469,6 +4470,56 @@ Returns the names and values of all the environment variables as an
 association list in which both the keys and the values are strings.
 @end deffn
 
+@node SRFI-105
+@subsection SRFI-105 Curly-infix expressions.
+@cindex SRFI-105
+@cindex curly-infix
+@cindex curly-infix-and-bracket-lists
+
+Guile's built-in reader includes support for SRFI-105 curly-infix
+expressions.  See @uref{http://srfi.schemers.org/srfi-105/srfi-105.html,
+the specification of SRFI-105}.  Some examples:
+
+@example
+@{n <= 5@}                @result{}  (<= n 5)
+@{a + b + c@}             @result{}  (+ a b c)
+@{a * @{b + c@}@}           @result{}  (* a (+ b c))
+@{(- a) / b@}             @result{}  (/ (- a) b)
+@{-(a) / b@}              @result{}  (/ (- a) b) as well
+@{(f a b) + (g h)@}       @result{}  (+ (f a b) (g h))
+@{f(a b) + g(h)@}         @result{}  (+ (f a b) (g h)) as well
+@{f[a b] + g(h)@}         @result{}  (+ ($bracket-apply$ f a b) (g h))
+'@{a + f(b) + x@}         @result{}  '(+ a (f b) x)
+@{length(x) >= 6@}        @result{}  (>= (length x) 6)
+@{n-1 + n-2@}             @result{}  (+ n-1 n-2)
+@{n * factorial@{n - 1@}@}  @result{}  (* n (factorial (- n 1)))
+@{@{a > 0@} and @{b >= 1@}@}  @result{}  (and (> a 0) (>= b 1))
+@{f@{n - 1@}(x)@}           @result{}  ((f (- n 1)) x)
+@{a . z@}                 @result{}  ($nfx$ a . z)
+@{a + b - c@}             @result{}  ($nfx$ a + b - c)
+@end example
+
+To enable curly-infix expressions within a file, place the reader
+directive @code{#!curly-infix} before the first use of curly-infix
+notation.  To globally enable curly-infix expressions in Guile's reader,
+set the @code{curly-infix} read option.
+
+Guile also implements the following non-standard extension to SRFI-105:
+if @code{curly-infix} is enabled and there is no other meaning assigned
+to square brackets (i.e. the @code{square-brackets} read option is
+turned off), then lists within square brackets are read as normal lists
+but with the special symbol @code{$bracket-list$} added to the front.
+To enable this combination of read options within a file, use the reader
+directive @code{#!curly-infix-and-bracket-lists}.  For example:
+
+@example
+[a b]    @result{}  ($bracket-list$ a b)
+[a . b]  @result{}  ($bracket-list$ a . b)
+@end example
+
+
+For more information on reader options, @xref{Scheme Read}.
+
 @c srfi-modules.texi ends here
 
 @c Local Variables:

doc/ref/tour.texi

@@ -1,7 +1,7 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2010, 2011
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2010, 2011,
-@c   Free Software Foundation, Inc.
+@c   2012 Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @raisesections
@@ -149,7 +149,7 @@ that makes the @code{j0} function available to Scheme code.
 SCM
 j0_wrapper (SCM x)
 @{
-  return scm_make_real (j0 (scm_num2dbl (x, "j0")));
+  return scm_from_double (j0 (scm_to_double (x)));
 @}
 
 void

libguile/arrays.c

@@ -1,4 +1,5 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005,
+ *   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 License
@@ -814,178 +815,6 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
     return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
 }
 
-/* Read an array.  This function can also read vectors and uniform
-   vectors.  Also, the conflict between '#f' and '#f32' and '#f64' is
-   handled here.
-
-   C is the first character read after the '#'.
-*/
-
-static int
-read_decimal_integer (SCM port, int c, ssize_t *resp)
-{
-  ssize_t sign = 1;
-  ssize_t res = 0;
-  int got_it = 0;
-
-  if (c == '-')
-    {
-      sign = -1;
-      c = scm_getc_unlocked (port);
-    }
-
-  while ('0' <= c && c <= '9')
-    {
-      res = 10*res + c-'0';
-      got_it = 1;
-      c = scm_getc_unlocked (port);
-    }
-
-  if (got_it)
-    *resp = sign * res;
-  return c;
-}
-
-SCM
-scm_i_read_array (SCM port, int c)
-{
-  ssize_t rank;
-  scm_t_wchar tag_buf[8];
-  int tag_len;
-
-  SCM tag, shape = SCM_BOOL_F, elements;
-
-  /* XXX - shortcut for ordinary vectors.  Shouldn't be necessary but
-     the array code can not deal with zero-length dimensions yet, and
-     we want to allow zero-length vectors, of course.
-  */
-  if (c == '(')
-    {
-      scm_ungetc_unlocked (c, port);
-      return scm_vector (scm_read (port));
-    }
-
-  /* Disambiguate between '#f' and uniform floating point vectors.
-   */
-  if (c == 'f')
-    {
-      c = scm_getc_unlocked (port);
-      if (c != '3' && c != '6')
-	{
-	  if (c != EOF)
-	    scm_ungetc_unlocked (c, port);
-	  return SCM_BOOL_F;
-	}
-      rank = 1;
-      tag_buf[0] = 'f';
-      tag_len = 1;
-      goto continue_reading_tag;
-    }
-
-  /* Read rank. 
-   */
-  rank = 1;
-  c = read_decimal_integer (port, c, &rank);
-  if (rank < 0)
-    scm_i_input_error (NULL, port, "array rank must be non-negative",
-		       SCM_EOL);
-
-  /* Read tag. 
-   */
-  tag_len = 0;
- continue_reading_tag:
-  while (c != EOF && c != '(' && c != '@' && c != ':'
-         && tag_len < sizeof tag_buf / sizeof tag_buf[0])
-    {
-      tag_buf[tag_len++] = c;
-      c = scm_getc_unlocked (port);
-    }
-  if (tag_len == 0)
-    tag = SCM_BOOL_T;
-  else
-    {
-      tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len));
-      if (tag_len == sizeof tag_buf / sizeof tag_buf[0])
-        scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a",
-                           scm_list_1 (tag));
-    }
-    
-  /* Read shape. 
-   */
-  if (c == '@' || c == ':')
-    {
-      shape = SCM_EOL;
-      
-      do
-	{
-	  ssize_t lbnd = 0, len = 0;
-	  SCM s;
-
-	  if (c == '@')
-	    {
-	      c = scm_getc_unlocked (port);
-	      c = read_decimal_integer (port, c, &lbnd);
-	    }
-	  
-	  s = scm_from_ssize_t (lbnd);
-
-	  if (c == ':')
-	    {
-	      c = scm_getc_unlocked (port);
-	      c = read_decimal_integer (port, c, &len);
-	      if (len < 0)
-		scm_i_input_error (NULL, port,
-				   "array length must be non-negative",
-				   SCM_EOL);
-
-	      s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
-	    }
-
-	  shape = scm_cons (s, shape);
-	} while (c == '@' || c == ':');
-
-      shape = scm_reverse_x (shape, SCM_EOL);
-    }
-
-  /* Read nested lists of elements.
-   */
-  if (c != '(')
-    scm_i_input_error (NULL, port,
-		       "missing '(' in vector or array literal",
-		       SCM_EOL);
-  scm_ungetc_unlocked (c, port);
-  elements = scm_read (port);
-
-  if (scm_is_false (shape))
-    shape = scm_from_ssize_t (rank);
-  else if (scm_ilength (shape) != rank)
-    scm_i_input_error 
-      (NULL, port,
-       "the number of shape specifications must match the array rank",
-       SCM_EOL);
-
-  /* Handle special print syntax of rank zero arrays; see
-     scm_i_print_array for a rationale.
-  */
-  if (rank == 0)
-    {
-      if (!scm_is_pair (elements))
-	scm_i_input_error (NULL, port,
-			   "too few elements in array literal, need 1",
-			   SCM_EOL);
-      if (!scm_is_null (SCM_CDR (elements)))
-	scm_i_input_error (NULL, port,
-			   "too many elements in array literal, want 1",
-			   SCM_EOL);
-      elements = SCM_CAR (elements);
-    }
-
-  /* Construct array. 
-   */
-  return scm_list_to_typed_array (tag, shape, elements);
-}
-
-
 static SCM
 array_handle_ref (scm_t_array_handle *h, size_t pos)
 {

libguile/arrays.h

@@ -3,7 +3,8 @@
 #ifndef SCM_ARRAY_H
 #define SCM_ARRAY_H
 
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009,
+ *   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 License
@@ -73,7 +74,6 @@ typedef struct scm_i_t_array
 
 SCM_INTERNAL SCM scm_i_make_array (int ndim);
 SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate);
-SCM_INTERNAL SCM scm_i_read_array (SCM port, int c);
 
 SCM_INTERNAL void scm_init_arrays (void);
 

libguile/hash.c

@@ -1,4 +1,5 @@
-/*	Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 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
@@ -223,6 +224,53 @@ scm_i_utf8_string_hash (const char *str, size_t len)
   return ret;
 }
 
+static unsigned long scm_raw_ihashq (scm_t_bits key);
+static unsigned long scm_raw_ihash (SCM obj, size_t depth);
+
+/* Return the hash of struct OBJ.  Traverse OBJ's fields to compute the
+   result, unless DEPTH is zero.  Assumes that OBJ is a struct.  */
+static unsigned long
+scm_i_struct_hash (SCM obj, size_t depth)
+{
+  SCM layout;
+  scm_t_bits *data;
+  size_t struct_size, field_num;
+  unsigned long hash;
+
+  layout = SCM_STRUCT_LAYOUT (obj);
+  struct_size = scm_i_symbol_length (layout) / 2;
+  data = SCM_STRUCT_DATA (obj);
+
+  hash = scm_raw_ihashq (SCM_UNPACK (SCM_STRUCT_VTABLE (obj)));
+  if (depth > 0)
+    for (field_num = 0; field_num < struct_size; field_num++)
+      {
+        int protection;
+
+        protection = scm_i_symbol_ref (layout, field_num * 2 + 1);
+        if (protection != 'h' && protection != 'o')
+          {
+            int type;
+            type = scm_i_symbol_ref (layout, field_num * 2);
+            switch (type)
+              {
+              case 'p':
+                hash ^= scm_raw_ihash (SCM_PACK (data[field_num]),
+                                       depth / 2);
+                break;
+              case 'u':
+                hash ^= scm_raw_ihashq (data[field_num]);
+                break;
+              default:
+                /* Ignore 's' fields.  */;
+              }
+          }
+      }
+
+  /* FIXME: Tail elements should be taken into account.  */
+
+  return hash;
+}
 
 /* Thomas Wang's integer hasher, from
    http://www.cris.com/~Ttwang/tech/inthash.htm.  */
@@ -298,6 +346,8 @@ scm_raw_ihash (SCM obj, size_t depth)
                 ^ scm_raw_ihash (SCM_CDR (obj), depth / 2));
       else
         return scm_raw_ihashq (scm_tc3_cons);
+    case scm_tcs_struct:
+      return scm_i_struct_hash (obj, depth);
     default:
       return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
     }

libguile/list.c

@@ -267,7 +267,7 @@ SCM_DEFINE (scm_append, "append", 0, 0, 1,
 
 
 SCM_DEFINE (scm_append_x, "append!", 0, 0, 1, 
-            (SCM lists),
+            (SCM args),
 	    "A destructive version of @code{append} (@pxref{Pairs and\n"
 	    "Lists,,,r5rs, The Revised^5 Report on Scheme}).  The cdr field\n"
 	    "of each list's final pair is changed to point to the head of\n"
@@ -276,26 +276,29 @@ SCM_DEFINE (scm_append_x, "append!", 0, 0, 1,
 #define FUNC_NAME s_scm_append_x
 {
   SCM ret, *loc;
-  SCM_VALIDATE_REST_ARGUMENT (lists);
+  int argnum = 1;
+  SCM_VALIDATE_REST_ARGUMENT (args);
 
-  if (scm_is_null (lists))
+  if (scm_is_null (args))
     return SCM_EOL;
 
   loc = &ret;
   for (;;)
     {
-      SCM arg = SCM_CAR (lists);
+      SCM arg = SCM_CAR (args);
       *loc = arg;
 
-      lists = SCM_CDR (lists);
+      args = SCM_CDR (args);
-      if (scm_is_null (lists))
+      if (scm_is_null (args))
         return ret;
 
       if (!SCM_NULL_OR_NIL_P (arg))
         {
-          SCM_VALIDATE_CONS (SCM_ARG1, arg);
+          SCM_VALIDATE_CONS (argnum, arg);
           loc = SCM_CDRLOC (scm_last_pair (arg));
+          SCM_VALIDATE_NULL_OR_NIL (argnum, *loc);
         }
+      argnum++;
     }
 }
 #undef FUNC_NAME

libguile/ports.c

@@ -613,6 +613,8 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits,
   entry->ilseq_handler = handler;
   entry->iconv_descriptors = NULL;
 
+  entry->alist = SCM_EOL;
+
   if (SCM_PORT_DESCRIPTOR (ret)->free)
     scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL);
 
@@ -2370,7 +2372,7 @@ scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port)
   if (end == (size_t) -1)
     end = scm_i_string_length (str);
 
-  scm_display (scm_c_substring (str, start, end), port);
+  scm_i_display_substring (str, start, end, port);
 
   if (pt->rw_random)
     pt->rw_active = SCM_PORT_WRITE;

libguile/ports.h

@@ -132,6 +132,10 @@ typedef struct
   scm_t_port_encoding_mode encoding_mode;
   scm_t_string_failed_conversion_handler ilseq_handler;
   scm_t_iconv_descriptors *iconv_descriptors;
+
+  /* an alist for storing additional information
+     (e.g. used to store per-port read options) */
+  SCM alist;
 } scm_t_port;
 
 

libguile/print.c

@@ -1229,6 +1229,29 @@ write_character (scm_t_wchar ch, SCM port, int string_escapes_p)
     write_character_escaped (ch, string_escapes_p, port);
 }
 
+/* Display STR to PORT from START inclusive to END exclusive.  */
+void
+scm_i_display_substring (SCM str, size_t start, size_t end, SCM port)
+{
+  int narrow_p;
+  const char *buf;
+  size_t len, printed;
+
+  buf = scm_i_string_data (str);
+  len = end - start;
+  narrow_p = scm_i_is_narrow_string (str);
+  buf += start * (narrow_p ? sizeof (char) : sizeof (scm_t_wchar));
+
+  printed = display_string (buf, narrow_p, end - start, port,
+			    PORT_CONVERSION_HANDLER (port));
+
+  if (SCM_UNLIKELY (printed < len))
+    scm_encoding_error (__func__, errno,
+			"cannot convert to output locale",
+			port, scm_c_string_ref (str, printed + start));
+}
+
+
 /* Print an integer.
  */
 

libguile/print.h

@@ -3,7 +3,8 @@
 #ifndef SCM_PRINT_H
 #define SCM_PRINT_H
 
-/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2004, 2006, 2008, 2010, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2004, 2006, 2008,
+ *   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 License
@@ -78,6 +79,8 @@ SCM_API SCM scm_print_options (SCM setting);
 SCM_API SCM scm_make_print_state (void);
 SCM_API void scm_free_print_state (SCM print_state);
 SCM_INTERNAL SCM scm_i_port_with_print_state (SCM port, SCM print_state);
+SCM_INTERNAL void scm_i_display_substring (SCM str, size_t start, size_t end,
+					   SCM port);
 SCM_API void scm_intprint (scm_t_intmax n, int radix, SCM port);
 SCM_API void scm_uintprint (scm_t_uintmax n, int radix, SCM port);
 SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port);

libguile/private-options.h

@@ -67,7 +67,8 @@ SCM_INTERNAL scm_t_option scm_read_opts[];
 #define SCM_R6RS_ESCAPES_P     scm_read_opts[4].val
 #define SCM_SQUARE_BRACKETS_P  scm_read_opts[5].val
 #define SCM_HUNGRY_EOL_ESCAPES_P scm_read_opts[6].val
+#define SCM_CURLY_INFIX_P      scm_read_opts[7].val
 
-#define SCM_N_READ_OPTIONS 6
+#define SCM_N_READ_OPTIONS 7
 
 #endif  /* PRIVATE_OPTIONS */ 

libguile/read.h

@@ -54,7 +54,6 @@ SCM_API SCM scm_sym_dot;
 
 SCM_API SCM scm_read_options (SCM setting);
 SCM_API SCM scm_read (SCM port);
-SCM_API size_t scm_read_token (int ic, SCM * tok_buf, SCM port, int weird);
 SCM_API SCM scm_read_hash_extend (SCM chr, SCM proc);
 SCM_INTERNAL char *scm_i_scan_for_encoding (SCM port);
 SCM_API SCM scm_file_encoding (SCM port);

libguile/srfi-13.c

@@ -2993,11 +2993,22 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0,
 #undef FUNC_NAME
 
 SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
-	    (SCM str, SCM chr),
+	    (SCM str, SCM char_pred),
 	    "Split the string @var{str} into a list of the substrings delimited\n"
-	    "by appearances of the character @var{chr}.  Note that an empty substring\n"
+            "by appearances of characters that\n"
-	    "between separator characters will result in an empty string in the\n"
+            "\n"
-	    "result list.\n"
+            "@itemize @bullet\n"
+            "@item\n"
+            "equal @var{char_pred}, if it is a character,\n"
+            "\n"
+            "@item\n"
+            "satisfy the predicate @var{char_pred}, if it is a procedure,\n"
+            "\n"
+            "@item\n"
+            "are in the set @var{char_pred}, if it is a character set.\n"
+            "@end itemize\n\n"
+            "Note that an empty substring between separator characters\n"
+            "will result in an empty string in the result list.\n"
 	    "\n"
 	    "@lisp\n"
 	    "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
@@ -3014,47 +3025,73 @@ SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
 	    "@end lisp")
 #define FUNC_NAME s_scm_string_split
 {
-  long idx, last_idx;
-  int narrow;
   SCM res = SCM_EOL;
 
   SCM_VALIDATE_STRING (1, str);
-  SCM_VALIDATE_CHAR (2, chr);
   
-  /* This is explicit wide/narrow logic (instead of using
+  if (SCM_CHARP (char_pred))
-     scm_i_string_ref) is a speed optimization.  */
-  idx = scm_i_string_length (str);
-  narrow = scm_i_is_narrow_string (str);
-  if (narrow)
     {
-      const char *buf = scm_i_string_chars (str);
+      long idx, last_idx;
-      while (idx >= 0)
+      int narrow;
+
+      /* This is explicit wide/narrow logic (instead of using
+         scm_i_string_ref) is a speed optimization.  */
+      idx = scm_i_string_length (str);
+      narrow = scm_i_is_narrow_string (str);
+      if (narrow)
         {
-          last_idx = idx;
+          const char *buf = scm_i_string_chars (str);
-          while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(chr))
+          while (idx >= 0)
-            idx--;
-          if (idx >= 0)
             {
-              res = scm_cons (scm_i_substring (str, idx, last_idx), res);
+              last_idx = idx;
-              idx--;
+              while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(char_pred))
+                idx--;
+              if (idx >= 0)
+                {
+                  res = scm_cons (scm_i_substring (str, idx, last_idx), res);
+                  idx--;
+                }
+            }
+        }
+      else
+        {
+          const scm_t_wchar *buf = scm_i_string_wide_chars (str);
+          while (idx >= 0)
+            {
+              last_idx = idx;
+              while (idx > 0 && buf[idx-1] != SCM_CHAR(char_pred))
+                idx--;
+              if (idx >= 0)
+                {
+                  res = scm_cons (scm_i_substring (str, idx, last_idx), res);
+                  idx--;
+                }
             }
         }
     }
   else
     {
-      const scm_t_wchar *buf = scm_i_string_wide_chars (str);
+      SCM sidx, slast_idx;
-      while (idx >= 0)
+
+      if (!SCM_CHARSETP (char_pred))
+        SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+                    char_pred, SCM_ARG2, FUNC_NAME);
+
+      /* Supporting predicates and character sets involves handling SCM
+         values so there is less chance to optimize. */
+      slast_idx = scm_string_length (str);
+      for (;;)
         {
-          last_idx = idx;
+          sidx = scm_string_index_right (str, char_pred, SCM_INUM0, slast_idx);
-          while (idx > 0 && buf[idx-1] != SCM_CHAR(chr))
+          if (scm_is_false (sidx))
-            idx--;
+            break;
-          if (idx >= 0)
+          res = scm_cons (scm_substring (str, scm_oneplus (sidx), slast_idx), res);
-            {
+          slast_idx = sidx;
-              res = scm_cons (scm_i_substring (str, idx, last_idx), res);
-              idx--;
-            }
         }
+
+      res = scm_cons (scm_substring (str, SCM_INUM0, slast_idx), res);
     }
+
   scm_remember_upto_here_1 (str);
   return res;
 }

libguile/srfi-13.h

@@ -110,7 +110,7 @@ SCM_API SCM scm_xsubstring (SCM s, SCM from, SCM to, SCM start, SCM end);
 SCM_API SCM scm_string_xcopy_x (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end);
 SCM_API SCM scm_string_replace (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
 SCM_API SCM scm_string_tokenize (SCM s, SCM token_char, SCM start, SCM end);
-SCM_API SCM scm_string_split (SCM s, SCM chr);
+SCM_API SCM scm_string_split (SCM s, SCM char_pred);
 SCM_API SCM scm_string_filter (SCM char_pred, SCM s, SCM start, SCM end);
 SCM_API SCM scm_string_delete (SCM char_pred, SCM s, SCM start, SCM end);
 

libguile/strings.c

@@ -1997,7 +1997,10 @@ u32_u8_length_in_bytes (const scm_t_uint32 *str, size_t len)
 
 char *
 scm_to_utf8_stringn (SCM str, size_t *lenp)
+#define FUNC_NAME "scm_to_utf8_stringn"
 {
+  SCM_VALIDATE_STRING (1, str);
+
   if (scm_i_is_narrow_string (str))
     return (char *) latin1_to_u8 ((scm_t_uint8 *) scm_i_string_chars (str),
                                   scm_i_string_length (str),
@@ -2044,6 +2047,7 @@ scm_to_utf8_stringn (SCM str, size_t *lenp)
       }
     }
 }
+#undef FUNC_NAME
 
 scm_t_wchar *
 scm_to_utf32_string (SCM str)

meta/Makefile.am

@@ -28,7 +28,7 @@ EXTRA_DIST= \
   guild.in guile-config.in
 
 # What we now call `guild' used to be known as `guile-tools'.
-install-data-hook:
+install-exec-hook:
 	guild="`echo $(ECHO_N) guild				\
 	   | $(SED) -e '$(program_transform_name)'`$(EXEEXT)" ;	\
 	guile_tools="`echo $(ECHO_N) guile-tools		\

module/ice-9/boot-9.scm

@@ -3137,8 +3137,11 @@ module '(ice-9 q) '(make-q q-length))}."
                 (lambda (option)
                   (apply (lambda (name value documentation)
                            (display name)
-                           (if (< (string-length (symbol->string name)) 8)
+                           (let ((len (string-length (symbol->string name))))
-                               (display #\tab))
+                             (when (< len 16)
+                               (display #\tab)
+                               (when (< len 8)
+                                 (display #\tab))))
                            (display #\tab)
                            (display value)
                            (display #\tab)
@@ -3509,7 +3512,9 @@ module '(ice-9 q) '(make-q q-length))}."
 (define-syntax define-public
   (syntax-rules ()
     ((_ (name . args) . body)
-     (define-public name (lambda args . body)))
+     (begin
+       (define name (lambda args . body))
+       (export name)))
     ((_ name val)
      (begin
        (define name val)
@@ -3899,7 +3904,7 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;;
 ;;; Currently, the following feature identifiers are supported:
 ;;;
-;;;   guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61
+;;;   guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61 srfi-105
 ;;;
 ;;; Remember to update the features list when adding more SRFIs.
 ;;;
@@ -3919,6 +3924,7 @@ module '(ice-9 q) '(make-q q-length))}."
     srfi-39  ;; parameterize
     srfi-55  ;; require-extension
     srfi-61  ;; general cond clause
+    srfi-105 ;; curly infix expressions
     ))
 
 ;; This table maps module public interfaces to the list of features.

module/ice-9/command-line.scm

@@ -1,6 +1,6 @@
 ;;; Parsing Guile's command-line
 
-;;; Copyright (C) 1994-1998, 2000-2011 Free Software Foundation, Inc.
+;;; Copyright (C) 1994-1998, 2000-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
@@ -325,7 +325,7 @@ If FILE begins with `-' the -s switch is mandatory.
 
            ((string=? arg "--listen")   ; start a repl server
             (parse args
-                (cons '(@@ (system repl server) (spawn-server)) out)))
+                   (cons '((@@ (system repl server) spawn-server)) out)))
            
            ((string-prefix? "--listen=" arg) ; start a repl server
             (parse
@@ -336,14 +336,12 @@ If FILE begins with `-' the -s switch is mandatory.
                  ((string->number where) ; --listen=PORT
                   => (lambda (port)
                        (if (and (integer? port) (exact? port) (>= port 0))
-                           `(@@ (system repl server)
+                           `((@@ (system repl server) spawn-server)
-                                (spawn-server
+                             ((@@ (system repl server) make-tcp-server-socket) #:port ,port))
-                                 (make-tcp-server-socket #:port ,port)))
                            (error "invalid port for --listen"))))
                  ((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET
-                  `(@@ (system repl server)
+                  `((@@ (system repl server) spawn-server)
-                       (spawn-server
+                    ((@@ (system repl server) make-unix-domain-server-socket) #:path ,where)))
-                        (make-unix-domain-server-socket #:path ,where))))
                  (else
                   (error "unknown argument to --listen"))))
               out)))

module/ice-9/curried-definitions.scm

@@ -16,7 +16,8 @@
 
 (define-module (ice-9 curried-definitions)
   #:replace ((cdefine . define)
-             (cdefine* . define*)))
+             (cdefine* . define*)
+             define-public))
 
 (define-syntax cdefine
   (syntax-rules ()
@@ -39,3 +40,14 @@
        (lambda* rest body body* ...)))
     ((_ . rest)
      (define* . rest))))
+
+(define-syntax define-public
+  (syntax-rules ()
+    ((_ (name . args) . body)
+     (begin
+       (cdefine (name . args) . body)
+       (export name)))
+    ((_ name val)
+     (begin
+       (define name val)
+       (export name)))))

module/ice-9/format.scm

@@ -427,15 +427,15 @@
                      (case modifier
                        ((at)
                         (format:out-str
-                         (with-output-to-string 
+                         (call-with-output-string
-                           (lambda ()
+                           (lambda (p)
-                             (truncated-print (next-arg)
+                             (truncated-print (next-arg) p
                                               #:width width)))))
                        ((colon-at)
                         (format:out-str
-                         (with-output-to-string 
+                         (call-with-output-string
-                           (lambda ()
+                           (lambda (p)
-                             (truncated-print (next-arg)
+                             (truncated-print (next-arg) p
                                               #:width
                                               (max (- width
                                                       output-col)
@@ -779,7 +779,7 @@
     (define (format:obj->str obj slashify)
       (let ((res (if slashify
                      (object->string obj)
-                     (with-output-to-string (lambda () (display obj))))))
+                     (call-with-output-string (lambda (p) (display obj p))))))
         (if (and format:read-proof (string-prefix? "#<" res))
             (object->string res)
             res)))

module/ice-9/regex.scm

@@ -172,8 +172,9 @@
     (let loop ((start 0)
                (value init)
                (abuts #f))              ; True if start abuts a previous match.
+      (define bol (if (zero? start) 0 regexp/notbol))
       (let ((m (if (> start (string-length string)) #f
-                   (regexp-exec regexp string start flags))))
+                   (regexp-exec regexp string start (logior flags bol)))))
         (cond
          ((not m) value)
          ((and (= (match:start m) (match:end m)) abuts)

module/language/tree-il/primitives.scm

@@ -516,6 +516,27 @@
 (define-primitive-expander f64vector-set! (vec i x)
   (bytevector-ieee-double-native-set! vec (* i 8) x))
 
+;; Appropriate for use with either 'eqv?' or 'equal?'.
+(define maybe-simplify-to-eq
+  (case-lambda
+    ((src a b)
+     ;; Simplify cases where either A or B is constant.
+     (define (maybe-simplify a b)
+       (and (const? a)
+            (let ((v (const-exp a)))
+              (and (or (memq v '(#f #t () #nil))
+                       (symbol? v)
+                       (and (integer? v)
+                            (exact? v)
+                            (<= v most-positive-fixnum)
+                            (>= v most-negative-fixnum)))
+                   (make-primcall src 'eq? (list a b))))))
+     (or (maybe-simplify a b) (maybe-simplify b a)))
+    (else #f)))
+
+(hashq-set! *primitive-expand-table* 'eqv?   maybe-simplify-to-eq)
+(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
+
 (hashq-set! *primitive-expand-table*
             '@dynamic-wind
             (case-lambda

module/srfi/srfi-19.scm

@@ -1113,13 +1113,13 @@
    (cons #\1 (lambda (date pad-with port)
                (display (date->string date "~Y-~m-~d") port)))
    (cons #\2 (lambda (date pad-with port)
-               (display (date->string date "~k:~M:~S~z") port)))
+               (display (date->string date "~H:~M:~S~z") port)))
    (cons #\3 (lambda (date pad-with port)
-               (display (date->string date "~k:~M:~S") port)))
+               (display (date->string date "~H:~M:~S") port)))
    (cons #\4 (lambda (date pad-with port)
-               (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port)))
+               (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port)))
    (cons #\5 (lambda (date pad-with port)
-               (display (date->string date "~Y-~m-~dT~k:~M:~S") port)))))
+               (display (date->string date "~Y-~m-~dT~H:~M:~S") port)))))
 
 
 (define (get-formatter char)

module/srfi/srfi-31.scm

@@ -1,6 +1,6 @@
 ;;; srfi-31.scm --- special form for recursive evaluation
 
-;; 	Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2004, 2006, 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
@@ -19,17 +19,15 @@
 ;;; Original author: Rob Browning <rlb@defaultvalue.org>
 
 (define-module (srfi srfi-31)
-  :export-syntax (rec))
+  #:export (rec))
 
-(define-macro (rec arg-form . body)
+(define-syntax rec
-  (cond
+  (syntax-rules ()
-   ((and (symbol? arg-form) (= 1 (length body)))
+    "Return the given object, defined in a lexical environment where
-    ;; (rec S (cons 1 (delay S)))
+NAME is bound to itself."
-    `(letrec ((,arg-form ,(car body)))
+    ((_ (name . formals) body ...)                ; procedure
-       ,arg-form))
+     (letrec ((name (lambda formals body ...)))
-   ;; (rec (f x) (+ x 1))
+       name))
-   ((list? arg-form)
+    ((_ name expr)                                ; arbitrary object
-    `(letrec ((,(car arg-form) (lambda ,(cdr arg-form) ,@body)))
+     (letrec ((name expr))
-       ,(car arg-form)))
+       name))))
-   (else
-    (error "syntax error in rec form" `(rec ,arg-form ,@body)))))

module/system/base/compile.scm

@@ -1,6 +1,6 @@
 ;;; High-level compiler interface
 
-;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 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
@@ -72,7 +72,7 @@
 ;; before the check, so that we avoid races (possibly due to parallel
 ;; compilation).
 ;;
-(define (ensure-writable-dir dir)
+(define (ensure-directory dir)
   (catch 'system-error
     (lambda ()
       (mkdir dir))
@@ -80,13 +80,12 @@
       (let ((errno (and (pair? rest) (car rest))))
         (cond
          ((eqv? errno EEXIST)
-          (let ((st (stat dir)))
+          ;; Assume it's a writable directory, to avoid TOCTOU errors,
-            (if (or (not (eq? (stat:type st) 'directory))
+          ;; as well as UID/EUID mismatches that occur with access(2).
-                    (not (access? dir W_OK)))
+          #t)
-                (error "directory not writable" dir))))
          ((eqv? errno ENOENT)
-          (ensure-writable-dir (dirname dir))
+          (ensure-directory (dirname dir))
-          (ensure-writable-dir dir))
+          (ensure-directory dir))
          (else
           (throw k subr fmt args rest)))))))
 
@@ -125,7 +124,7 @@
                  %compile-fallback-path
                  (canonical->suffix (canonicalize-path file))
                  (compiled-extension))))
-         (and (false-if-exception (ensure-writable-dir (dirname f)))
+         (and (false-if-exception (ensure-directory (dirname f)))
               f))))
 
 (define* (compile-file file #:key
@@ -144,7 +143,7 @@
       ;; Choose the input encoding deterministically.
       (set-port-encoding! in (or enc "UTF-8"))
 
-      (ensure-writable-dir (dirname comp))
+      (ensure-directory (dirname comp))
       (call-with-output-file/atomic comp
         (lambda (port)
           ((language-printer (ensure-language to))

module/texinfo.scm

@@ -384,8 +384,14 @@ Examples:
 
 ;; Like a DTD for texinfo
 (define (command-spec command)
-  (or (assq command texi-command-specs)
+  (let ((spec (assq command texi-command-specs)))
-      (parser-error #f "Unknown command" command)))
+    (cond
+     ((not spec)
+      (parser-error #f "Unknown command" command))
+     ((eq? (cadr spec) 'ALIAS)
+      (command-spec (cddr spec)))
+     (else
+      spec))))
 
 (define (inline-content? content)
   (case content
@@ -647,11 +653,10 @@ Examples:
     (arguments->attlist port (read-arguments port stop-char) arg-names))
 
   (let* ((spec (command-spec command))
+         (command (car spec))
          (type (cadr spec))
          (arg-names (cddr spec)))
     (case type
-      ((ALIAS)
-       (complete-start-command arg-names port))
       ((INLINE-TEXT)
        (assert-curr-char '(#\{) "Inline element lacks {" port)
        (values command '() type))
@@ -954,7 +959,9 @@ Examples:
                          (loop port expect-eof? end-para need-break? seed)))
                       ((START)          ; Start of an @-command
                        (let* ((head (token-head token))
-                              (type (cadr (command-spec head)))
+                              (spec (command-spec head))
+                              (head (car spec))
+                              (type (cadr spec))
                               (inline? (inline-content? type))
                               (seed ((if (and inline? (not need-break?))
                                          identity end-para) seed))
@@ -1045,8 +1052,9 @@ Examples:
    (lambda (command args content seed)      ; fdown
      '())
    (lambda (command args parent-seed seed)  ; fup
-     (let ((seed (reverse-collect-str-drop-ws seed))
+     (let* ((seed (reverse-collect-str-drop-ws seed))
-           (spec (command-spec command)))
+            (spec (command-spec command))
+            (command (car spec)))
        (if (eq? (cadr spec) 'INLINE-TEXT-ARGS)
            (cons (list command (cons '% (parse-inline-text-args #f spec seed)))
                  parent-seed)
@@ -1062,8 +1070,10 @@ Examples:
   (let ((parser (make-dom-parser)))
     ;; duplicate arguments->attlist to avoid unnecessary splitting
     (lambda (command port)
-      (let ((args (cdar (parser '*ENVIRON-ARGS* port '())))
+      (let* ((args (cdar (parser '*ENVIRON-ARGS* port '())))
-            (arg-names (cddr (command-spec command))))
+             (spec (command-spec command))
+             (command (car spec))
+             (arg-names (cddr spec)))
         (cond
          ((not arg-names)
           (if (null? args) '()

module/web/client.scm

@@ -1,6 +1,6 @@
 ;;; Web client
 
-;; Copyright (C) 2011 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -42,19 +42,37 @@
             http-get))
 
 (define (open-socket-for-uri uri)
-  (let* ((ai (car (getaddrinfo (uri-host uri)
+  "Return an open input/output port for a connection to URI."
-                               (cond
+  (define addresses
-                                ((uri-port uri) => number->string)
+    (let ((port (uri-port uri)))
-                                (else (symbol->string (uri-scheme uri)))))))
+      (getaddrinfo (uri-host uri)
-         (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+                   (cond (port => number->string)
-                     (addrinfo:protocol ai))))
+                         (else (symbol->string (uri-scheme uri))))
-    (set-port-encoding! s "ISO-8859-1")
+                   (if port
-    (connect s (addrinfo:addr ai))
+                       AI_NUMERICSERV
-    ;; Buffer input and output on this port.
+                       0))))
-    (setvbuf s _IOFBF)
+
-    ;; Enlarge the receive buffer.
+  (let loop ((addresses addresses))
-    (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
+    (let* ((ai (car addresses))
-    s))
+           (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+                       (addrinfo:protocol ai))))
+      (set-port-encoding! s "ISO-8859-1")
+
+      (catch 'system-error
+        (lambda ()
+          (connect s (addrinfo:addr ai))
+
+          ;; Buffer input and output on this port.
+          (setvbuf s _IOFBF)
+          ;; Enlarge the receive buffer.
+          (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
+          s)
+        (lambda args
+          ;; Connection failed, so try one of the other addresses.
+          (close s)
+          (if (null? addresses)
+              (apply throw args)
+              (loop (cdr addresses))))))))
 
 (define (decode-string bv encoding)
   (if (string-ci=? encoding "utf-8")

module/web/uri.scm

@@ -364,7 +364,9 @@ Percent-encoding first writes out the given character to a bytevector
 within the given @var{encoding}, then encodes each byte as
 @code{%@var{HH}}, where @var{HH} is the hexadecimal representation of
 the byte."
-  (if (string-index str unescaped-chars)
+  (define (needs-escaped? ch)
+    (not (char-set-contains? unescaped-chars ch)))
+  (if (string-index str needs-escaped?)
       (call-with-output-string*
        (lambda (port)
          (string-for-each
@@ -377,6 +379,8 @@ the byte."
                     (if (< i len)
                         (let ((byte (bytevector-u8-ref bv i)))
                           (display #\% port)
+                          (when (< byte 16)
+                            (display #\0 port))
                           (display (number->string byte 16) port)
                           (lp (1+ i))))))))
           str)))

test-suite/Makefile.am

@@ -136,6 +136,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/srfi-67.test			\
 	    tests/srfi-69.test			\
 	    tests/srfi-88.test			\
+	    tests/srfi-105.test			\
 	    tests/srfi-4.test			\
 	    tests/srfi-9.test			\
 	    tests/statprof.test			\

test-suite/tests/chars.test

@@ -45,18 +45,18 @@
     (pass-if "char=? #\\A #\\A"
       (char=? #\A #\A))
 
-    (expect-fail "char=? #\\A #\\a"
+    (pass-if "char=? #\\A #\\a"
-      (char=? #\A #\a))
+      (not (char=? #\A #\a)))
 
-    (expect-fail "char=? #\\A #\\B"
+    (pass-if "char=? #\\A #\\B"
-      (char=? #\A #\B))
+      (not (char=? #\A #\B)))
 
-    (expect-fail "char=? #\\B #\\A"
+    (pass-if "char=? #\\B #\\A"
-      (char=? #\A #\B))
+      (not (char=? #\A #\B)))
 
     ;; char<?
-    (expect-fail "char<? #\\A #\\A"
+    (pass-if "char<? #\\A #\\A"
-      (char<? #\A #\A))
+      (not (char<? #\A #\A)))
 
     (pass-if "char<? #\\A #\\a"
       (char<? #\A #\a))
@@ -64,8 +64,8 @@
     (pass-if "char<? #\\A #\\B"
       (char<? #\A #\B))
 
-    (expect-fail "char<? #\\B #\\A"
+    (pass-if "char<? #\\B #\\A"
-      (char<? #\B #\A))
+      (not (char<? #\B #\A)))
 
     ;; char<=?
     (pass-if "char<=? #\\A #\\A"
@@ -77,18 +77,18 @@
     (pass-if "char<=? #\\A #\\B"
       (char<=? #\A #\B))
 
-    (expect-fail "char<=? #\\B #\\A"
+    (pass-if "char<=? #\\B #\\A"
-      (char<=? #\B #\A))
+      (not (char<=? #\B #\A)))
 
     ;; char>?
-    (expect-fail "char>? #\\A #\\A"
+    (pass-if "char>? #\\A #\\A"
-      (char>? #\A #\A))
+      (not (char>? #\A #\A)))
 
-    (expect-fail "char>? #\\A #\\a"
+    (pass-if "char>? #\\A #\\a"
-      (char>? #\A #\a))
+      (not (char>? #\A #\a)))
 
-    (expect-fail "char>? #\\A #\\B"
+    (pass-if "char>? #\\A #\\B"
-      (char>? #\A #\B))
+      (not (char>? #\A #\B)))
 
     (pass-if "char>? #\\B #\\A"
       (char>? #\B #\A))
@@ -97,11 +97,11 @@
     (pass-if "char>=? #\\A #\\A"
       (char>=? #\A #\A))
 
-    (expect-fail "char>=? #\\A #\\a"
+    (pass-if "char>=? #\\A #\\a"
-      (char>=? #\A #\a))
+      (not (char>=? #\A #\a)))
 
-    (expect-fail "char>=? #\\A #\\B"
+    (pass-if "char>=? #\\A #\\B"
-      (char>=? #\A #\B))
+      (not (char>=? #\A #\B)))
 
     (pass-if "char>=? #\\B #\\A"
       (char>=? #\B #\A))
@@ -113,24 +113,24 @@
     (pass-if "char-ci=? #\\A #\\a"
       (char-ci=? #\A #\a))
 
-    (expect-fail "char-ci=? #\\A #\\B"
+    (pass-if "char-ci=? #\\A #\\B"
-      (char-ci=? #\A #\B))
+      (not (char-ci=? #\A #\B)))
 
-    (expect-fail "char-ci=? #\\B #\\A"
+    (pass-if "char-ci=? #\\B #\\A"
-      (char-ci=? #\A #\B))
+      (not (char-ci=? #\A #\B)))
 
     ;; char-ci<?
-    (expect-fail "char-ci<? #\\A #\\A"
+    (pass-if "char-ci<? #\\A #\\A"
-      (char-ci<? #\A #\A))
+      (not (char-ci<? #\A #\A)))
 
-    (expect-fail "char-ci<? #\\A #\\a"
+    (pass-if "char-ci<? #\\A #\\a"
-      (char-ci<? #\A #\a))
+      (not (char-ci<? #\A #\a)))
 
     (pass-if "char-ci<? #\\A #\\B"
       (char-ci<? #\A #\B))
 
-    (expect-fail "char-ci<? #\\B #\\A"
+    (pass-if "char-ci<? #\\B #\\A"
-      (char-ci<? #\B #\A))
+      (not (char-ci<? #\B #\A)))
 
     ;; char-ci<=?
     (pass-if "char-ci<=? #\\A #\\A"
@@ -142,18 +142,18 @@
     (pass-if "char-ci<=? #\\A #\\B"
       (char-ci<=? #\A #\B))
 
-    (expect-fail "char-ci<=? #\\B #\\A"
+    (pass-if "char-ci<=? #\\B #\\A"
-      (char-ci<=? #\B #\A))
+      (not (char-ci<=? #\B #\A)))
 
     ;; char-ci>?
-    (expect-fail "char-ci>? #\\A #\\A"
+    (pass-if "char-ci>? #\\A #\\A"
-      (char-ci>? #\A #\A))
+      (not (char-ci>? #\A #\A)))
 
-    (expect-fail "char-ci>? #\\A #\\a"
+    (pass-if "char-ci>? #\\A #\\a"
-      (char-ci>? #\A #\a))
+      (not (char-ci>? #\A #\a)))
 
-    (expect-fail "char-ci>? #\\A #\\B"
+    (pass-if "char-ci>? #\\A #\\B"
-      (char-ci>? #\A #\B))
+      (not (char-ci>? #\A #\B)))
 
     (pass-if "char-ci>? #\\B #\\A"
       (char-ci>? #\B #\A))
@@ -165,8 +165,8 @@
     (pass-if "char-ci>=? #\\A #\\a"
       (char-ci>=? #\A #\a))
 
-    (expect-fail "char-ci>=? #\\A #\\B"
+    (pass-if "char-ci>=? #\\A #\\B"
-      (char-ci>=? #\A #\B))
+      (not (char-ci>=? #\A #\B)))
 
     (pass-if "char-ci>=? #\\B #\\A"
       (char-ci>=? #\B #\A)))

test-suite/tests/list.test

@@ -439,15 +439,15 @@
 
   (with-test-prefix "wrong argument"
 
-    (expect-fail-exception "improper list and empty list"
+    (pass-if-exception "improper list and empty list"
       exception:wrong-type-arg
       (append! (cons 1 2) '()))
 
-    (expect-fail-exception "improper list and list"
+    (pass-if-exception "improper list and list"
       exception:wrong-type-arg
       (append! (cons 1 2) (list 3 4)))
 
-    (expect-fail-exception "list, improper list and list"
+    (pass-if-exception "list, improper list and list"
       exception:wrong-type-arg
       (append! (list 1 2) (cons 3 4) (list 5 6)))
 

test-suite/tests/numbers.test

@@ -4845,7 +4845,7 @@
                     (test+/- n d))))))
 
     (with-test-prefix "divide by zero"
-      (for `((0 0.0 +0.0))  ;; denominators
+      (for `((0 0.0 -0.0))  ;; denominators
            (lambda (d)
              (for `((15 ,(* 3/2 big) 18.0 33/7
                         0 0.0 -0.0 +inf.0 -inf.0 +nan.0))  ;; numerators

test-suite/tests/reader.test

@@ -401,6 +401,19 @@
         (lambda ()
           (read-disable 'hungry-eol-escapes))))))
 
+(with-test-prefix "per-port-read-options"
+  (pass-if "case-sensitive"
+    (equal? '(guile GuiLe gUIle)
+            (with-read-options '(case-insensitive)
+              (lambda ()
+                (with-input-from-string "GUIle #!no-fold-case GuiLe gUIle"
+                  (lambda ()
+                    (list (read) (read) (read))))))))
+  (pass-if "case-insensitive"
+    (equal? '(GUIle guile guile)
+            (with-input-from-string "GUIle #!fold-case GuiLe gUIle"
+              (lambda ()
+                (list (read) (read) (read)))))))
 
 (with-test-prefix "#;"
   (for-each

test-suite/tests/regexp.test

@@ -1,8 +1,9 @@
 ;;;; regexp.test ---  test Guile's regexps   -*- coding: utf-8; mode: scheme -*-
 ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
 ;;;;
-;;;; 	Copyright (C) 1999, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 1999, 2004, 2006, 2007, 2008, 2009, 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
 ;;;; License as published by the Free Software Foundation; either
@@ -131,7 +132,14 @@
                    (lambda (match result)
                      (cons (match:substring match)
                            result))
-                   (logior regexp/notbol regexp/noteol)))))
+                   (logior regexp/notbol regexp/noteol))))
+
+  (pass-if "regexp/notbol is set correctly"
+    (equal? '("foo")
+            (fold-matches "^foo" "foofoofoofoo" '()
+                          (lambda (match result)
+                            (cons (match:substring match)
+                                  result))))))
 
 
 ;;;
@@ -282,4 +290,12 @@
     (with-locale "en_US.utf8"
       ;; bug #31650
       (equal? (match:substring (string-match ".*" "calçot") 0)
-              "calçot"))))
+              "calçot")))
+
+  (pass-if "match structures refer to char offsets, non-ASCII pattern"
+    (with-locale "en_US.utf8"
+      ;; bug #31650
+      (equal? (match:substring (string-match "λ: The Ultimate (.*)"
+                                             "λ: The Ultimate GOTO")
+                               1)
+              "GOTO"))))

test-suite/tests/srfi-105.test

@@ -0,0 +1,240 @@
+;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 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 the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-105)
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-1))
+
+(define (read-string s)
+  (with-fluids ((%default-port-encoding #f))
+    (with-input-from-string s read)))
+
+(define (with-read-options opts thunk)
+  (let ((saved-options (read-options)))
+    (dynamic-wind
+        (lambda ()
+          (read-options opts))
+        thunk
+        (lambda ()
+          (read-options saved-options)))))
+
+;; Verify that curly braces are allowed in identifiers and that neoteric
+;; expressions are not recognized by default.
+(with-test-prefix "no-curly-infix"
+  (pass-if (equal? '({f(x) + g[y] + h{z} + [a]})
+                   `(,(string->symbol "{f")
+                     (x) + g [y] +
+                     ,(string->symbol "h{z}")
+                     + [a]
+                     ,(string->symbol "}")))))
+
+#!curly-infix
+
+(with-test-prefix "curly-infix"
+  (pass-if (equal? '{n <= 5}                '(<= n 5)))
+  (pass-if (equal? '{x + 1}                 '(+ x 1)))
+  (pass-if (equal? '{a + b + c}             '(+ a b c)))
+  (pass-if (equal? '{x ,op y ,op z}         '(,op x y z)))
+  (pass-if (equal? '{x eqv? `a}             '(eqv? x `a)))
+  (pass-if (equal? '{'a eq? b}              '(eq? 'a b)))
+  (pass-if (equal? '{n-1 + n-2}             '(+ n-1 n-2)))
+  (pass-if (equal? '{a * {b + c}}           '(* a (+ b c))))
+  (pass-if (equal? '{a + {b - c}}           '(+ a (- b c))))
+  (pass-if (equal? '{{a + b} - c}           '(- (+ a b) c)))
+  (pass-if (equal? '{{a > 0} and {b >= 1}}  '(and (> a 0) (>= b 1))))
+  (pass-if (equal? '{}                      '()))
+  (pass-if (equal? '{5}                     '5))
+  (pass-if (equal? '{- x}                   '(- x)))
+  (pass-if (equal? '{length(x) >= 6}        '(>= (length x) 6)))
+  (pass-if (equal? '{f(x) + g(y) + h(z)}    '(+ (f x) (g y) (h z))))
+  (pass-if (equal? '{(f a b) + (g h)}       '(+ (f a b) (g h))))
+  (pass-if (equal? '{f(a b) + g(h)}         '(+ (f a b) (g h))))
+  (pass-if (equal? ''{a + f(b) + x}         ''(+ a (f b) x)))
+  (pass-if (equal? '{(- a) / b}             '(/ (- a) b)))
+  (pass-if (equal? '{-(a) / b}              '(/ (- a) b)))
+  (pass-if (equal? '{cos(q)}                '(cos q)))
+  (pass-if (equal? '{e{}}                   '(e)))
+  (pass-if (equal? '{pi{}}                  '(pi)))
+  (pass-if (equal? '{'f(x)}                 '(quote (f x))))
+
+  (pass-if (equal? '{ (f (g h(x))) }        '(f (g (h x)))))
+  (pass-if (equal? '{#(1 2 f(a) 4)}         '#(1 2 (f a) 4)))
+  (pass-if (equal? '{ (f #;g(x) h(x)) }     '(f (h x))))
+  (pass-if (equal? '{ (f #; g(x)[y] h(x)) } '(f (h x))))
+  (pass-if (equal? '{ (f #; g[x]{y} h(x)) } '(f (h x))))
+
+  (pass-if (equal? '{ (f #(g h(x))) }       '(f #(g (h x)))))
+  (pass-if (equal? '{ (f '(g h(x))) }       '(f '(g (h x)))))
+  (pass-if (equal? '{ (f `(g h(x))) }       '(f `(g (h x)))))
+  (pass-if (equal? '{ (f #'(g h(x))) }      '(f #'(g (h x)))))
+  (pass-if (equal? '{ (f #2((g) (h(x)))) }  '(f #2((g) ((h x))))))
+
+  (pass-if (equal? '{(map - ns)}            '(map - ns)))
+  (pass-if (equal? '{map(- ns)}             '(map - ns)))
+  (pass-if (equal? '{n * factorial{n - 1}}  '(* n (factorial (- n 1)))))
+  (pass-if (equal? '{2 * sin{- x}}          '(* 2 (sin (- x)))))
+
+  (pass-if (equal? '{3 + 4 +}               '($nfx$ 3 + 4 +)))
+  (pass-if (equal? '{3 + 4 + 5 +}           '($nfx$ 3 + 4 + 5 +)))
+  (pass-if (equal? '{a . z}                 '($nfx$ a . z)))
+  (pass-if (equal? '{a + b - c}             '($nfx$ a + b - c)))
+
+  (pass-if (equal? '{read(. options)}       '(read . options)))
+
+  (pass-if (equal? '{a(x)(y)}               '((a x) y)))
+  (pass-if (equal? '{x[a]}                  '($bracket-apply$ x a)))
+  (pass-if (equal? '{y[a b]}                '($bracket-apply$ y a b)))
+
+  (pass-if (equal? '{f(g(x))}               '(f (g x))))
+  (pass-if (equal? '{f(g(x) h(x))}          '(f (g x) (h x))))
+
+
+  (pass-if (equal? '{}                      '()))
+  (pass-if (equal? '{e}                     'e))
+  (pass-if (equal? '{e1 e2}                 '(e1 e2)))
+
+  (pass-if (equal? '{a . t}                 '($nfx$ a . t)))
+  (pass-if (equal? '{a b . t}               '($nfx$ a b . t)))
+  (pass-if (equal? '{a b c . t}             '($nfx$ a b c . t)))
+  (pass-if (equal? '{a b c d . t}           '($nfx$ a b c d . t)))
+  (pass-if (equal? '{a + b +}               '($nfx$ a + b +)))
+  (pass-if (equal? '{a + b + c +}           '($nfx$ a + b + c +)))
+  (pass-if (equal? '{q + r * s}             '($nfx$ q + r * s)))
+
+  ;; The following two tests will become relevant when Guile's reader
+  ;; supports datum labels, specified in SRFI-38 (External
+  ;; Representation for Data With Shared Structure).
+
+  ;;(pass-if (equal? '{#1=f(#1#)}             '#1=(f #1#)))
+  ;;(pass-if (equal? '#1={a + . #1#}          '($nfx$ . #1=(a + . #1#))))
+
+  (pass-if (equal? '{e()}                   '(e)))
+  (pass-if (equal? '{e{}}                   '(e)))
+  (pass-if (equal? '{e(1)}                  '(e 1)))
+  (pass-if (equal? '{e{1}}                  '(e 1)))
+  (pass-if (equal? '{e(1 2)}                '(e 1 2)))
+  (pass-if (equal? '{e{1 2}}                '(e (1 2))))
+  (pass-if (equal? '{f{n - 1}}              '(f (- n 1))))
+  (pass-if (equal? '{f{n - 1}(x)}           '((f (- n 1)) x)))
+  (pass-if (equal? '{f{n - 1}{y - 1}}       '((f (- n 1)) (- y 1))))
+  (pass-if (equal? '{f{- x}[y]}             '($bracket-apply$ (f (- x)) y)))
+  (pass-if (equal? '{g{- x}}                '(g (- x))))
+  (pass-if (equal? '{( . e)}                'e))
+
+  (pass-if (equal? '{e[]}                   '($bracket-apply$ e)))
+  (pass-if (equal? '{e[1 2]}                '($bracket-apply$ e 1 2)))
+  (pass-if (equal? '{e[1 . 2]}              '($bracket-apply$ e 1 . 2)))
+
+  ;; Verify that source position information is not recorded if not
+  ;; asked for.
+  (with-test-prefix "no positions"
+    (pass-if "simple curly-infix list"
+      (let ((sexp (with-read-options '(curly-infix)
+                    (lambda ()
+                      (read-string " {1 + 2 + 3}")))))
+        (and (not (source-property sexp 'line))
+             (not (source-property sexp 'column)))))
+    (pass-if "mixed curly-infix list"
+      (let ((sexp (with-read-options '(curly-infix)
+                    (lambda ()
+                      (read-string " {1 + 2 * 3}")))))
+        (and (not (source-property sexp 'line))
+             (not (source-property sexp 'column)))))
+    (pass-if "singleton curly-infix list"
+      (let ((sexp (with-read-options '(curly-infix)
+                    (lambda ()
+                      (read-string " { 1.0 }")))))
+        (and (not (source-property sexp 'line))
+             (not (source-property sexp 'column)))))
+    (pass-if "neoteric expression"
+      (let ((sexp (with-read-options '(curly-infix)
+                    (lambda ()
+                      (read-string " { f(x) }")))))
+        (and (not (source-property sexp 'line))
+             (not (source-property sexp 'column))))))
+
+  ;; Verify that source position information is properly recorded.
+  (with-test-prefix "positions"
+    (pass-if "simple curly-infix list"
+      (let ((sexp (with-read-options '(curly-infix positions)
+                    (lambda ()
+                      (read-string " {1 + 2 + 3}")))))
+        (and (equal? (source-property sexp 'line) 0)
+             (equal? (source-property sexp 'column) 1))))
+    (pass-if "mixed curly-infix list"
+      (let ((sexp (with-read-options '(curly-infix positions)
+                    (lambda ()
+                      (read-string " {1 + 2 * 3}")))))
+        (and (equal? (source-property sexp 'line) 0)
+             (equal? (source-property sexp 'column) 1))))
+    (pass-if "singleton curly-infix list"
+      (let ((sexp (with-read-options '(curly-infix positions)
+                    (lambda ()
+                      (read-string " { 1.0 }")))))
+        (and (equal? (source-property sexp 'line) 0)
+             (equal? (source-property sexp 'column) 3))))
+    (pass-if "neoteric expression"
+      (let ((sexp (with-read-options '(curly-infix positions)
+                    (lambda ()
+                      (read-string " { f(x) }")))))
+        (and (equal? (source-property sexp 'line) 0)
+             (equal? (source-property sexp 'column) 3)))))
+
+  ;; Verify that neoteric expressions are recognized only within curly braces.
+  (pass-if (equal? '(a(x)(y))               '(a (x) (y))))
+  (pass-if (equal? '(x[a])                  '(x [a])))
+  (pass-if (equal? '(y[a b])                '(y [a b])))
+  (pass-if (equal? '(a f{n - 1})            '(a f (- n 1))))
+  (pass-if (equal? '(a f{n - 1}(x))         '(a f (- n 1) (x))))
+  (pass-if (equal? '(a f{n - 1}[x])         '(a f (- n 1) [x])))
+  (pass-if (equal? '(a f{n - 1}{y - 1})     '(a f (- n 1) (- y 1))))
+
+  ;; Verify that bracket lists are not recognized by default.
+  (pass-if (equal? '{[]}                    '()))
+  (pass-if (equal? '{[a]}                   '(a)))
+  (pass-if (equal? '{[a b]}                 '(a b)))
+  (pass-if (equal? '{[a . b]}               '(a . b)))
+  (pass-if (equal? '[]                      '()))
+  (pass-if (equal? '[a]                     '(a)))
+  (pass-if (equal? '[a b]                   '(a b)))
+  (pass-if (equal? '[a . b]                 '(a . b))))
+
+
+#!curly-infix-and-bracket-lists
+
+(with-test-prefix "curly-infix-and-bracket-lists"
+  ;; Verify that these neoteric expressions still work properly
+  ;; when the 'square-brackets' read option is unset (which is done by
+  ;; the '#!curly-infix-and-bracket-lists' reader directive above).
+  (pass-if (equal? '{e[]}                   '($bracket-apply$ e)))
+  (pass-if (equal? '{e[1 2]}                '($bracket-apply$ e 1 2)))
+  (pass-if (equal? '{e[1 . 2]}              '($bracket-apply$ e 1 . 2)))
+
+  ;; The following expressions are not actually part of SRFI-105, but
+  ;; they are handled when the 'curly-infix' read option is set and the
+  ;; 'square-brackets' read option is unset.  This is a non-standard
+  ;; extension of SRFI-105, and follows the convention of GNU Kawa.
+  (pass-if (equal? '{[]}                    '($bracket-list$)))
+  (pass-if (equal? '{[a]}                   '($bracket-list$ a)))
+  (pass-if (equal? '{[a b]}                 '($bracket-list$ a b)))
+  (pass-if (equal? '{[a . b]}               '($bracket-list$ a . b)))
+
+  (pass-if (equal? '[]                      '($bracket-list$)))
+  (pass-if (equal? '[a]                     '($bracket-list$ a)))
+  (pass-if (equal? '[a b]                   '($bracket-list$ a b)))
+  (pass-if (equal? '[a . b]                 '($bracket-list$ a . b))))

test-suite/tests/srfi-31.test

@@ -1,6 +1,6 @@
 ;;;; srfi-31.test --- Test suite for Guile's SRFI-31 functions. -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2004, 2006, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2006, 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
@@ -22,9 +22,10 @@
 
 (with-test-prefix "rec special form"
 
-  (pass-if-exception "bogus variable" '(misc-error . ".*")
+  (pass-if-exception "bogus variable"
+    exception:syntax-pattern-unmatched
     (eval '(rec #:foo) (current-module)))
-  
+
   (pass-if "rec expressions"
     (let ((ones-list (rec ones (cons 1 (delay ones)))))
       (and (= 1 (car ones-list))

test-suite/tests/strings.test

@@ -557,7 +557,67 @@
   (pass-if "char 255"
     (equal? '("a" "b")
 	    (string-split (string #\a (integer->char 255) #\b)
-			  (integer->char 255)))))
+			  (integer->char 255))))
+
+  (pass-if "empty string - char"
+    (equal? '("")
+            (string-split "" #\:)))
+
+  (pass-if "non-empty - char - no delimiters"
+    (equal? '("foobarfrob")
+            (string-split "foobarfrob" #\:)))
+
+  (pass-if "non-empty - char - delimiters"
+    (equal? '("foo" "bar" "frob")
+            (string-split "foo:bar:frob" #\:)))
+
+  (pass-if "non-empty - char - leading delimiters"
+    (equal? '("" "" "foo" "bar" "frob")
+            (string-split "::foo:bar:frob" #\:)))
+
+  (pass-if "non-empty - char - trailing delimiters"
+    (equal? '("foo" "bar" "frob" "" "")
+            (string-split "foo:bar:frob::" #\:)))
+
+  (pass-if "empty string - charset"
+    (equal? '("")
+            (string-split "" (char-set #\:))))
+
+  (pass-if "non-empty - charset - no delimiters"
+    (equal? '("foobarfrob")
+            (string-split "foobarfrob" (char-set #\:))))
+
+  (pass-if "non-empty - charset - delimiters"
+    (equal? '("foo" "bar" "frob")
+            (string-split "foo:bar:frob" (char-set #\:))))
+
+  (pass-if "non-empty - charset - leading delimiters"
+    (equal? '("" "" "foo" "bar" "frob")
+            (string-split "::foo:bar:frob" (char-set #\:))))
+
+  (pass-if "non-empty - charset - trailing delimiters"
+    (equal? '("foo" "bar" "frob" "" "")
+            (string-split "foo:bar:frob::" (char-set #\:))))
+
+  (pass-if "empty string - pred"
+    (equal? '("")
+            (string-split "" (negate char-alphabetic?))))
+
+  (pass-if "non-empty - pred - no delimiters"
+    (equal? '("foobarfrob")
+            (string-split "foobarfrob" (negate char-alphabetic?))))
+
+  (pass-if "non-empty - pred - delimiters"
+    (equal? '("foo" "bar" "frob")
+            (string-split "foo:bar:frob" (negate char-alphabetic?))))
+
+  (pass-if "non-empty - pred - leading delimiters"
+    (equal? '("" "" "foo" "bar" "frob")
+            (string-split "::foo:bar:frob" (negate char-alphabetic?))))
+
+  (pass-if "non-empty - pred - trailing delimiters"
+    (equal? '("foo" "bar" "frob" "" "")
+            (string-split "foo:bar:frob::" (negate char-alphabetic?)))))
 
 (with-test-prefix "substring-move!"
 

test-suite/tests/structs.test

@@ -126,7 +126,49 @@
      (not (or (equal? (make-ball red "Bob") (make-ball green "Bob"))
 	      (equal? (make-ball red "Bob") (make-ball red "Bill"))))))
 
+
+(with-test-prefix "hash"
 
+  (pass-if "simple structs"
+    (let* ((v  (make-vtable "pr"))
+           (s1 (make-struct v 0 "hello"))
+           (s2 (make-struct v 0 "hello")))
+      (= (hash s1 7777) (hash s2 7777))))
+
+  (pass-if "different structs"
+    (let* ((v  (make-vtable "pr"))
+           (s1 (make-struct v 0 "hello"))
+           (s2 (make-struct v 0 "world")))
+      (or (not (= (hash s1 7777) (hash s2 7777)))
+          (throw 'unresolved))))
+
+  (pass-if "different struct types"
+    (let* ((v1 (make-vtable "pr"))
+           (v2 (make-vtable "pr"))
+           (s1 (make-struct v1 0 "hello"))
+           (s2 (make-struct v2 0 "hello")))
+      (or (not (= (hash s1 7777) (hash s2 7777)))
+          (throw 'unresolved))))
+
+  (pass-if "more complex structs"
+    (let ((s1 (make-ball red (string-copy "Bob")))
+          (s2 (make-ball red (string-copy "Bob"))))
+      (= (hash s1 7777) (hash s2 7777))))
+
+  (pass-if "struct with weird fields"
+    (let* ((v  (make-vtable "prurph"))
+           (s1 (make-struct v 0 "hello" 123 "invisible-secret1"))
+           (s2 (make-struct v 0 "hello" 123 "invisible-secret2")))
+      (= (hash s1 7777) (hash s2 7777))))
+
+  (pass-if "cyclic structs"
+    (let* ((v (make-vtable "pw"))
+           (a (make-struct v 0 #f))
+           (b (make-struct v 0 a)))
+      (struct-set! a 0 b)
+      (and (hash a 7777) (hash b 7777) #t))))
+
+
 ;;
 ;; make-struct
 ;;

test-suite/tests/texinfo.test

@@ -208,9 +208,8 @@
 
   (test-body "@code{arg}"
              '((para (code "arg"))))
-  ;; FIXME: Why no enclosing para here?  Probably a bug.
   (test-body "@url{arg}"
-             '((uref (% (url "arg")))))
+             '((para (uref (% (url "arg"))))))
   (test-body "@code{     }"
              '((para (code))))
   (test-body "@code{ @code{}    }"

test-suite/tests/tree-il.test

@@ -58,6 +58,20 @@
      (assert-tree-il->glil with-partial-evaluation
                            in pat test ...))))
 
+(define-syntax-rule (pass-if-primitives-resolved in expected)
+  (pass-if (format #f "primitives-resolved in ~s" 'in)
+    (let* ((module   (let ((m (make-module)))
+                       (beautify-user-module! m)
+                       m))
+           (orig     (parse-tree-il 'in))
+           (resolved (expand-primitives! (resolve-primitives! orig module))))
+      (or (equal? (unparse-tree-il resolved) 'expected)
+          (begin
+            (format (current-error-port)
+                    "primitive test failed: got ~s, expected ~s"
+                    resolved 'expected)
+            #f)))))
+
 (define-syntax pass-if-tree-il->scheme
   (syntax-rules ()
     ((_ in pat)
@@ -69,6 +83,69 @@
          (pat (guard guard-exp) #t)
          (_ #f))))))
 
+
+(with-test-prefix "primitives"
+
+  (with-test-prefix "eqv?"
+
+    (pass-if-primitives-resolved
+        (primcall eqv? (toplevel x) (const #f))
+      (primcall eq? (const #f) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (primcall eqv? (toplevel x) (const ()))
+      (primcall eq? (const ()) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (primcall eqv? (const #t) (lexical x y))
+      (primcall eq? (const #t) (lexical x y)))
+
+    (pass-if-primitives-resolved
+        (primcall eqv? (const this-is-a-symbol) (toplevel x))
+      (primcall eq? (const this-is-a-symbol) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (primcall eqv? (const 42) (toplevel x))
+      (primcall eq? (const 42) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (primcall eqv? (const 42.0) (toplevel x))
+      (primcall eqv? (const 42.0) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (primcall eqv? (const #nil) (toplevel x))
+      (primcall eq? (const #nil) (toplevel x))))
+
+  (with-test-prefix "equal?"
+
+    (pass-if-primitives-resolved
+        (primcall equal? (toplevel x) (const #f))
+      (primcall eq? (const #f) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (primcall equal? (toplevel x) (const ()))
+      (primcall eq? (const ()) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (primcall equal? (const #t) (lexical x y))
+      (primcall eq? (const #t) (lexical x y)))
+
+    (pass-if-primitives-resolved
+        (primcall equal? (const this-is-a-symbol) (toplevel x))
+      (primcall eq? (const this-is-a-symbol) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (primcall equal? (const 42) (toplevel x))
+      (primcall eq? (const 42) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (primcall equal? (const 42.0) (toplevel x))
+      (primcall equal? (const 42.0) (toplevel x)))
+
+    (pass-if-primitives-resolved
+        (primcall equal? (const #nil) (toplevel x))
+      (primcall eq? (const #nil) (toplevel x)))))
+
 
 (with-test-prefix "tree-il->scheme"
   (pass-if-tree-il->scheme
@@ -1704,3 +1781,8 @@
                               #:to 'assembly)))))
            (and (= (length w) 1)
                 (number? (string-contains (car w) "unsupported format option"))))))))
+
+;; Local Variables:
+;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1)
+;; eval: (put 'pass-if-tree-il->scheme 'scheme-indent-function 1)
+;; End:

test-suite/tests/web-uri.test

@@ -258,4 +258,6 @@
     (equal? "foo bar" (uri-decode "foo+bar"))))
 
 (with-test-prefix "encode"
-  (pass-if (equal? "foo%20bar" (uri-encode "foo bar"))))
+  (pass-if (equal? "foo%20bar" (uri-encode "foo bar")))
+  (pass-if (equal? "foo%0a%00bar" (uri-encode "foo\n\x00bar")))
+  (pass-if (equal? "%3c%3e%5c%5e" (uri-encode "<>\\^"))))