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

Conflicts:
	libguile/deprecated.c
	libguile/ports.c
	libguile/ports.h
	libguile/strports.c
	test-suite/tests/cse.test

THANKS

@@ -101,6 +101,7 @@ For fixes or providing information which led to a fix:
          Daniel Llorens del Río
            Jeff Long
 	  Marco Maggi
+      Bogdan A. Marinescu
         Gregory Marton
       Kjetil S. Matheussen
         Antoine Mathys

doc/ref/api-io.texi

@@ -166,6 +166,21 @@ returned.  New ports will have this default behavior when they are
 created.
 @end deffn
 
+@deffn {Scheme Variable} %default-port-conversion-strategy
+The fluid that defines the conversion strategy for newly created ports,
+and for other conversion routines such as @code{scm_to_stringn},
+@code{scm_from_stringn}, @code{string->pointer}, and
+@code{pointer->string}.
+
+Its value must be one of the symbols described above, with the same
+semantics: @code{'error}, @code{'substitute}, or @code{'escape}.
+
+When Guile starts, its value is @code{'substitute}.
+
+Note that @code{(set-port-conversion-strategy! #f @var{sym})} is
+equivalent to @code{(fluid-set! %default-port-conversion-strategy
+@var{sym})}.
+@end deffn
 
 
 @node Reading

libguile/foreign.c

@@ -372,7 +372,7 @@ SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 1, 0,
 
       ret = scm_from_pointer
         (scm_to_stringn (string, NULL, enc,
-                         scm_i_get_conversion_strategy (SCM_BOOL_F)),
+                         scm_i_default_port_conversion_handler ()),
          free);
 
       scm_dynwind_end ();
@@ -417,7 +417,7 @@ SCM_DEFINE (scm_pointer_to_string, "pointer->string", 1, 2, 0,
       scm_dynwind_free (enc);
 
       ret = scm_from_stringn (SCM_POINTER_VALUE (pointer), len, enc,
-                              scm_i_get_conversion_strategy (SCM_BOOL_F));
+                              scm_i_default_port_conversion_handler ());
 
       scm_dynwind_end ();
 

libguile/ports.c

@@ -627,7 +627,7 @@ scm_c_make_port (scm_t_bits tag, unsigned long mode_bits, scm_t_bits stream)
 {
   return scm_c_make_port_with_encoding (tag, mode_bits,
                                         scm_i_default_port_encoding (),
-                                        scm_i_get_conversion_strategy (SCM_BOOL_F),
+                                        scm_i_default_port_conversion_handler (),
                                         stream);
 }
 
@@ -847,6 +847,83 @@ scm_i_default_port_encoding (void)
     }
 }
 
+/* A fluid specifying the default conversion handler for newly created
+   ports.  Its value should be one of the symbols below.  */
+SCM_VARIABLE (default_conversion_strategy_var,
+	      "%default-port-conversion-strategy");
+
+/* Whether the above fluid is initialized.  */
+static int scm_conversion_strategy_init = 0;
+
+/* The possible conversion strategies.  */
+SCM_SYMBOL (sym_error, "error");
+SCM_SYMBOL (sym_substitute, "substitute");
+SCM_SYMBOL (sym_escape, "escape");
+
+/* Return the default failed encoding conversion policy for new created
+   ports.  */
+scm_t_string_failed_conversion_handler
+scm_i_default_port_conversion_handler (void)
+{
+  scm_t_string_failed_conversion_handler handler;
+
+  if (!scm_conversion_strategy_init
+      || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var)))
+    handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
+  else
+    {
+      SCM fluid, value;
+
+      fluid = SCM_VARIABLE_REF (default_conversion_strategy_var);
+      value = scm_fluid_ref (fluid);
+
+      if (scm_is_eq (sym_substitute, value))
+	handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
+      else if (scm_is_eq (sym_escape, value))
+	handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE;
+      else
+	/* Default to 'error also when the fluid's value is not one of
+	   the valid symbols.  */
+	handler = SCM_FAILED_CONVERSION_ERROR;
+    }
+
+  return handler;
+}
+
+/* Use HANDLER as the default conversion strategy for future ports.  */
+void
+scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handler
+					   handler)
+{
+  SCM strategy;
+
+  if (!scm_conversion_strategy_init
+      || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var)))
+    scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized",
+		    SCM_EOL);
+
+  switch (handler)
+    {
+    case SCM_FAILED_CONVERSION_ERROR:
+      strategy = sym_error;
+      break;
+
+    case SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE:
+      strategy = sym_escape;
+      break;
+
+    case SCM_FAILED_CONVERSION_QUESTION_MARK:
+      strategy = sym_substitute;
+      break;
+
+    default:
+      abort ();
+    }
+
+  scm_fluid_set_x (SCM_VARIABLE_REF (default_conversion_strategy_var),
+		   strategy);
+}
+
 static void
 finalize_iconv_descriptors (GC_PTR ptr, GC_PTR data)
 {
@@ -1031,65 +1108,6 @@ SCM_DEFINE (scm_set_port_encoding_x, "set-port-encoding!", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-
-/* This determines how conversions handle unconvertible characters.  */
-SCM_GLOBAL_VARIABLE (scm_conversion_strategy, "%port-conversion-strategy");
-static int scm_conversion_strategy_init = 0;
-
-scm_t_string_failed_conversion_handler
-scm_i_get_conversion_strategy (SCM port)
-{
-  SCM encoding;
-  
-  if (scm_is_false (port))
-    {
-      if (!scm_conversion_strategy_init
-	  || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
-	return SCM_FAILED_CONVERSION_QUESTION_MARK;
-      else
-	{
-	  encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy));
-	  if (scm_is_false (encoding))
-	    return SCM_FAILED_CONVERSION_QUESTION_MARK;
-	  else 
-	    return (scm_t_string_failed_conversion_handler) scm_to_int (encoding);
-	}
-    }
-  else
-    {
-      scm_t_port *pt;
-      pt = SCM_PTAB_ENTRY (port);
-      return pt->ilseq_handler;
-    }
-      
-}
-
-void
-scm_i_set_conversion_strategy_x (SCM port, 
-				 scm_t_string_failed_conversion_handler handler)
-{
-  SCM strategy;
-  scm_t_port *pt;
-  
-  strategy = scm_from_int ((int) handler);
-  
-  if (scm_is_false (port))
-    {
-      /* Set the default encoding for future ports.  */
-      if (!scm_conversion_strategy_init
-	  || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
-	scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized",
-                       SCM_EOL);
-      scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy), strategy);
-    }
-  else
-    {
-      /* Set the character encoding for this port.  */
-      pt = SCM_PTAB_ENTRY (port);
-      pt->ilseq_handler = handler;
-    }
-}
-
 SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy",
 	    1, 0, 0, (SCM port),
 	    "Returns the behavior of the port when handling a character that\n"
@@ -1109,12 +1127,18 @@ SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy",
 
   SCM_VALIDATE_OPPORT (1, port);
 
-  if (!scm_is_false (port))
+  if (scm_is_false (port))
+    h = scm_i_default_port_conversion_handler ();
+  else
     {
+      scm_t_port *pt;
+
       SCM_VALIDATE_OPPORT (1, port);
+      pt = SCM_PTAB_ENTRY (port);
+
+      h = pt->ilseq_handler;
     }
 
-  h = scm_i_get_conversion_strategy (port);
   if (h == SCM_FAILED_CONVERSION_ERROR)
     return scm_from_latin1_symbol ("error");
   else if (h == SCM_FAILED_CONVERSION_QUESTION_MARK)
@@ -1149,40 +1173,25 @@ SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!",
 	    "this thread.\n")
 #define FUNC_NAME s_scm_set_port_conversion_strategy_x
 {
-  SCM err;
+  scm_t_string_failed_conversion_handler handler;
-  SCM qm;
-  SCM esc;
 
-  if (!scm_is_false (port))
+  if (scm_is_eq (sym, sym_error))
+    handler = SCM_FAILED_CONVERSION_ERROR;
+  else if (scm_is_eq (sym, sym_substitute))
+    handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
+  else if (scm_is_eq (sym, sym_escape))
+    handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE;
+  else
+    SCM_MISC_ERROR ("unknown conversion strategy ~s", scm_list_1 (sym));
+
+  if (scm_is_false (port))
+    scm_i_set_default_port_conversion_handler (handler);
+  else
     {
       SCM_VALIDATE_OPPORT (1, port);
+      SCM_PTAB_ENTRY (port)->ilseq_handler = handler;
     }
 
-  err = scm_from_latin1_symbol ("error");
-  if (scm_is_true (scm_eqv_p (sym, err)))
-    {
-      scm_i_set_conversion_strategy_x (port, SCM_FAILED_CONVERSION_ERROR);
-      return SCM_UNSPECIFIED;
-    }
-
-  qm = scm_from_latin1_symbol ("substitute");
-  if (scm_is_true (scm_eqv_p (sym, qm)))
-    {
-      scm_i_set_conversion_strategy_x (port, 
-                                       SCM_FAILED_CONVERSION_QUESTION_MARK);
-      return SCM_UNSPECIFIED;
-    }
-
-  esc = scm_from_latin1_symbol ("escape");
-  if (scm_is_true (scm_eqv_p (sym, esc)))
-    {
-      scm_i_set_conversion_strategy_x (port,
-                                       SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
-      return SCM_UNSPECIFIED;
-    }
-
-  SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym));
-
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -2857,9 +2866,8 @@ scm_init_ports ()
                     scm_make_fluid_with_default (SCM_BOOL_F));
   scm_port_encoding_init = 1;
 
-  SCM_VARIABLE_SET (scm_conversion_strategy,
+  SCM_VARIABLE_SET (default_conversion_strategy_var,
-                    scm_make_fluid_with_default
+                    scm_make_fluid_with_default (sym_substitute));
-                    (scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK)));
   scm_conversion_strategy_init = 1;
 
   /* These bindings are used when boot-9 turns `current-input-port' et

libguile/ports.h

@@ -297,13 +297,14 @@ SCM_API SCM scm_close_output_port (SCM port);
    characters.  */
 SCM_INTERNAL const char *scm_i_default_port_encoding (void);
 SCM_INTERNAL void scm_i_set_default_port_encoding (const char *);
+SCM_INTERNAL scm_t_string_failed_conversion_handler
+scm_i_default_port_conversion_handler (void);
+SCM_INTERNAL void
+scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handler);
 SCM_INTERNAL scm_t_iconv_descriptors *scm_i_port_iconv_descriptors (SCM port);
 SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str);
 SCM_API SCM scm_port_encoding (SCM port);
 SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding);
-SCM_INTERNAL scm_t_string_failed_conversion_handler scm_i_get_conversion_strategy (SCM port);
-SCM_INTERNAL void scm_i_set_conversion_strategy_x (SCM port, 
-						   scm_t_string_failed_conversion_handler h);
 SCM_API SCM scm_port_conversion_strategy (SCM port);
 SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior);
 

libguile/print.c

@@ -60,6 +60,9 @@
 
 /* Character printers.  */
 
+#define PORT_CONVERSION_HANDLER(port)		\
+  SCM_PTAB_ENTRY (port)->ilseq_handler
+
 static size_t display_string (const void *, int, size_t, SCM,
 			      scm_t_string_failed_conversion_handler);
 
@@ -417,7 +420,7 @@ print_normal_symbol (SCM sym, SCM port)
   scm_t_string_failed_conversion_handler strategy;
 
   len = scm_i_symbol_length (sym);
-  strategy = scm_i_get_conversion_strategy (port);
+  strategy = SCM_PTAB_ENTRY (port)->ilseq_handler;
 
   if (scm_i_is_narrow_symbol (sym))
     display_string (scm_i_symbol_chars (sym), 1, len, port, strategy);
@@ -432,7 +435,7 @@ print_extended_symbol (SCM sym, SCM port)
   scm_t_string_failed_conversion_handler strategy;
 
   len = scm_i_symbol_length (sym);
-  strategy = scm_i_get_conversion_strategy (port);
+  strategy = PORT_CONVERSION_HANDLER (port);
 
   scm_lfwrite_unlocked ("#{", 2, port);
 
@@ -539,7 +542,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 	  else
 	    {
 	      if (!display_character (SCM_CHAR (exp), port,
-				      scm_i_get_conversion_strategy (port)))
+				      PORT_CONVERSION_HANDLER (port)))
 		scm_encoding_error (__func__, errno,
 				    "cannot convert to output locale",
 				    port, exp);
@@ -625,7 +628,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 	      printed = display_string (scm_i_string_data (exp),
 					scm_i_is_narrow_string (exp),
 					len, port,
-					scm_i_get_conversion_strategy (port));
+					PORT_CONVERSION_HANDLER (port));
 	      if (SCM_UNLIKELY (printed < len))
 		scm_encoding_error (__func__, errno,
 				    "cannot convert to output locale",
@@ -1178,7 +1181,7 @@ write_character (scm_t_wchar ch, SCM port, int string_escapes_p)
   int printed = 0;
   scm_t_string_failed_conversion_handler strategy;
 
-  strategy = scm_i_get_conversion_strategy (port);
+  strategy = PORT_CONVERSION_HANDLER (port);
 
   if (string_escapes_p)
     {
@@ -1539,7 +1542,7 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
 
   port = SCM_COERCE_OUTPORT (port);
   if (!display_character (SCM_CHAR (chr), port,
-			  scm_i_get_conversion_strategy (port)))
+			  PORT_CONVERSION_HANDLER (port)))
     scm_encoding_error (__func__, errno,
 			"cannot convert to output locale",
 			port, chr);

libguile/strings.c

@@ -1578,7 +1578,7 @@ SCM
 scm_from_locale_stringn (const char *str, size_t len)
 {
   return scm_from_stringn (str, len, locale_charset (),
-                           scm_i_get_conversion_strategy (SCM_BOOL_F));
+                           scm_i_default_port_conversion_handler ());
 }
 
 SCM
@@ -1879,7 +1879,7 @@ scm_to_locale_stringn (SCM str, size_t *lenp)
 {
   return scm_to_stringn (str, lenp,
                          locale_charset (),
-                         scm_i_get_conversion_strategy (SCM_BOOL_F));
+                         scm_i_default_port_conversion_handler ());
 }
 
 char *

libguile/strports.c

@@ -1,4 +1,5 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 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
@@ -292,10 +293,11 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
 
   z = scm_c_make_port_with_encoding (scm_tc16_strport, modes,
                                      encoding,
-                                     SCM_FAILED_CONVERSION_ERROR,
+                                     scm_i_default_port_conversion_handler (),
                                      (scm_t_bits)buf);
 
   pt = SCM_PTAB_ENTRY (z);
+
   pt->write_buf = pt->read_buf = (unsigned char *) c_buf;
   pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
   pt->read_buf_size = read_buf_size;

module/ice-9/command-line.scm

@@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law."))
 (define* (version-etc package version #:key
                       (port (current-output-port))
                       ;; FIXME: authors
-                      (copyright-year 2011)
+                      (copyright-year 2012)
                       (copyright-holder "Free Software Foundation, Inc.")
                       (copyright (format #f "Copyright (C) ~a ~a"
                                          copyright-year copyright-holder))

module/ice-9/ftw.scm

@@ -538,26 +538,29 @@ of file names is sorted according to ENTRY<?, which defaults to
   (define (enter? dir stat result)
     (and stat (string=? dir name)))
 
-  (define (leaf name stat result)
+  (define (visit basename result)
-    (if (select? name)
+    (if (select? basename)
-        (and (pair? result)                      ; must have a "." entry
+        (cons basename result)
-             (cons (basename name) result))
         result))
 
+  (define (leaf name stat result)
+    (and result
+         (visit (basename name) result)))
+
   (define (down name stat result)
-    (list "."))
+    (visit "." '()))
 
   (define (up name stat result)
-    (cons ".." result))
+    (visit ".." result))
 
   (define (skip name stat result)
     ;; All the sub-directories are skipped.
-    (cons (basename name) result))
+    (visit (basename name) result))
 
   (define (error name* stat errno result)
     (if (string=? name name*)             ; top-level NAME is unreadable
         result
-        (cons (basename name*) result)))
+        (visit (basename name*) result)))
 
   (and=> (file-system-fold enter? leaf down up skip error #f name stat)
          (lambda (files)

module/ice-9/match.scm

@@ -1,6 +1,6 @@
 ;;; -*- 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
@@ -52,7 +52,7 @@
 ;; `match' doesn't support clauses of the form `(pat => exp)'.
 
 ;; Unmodified public domain code by Alex Shinn retrieved from
-;; the Chibi-Scheme repository, commit 876:528cdab3f818.
+;; the Chibi-Scheme repository, commit 1206:acd808700e91.
 ;;
 ;; Note: Make sure to update `match.test.upstream' when updating this
 ;; file.

module/ice-9/match.upstream.scm

@@ -210,6 +210,7 @@
 ;; performance can be found at
 ;;   http://synthcode.com/scheme/match-cond-expand.scm
 ;;
+;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns
 ;; 2011/09/25 - fixing bug when directly matching an identifier repeated in
 ;;              the pattern (thanks to Stefan Israelsson Tampe)
 ;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
@@ -479,7 +480,8 @@
      (match-one v p . x))
     ((_ v (p . q) g+s sk fk i)
      ;; match one and try the remaining on failure
-     (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i))
+     (let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i))))
+       (match-one v p g+s sk (fk2) i)))
     ))
 
 ;; We match a pattern (p ...) by matching the pattern p in a loop on

module/ice-9/pretty-print.scm

@@ -320,9 +320,10 @@ sub-expression, via the @var{breadth-first?} keyword argument."
       (let ((e "…"))
         (catch 'encoding-error
           (lambda ()
-            (with-output-to-string
+            (with-fluids ((%default-port-conversion-strategy 'error))
-              (lambda ()
+              (with-output-to-string
-                (display e))))
+                (lambda ()
+                  (display e)))))
           (lambda (key . args)
             "..."))))
 

module/language/ecmascript/base.scm

@@ -92,7 +92,7 @@
   (pdel o (string->symbol p)))
 
 (define-method (has-property? (o <js-object>) p)
-  (if (hashq-get-handle (js-props o) v)
+  (if (hashq-get-handle (js-props o) p)
       #t
       (let ((proto (js-prototype o)))
         (if proto
@@ -176,9 +176,9 @@
         ((boolean? x) (if x 1 0))
         ((null? x) 0)
         ((eq? x *undefined*) +nan.0)
-        ((is-a? x <js-object>) (object->number x))
+        ((is-a? x <js-object>) (object->number x #t))
         ((string? x) (string->number x))
-        (else (throw 'TypeError o '->number))))
+        (else (throw 'TypeError x '->number))))
 
 (define (->integer x)
   (let ((n (->number x)))

module/language/tree-il/cse.scm

@@ -270,11 +270,11 @@
            #f)))
        (_
         (cond
-         ((find-dominating-expression exp effects #f db)
+         ((find-dominating-expression exp effects 'test db)
           ;; We have an EXP fact, so we infer #t.
           (log 'inferring exp #t)
           (make-const (tree-il-src exp) #t))
-         ((find-dominating-expression (negate exp 'test) effects #f db)
+         ((find-dominating-expression (negate exp 'test) effects 'test db)
           ;; We have a (not EXP) fact, so we infer #f.
           (log 'inferring exp #f)
           (make-const (tree-il-src exp) #f))

module/language/tree-il/primitives.scm

@@ -55,6 +55,8 @@
 
     char<? char<=? char>=? char>?
 
+    integer->char char->integer number->string string->number
+
     acons cons cons*
 
     list vector
@@ -155,6 +157,7 @@
     pair? null? list? symbol? vector? struct? string? number? char? nil
     complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
     char<? char<=? char>=? char>?
+    integer->char char->integer number->string string->number
     struct-vtable
     string-length vector-length
     ;; These all should get expanded out by expand-primitives!.

module/oop/goops/dispatch.scm

@@ -25,6 +25,7 @@
   #:use-module (oop goops)
   #:use-module (oop goops util)
   #:use-module (oop goops compile)
+  #:use-module (system base target)
   #:export (memoize-method!)
   #:no-backtrace)
 
@@ -178,10 +179,14 @@
                      '())
                  (acons gf gf-sym '()))))
   (define (comp exp vals)
-    (let ((p ((@ (system base compile) compile) exp
+    ;; When cross-compiling Guile itself, the native Guile must generate
-              #:env *dispatch-module*
+    ;; code for the host.
-              #:opts '(#:partial-eval? #f #:cse? #f))))
+    (with-target %host-type
-      (apply p vals)))
+      (lambda ()
+        (let ((p ((@ (system base compile) compile) exp
+                  #:env *dispatch-module*
+                  #:opts '(#:partial-eval? #f #:cse? #f))))
+          (apply p vals)))))
 
   ;; kick it.
   (scan))

module/srfi/srfi-6.scm

@@ -1,6 +1,6 @@
 ;;; srfi-6.scm --- Basic String Ports
 
-;; 	Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2001, 2002, 2003, 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
@@ -23,10 +23,20 @@
 ;;; Code:
 
 (define-module (srfi srfi-6)
-  #:re-export (open-input-string open-output-string get-output-string))
+  #:replace (open-input-string open-output-string)
+  #:re-export (get-output-string))
 
-;; Currently, guile provides these functions by default, so no action
+;; SRFI-6 says nothing about encodings, and assumes that any character
-;; is needed, and this file is just a placeholder.
+;; or string can be written to a string port.  Thus, make all SRFI-6
+;; string ports Unicode capable.  See <http://bugs.gnu.org/11197>.
+
+(define (open-input-string s)
+  (with-fluids ((%default-port-encoding "UTF-8"))
+    ((@ (guile) open-input-string) s)))
+
+(define (open-output-string)
+  (with-fluids ((%default-port-encoding "UTF-8"))
+    ((@ (guile) open-output-string))))
 
 (cond-expand-provide (current-module) '(srfi-6))
 

test-suite/test-suite/lib.scm

@@ -283,7 +283,7 @@
 (define exception:system-error
   (cons 'system-error ".*"))
 (define exception:encoding-error
-  (cons 'encoding-error "(cannot convert to output locale|input (locale conversion|decoding) error)"))
+  (cons 'encoding-error "(cannot convert.* to output locale|input (locale conversion|decoding) error)"))
 (define exception:miscellaneous-error
   (cons 'misc-error "^.*"))
 (define exception:read-error

test-suite/tests/coverage.test

@@ -1,6 +1,6 @@
 ;;;; coverage.test --- Code coverage.    -*- 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
@@ -216,6 +216,16 @@
              (= 3 result)
              (not (procedure-execution-count data proc))))))
 
+  (pass-if "applicable struct"
+    (let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw))
+           (proc  (lambda args (length args)))
+           (b     (make-struct <box> 0 proc)))
+      (let-values (((data result)
+                    (with-code-coverage %test-vm b)))
+        (and (coverage-data? data)
+             (= 0 result)
+             (= (procedure-execution-count data proc) 1)))))
+
   (pass-if "called from C"
     ;; The `scm_call_N' functions use the VM returned by `the-vm'.  This
     ;; test makes sure that they get to use %TEST-VM.

test-suite/tests/cse.test

@@ -266,4 +266,19 @@
    (let ((x (car y)))
      (cons x (car y)))
    (let (x) (_) ((primcall car (toplevel y)))
-        (primcall cons (lexical x _) (lexical x _)))))
+        (primcall cons (lexical x _) (lexical x _))))
+
+  ;; Dominating expressions only provide predicates when evaluated in
+  ;; test context.
+  (pass-if-cse
+   (let ((t (car x)))
+     (if (car x)
+         'one
+         'two))
+   ;; Actually this one should reduce in other ways, but this is the
+   ;; current reduction:
+   (seq
+     (primcall car (toplevel x))
+     (if (primcall car (toplevel x))
+         (const one)
+         (const two)))))

test-suite/tests/foreign.test

@@ -25,6 +25,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (ice-9 format)
   #:use-module (test-suite lib))
 
 
@@ -160,6 +161,29 @@
 
 (with-test-prefix "pointer<->string"
 
+  (pass-if-exception "%default-port-conversion-strategy is error"
+    exception:encoding-error
+    (let ((s "χαοσ"))
+      (with-fluids ((%default-port-conversion-strategy 'error))
+        (string->pointer s "ISO-8859-1"))))
+
+  (pass-if "%default-port-conversion-strategy is escape"
+    (let ((s "teĥniko"))
+      (equal? (with-fluids ((%default-port-conversion-strategy 'escape))
+                (pointer->string (string->pointer s "ISO-8859-1")))
+              (format #f "te\\u~4,'0xniko"
+                      (char->integer #\ĥ)))))
+
+  (pass-if "%default-port-conversion-strategy is substitute"
+    (let ((s "teĥniko")
+          (member (negate (negate member))))
+      (member (with-fluids ((%default-port-conversion-strategy 'substitute))
+                (pointer->string (string->pointer s "ISO-8859-1")))
+              '("te?niko"
+
+                ;; This form is found on FreeBSD 8.2 and Darwin 10.8.0.
+                "te^hniko"))))
+
   (pass-if "bijection"
     (let ((s "hello, world"))
       (string=? s (pointer->string (string->pointer s)))))

test-suite/tests/ftw.test

@@ -310,14 +310,17 @@
   (pass-if "test-suite"
     (let ((select? (cut string-suffix? ".test" <>)))
       (match (scandir (string-append %test-dir "/tests") select?)
-        (("." ".." "00-initial-env.test" (? select?) ...)
+        (("00-initial-env.test" (? select?) ...)
          #t))))
 
   (pass-if "flat file"
     (not (scandir (string-append %test-dir "/Makefile.am"))))
 
   (pass-if "EACCES"
-    (not (scandir "/.does-not-exist."))))
+    (not (scandir "/.does-not-exist.")))
+
+  (pass-if "no select"
+    (null? (scandir %test-dir (lambda (_) #f)))))
 
 ;;; Local Variables:
 ;;; eval: (put 'with-file-tree 'scheme-indent-function 2)

test-suite/tests/ports.test

@@ -57,6 +57,34 @@
     (close-port port)
     string))
 
+
+
+(with-test-prefix "%default-port-conversion-strategy"
+
+  (pass-if "initial value"
+    (eq? 'substitute (fluid-ref %default-port-conversion-strategy)))
+
+  (pass-if "file port"
+    (let ((strategies '(error substitute escape)))
+      (equal? (map (lambda (s)
+                     (with-fluids ((%default-port-conversion-strategy s))
+                       (call-with-output-file "/dev/null"
+                         (lambda (p)
+                           (port-conversion-strategy p)))))
+                   strategies)
+              strategies)))
+
+  (pass-if "(set-port-conversion-strategy! #f sym)"
+    (begin
+      (set-port-conversion-strategy! #f 'error)
+      (and (eq? (fluid-ref %default-port-conversion-strategy) 'error)
+           (begin
+             (set-port-conversion-strategy! #f 'substitute)
+             (eq? (fluid-ref %default-port-conversion-strategy)
+                  'substitute)))))
+
+)
+
 
 ;;;; Normal file ports.
 
@@ -385,6 +413,22 @@
     (pass-if "output check"
 	     (string=? text result)))
 
+  (pass-if "encoding failure leads to exception"
+    ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'.
+    ;; See the discussion at <http://bugs.gnu.org/11197>, for details.
+    (catch 'encoding-error
+      (lambda ()
+        (with-fluids ((%default-port-encoding "ISO-8859-1"))
+          (let ((p (open-input-string "λ")))      ; raise an exception
+            #f)))
+      (lambda (key . rest)
+        #t)
+      (lambda (key . rest)
+        ;; At this point, the port-table mutex used to be still held,
+        ;; hence the deadlock.  This situation would occur when trying
+        ;; to print a backtrace, for instance.
+        (input-port? (open-input-string "foo")))))
+
   (pass-if "%default-port-encoding is honored"
     (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
       (equal? (map (lambda (e)
@@ -396,6 +440,20 @@
                    encodings)
               encodings)))
 
+  (pass-if "%default-port-conversion-strategy is honored"
+    (let ((strategies '(error substitute escape)))
+      (equal? (map (lambda (s)
+                     (with-fluids ((%default-port-conversion-strategy s))
+                       (call-with-output-string
+                        (lambda (p)
+                          (and (eq? s (port-conversion-strategy p))
+                               (begin
+                                 (set-port-conversion-strategy! p s)
+                                 (display (port-conversion-strategy p)
+                                          p)))))))
+                   strategies)
+              (map symbol->string strategies))))
+
   (pass-if "suitable encoding [latin-1]"
     (let ((str "hello, world"))
       (with-fluids ((%default-port-encoding "ISO-8859-1"))
@@ -412,15 +470,17 @@
                   (lambda ()
                     (display str)))))))
 
-  (pass-if "wrong encoding"
+  (pass-if "wrong encoding, error"
     (let ((str "ĉu bone?"))
       (catch 'encoding-error
         (lambda ()
           ;; Latin-1 cannot represent ‘ĉ’.
-          (with-fluids ((%default-port-encoding "ISO-8859-1"))
+          (with-fluids ((%default-port-encoding "ISO-8859-1")
+                        (%default-port-conversion-strategy 'error))
             (with-output-to-string
               (lambda ()
-                (display str)))))
+                (display str))))
+          #f)                            ; so the test really fails here
         (lambda (key subr message errno port chr)
           (and (eq? chr #\ĉ)
                (string? (strerror errno)))))))

test-suite/tests/r6rs-ports.test

@@ -1,6 +1,6 @@
 ;;;; r6rs-ports.test --- R6RS I/O port tests.   -*- 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
@@ -306,10 +306,12 @@
            (bv  (string->utf16 str)))
       (catch 'decoding-error
         (lambda ()
-          (with-fluids ((%default-port-encoding "UTF-32"))
+          (with-fluids ((%default-port-encoding "UTF-32")
+                        (%default-port-conversion-strategy 'error))
             (call-with-output-string
               (lambda (port)
-                (put-bytevector port bv)))))
+                (put-bytevector port bv)))
+            #f))                           ; fail if we reach this point
         (lambda (key subr message errno port)
           (string? (strerror errno)))))))
 
@@ -662,7 +664,8 @@
            (tp (transcoded-port b t)))
       (guard (c ((i/o-decoding-error? c)
                  (eq? (i/o-error-port c) tp)))
-        (get-line tp))))
+        (get-line tp)
+        #f)))                              ; fail if we reach this point
 
   (pass-if "transcoded-port [error handling mode = replace]"
     (let* ((t  (make-transcoder (utf-8-codec) (native-eol-style)

test-suite/tests/srfi-6.test

@@ -1,6 +1,6 @@
 ;;;; srfi-6.test --- test suite for SRFI-6   -*- scheme -*-
 ;;;;
-;;;; 	Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2003, 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
@@ -38,12 +38,20 @@
 	   (char=? #\z (read-char port))
 	   (eof-object? (read-char port)))))
 
+  (pass-if "read-char, Unicode"
+    ;; String ports should always be Unicode-capable.
+    ;; See <http://bugs.gnu.org/11197>.
+    (with-fluids ((%default-port-encoding "ISO-8859-1"))
+      (let ((port (open-input-string "λμ")))
+        (and (char=? #\λ (read-char port))
+             (char=? #\μ (read-char port))))))
+
   (with-test-prefix "unread-char"
     
     (pass-if "one char"
       (let ((port (open-input-string "")))
-	(unread-char #\x port)
+        (unread-char #\x port)
-	(and (char=? #\x (read-char port))
+        (and (char=? #\x (read-char port))
 	     (eof-object? (read-char port)))))
     
     (pass-if "after eof"
@@ -76,6 +84,14 @@
       (display "xyz" port)
       (string=? "xyz" (get-output-string port))))
 
+  (pass-if "λ"
+    ;; Writing to an output string should always work.
+    ;; See <http://bugs.gnu.org/11197>.
+    (with-fluids ((%default-port-encoding "ISO-8859-1"))
+      (let ((port (open-output-string)))
+        (display "λ" port)
+        (string=? "λ" (get-output-string port)))))
+
   (pass-if "seek"
     (let ((port (open-output-string)))
       (display "abcdef" port)