[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-307-g0dd7c54
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-307-g0dd7c54 |
|
Date: |
Fri, 22 Jun 2012 11:18:19 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=0dd7c5407599b65a1a3da4b9bd8feccc715b51f7
The branch, master has been updated
via 0dd7c5407599b65a1a3da4b9bd8feccc715b51f7 (commit)
via 2874f66017b7bfae256e85af84689d00ecc418ab (commit)
via 5cfa385db721222069aa5a74421cbac6e6cee26a (commit)
via 4d1ae112792cb8faaa1f42b5c7332e9de05001ee (commit)
via 378daa5fa51f1d193f7236c2691acba59e9af539 (commit)
via 03fcf93bff9f02a3d12ab86be4e67b996310aad4 (commit)
via ecb48dccbac6b8fdd969f50a23351ef7f4b91ce5 (commit)
via 2cb363622d03b18402d6ee15c8c87d8fee9bfc32 (commit)
via f3b312a19d70293d7a3407fc4ef479183edd7cca (commit)
via 6b5e918e4f3cf011713e699c6af1c4e364bfae36 (commit)
via e80494083aa3e9dc40a7ae5da12f0e90db550889 (commit)
via 0a3ac81a1c1017d3c71e9eac8f0dd3407563632b (commit)
via 27ea5c3f31cd353b71e4691211082e8a8e36e730 (commit)
via d3a1a74cb8764cf1f60e3d0eb0b5369cb05cf6b3 (commit)
via 9f6e3f5a997f484548bd03e7e7573c38a95c8d09 (commit)
via b22e94db7c91d7661204e33f3bc2bfead002c9b7 (commit)
via 478848cb706b23bcc4c2afe9a4ad33c595bc33f6 (commit)
via 1a6ff60da8d824230e186a8c8bef8c21b23ae377 (commit)
from 747747ee06ac64c224b91e8f64f810a1159c1675 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 0dd7c5407599b65a1a3da4b9bd8feccc715b51f7
Merge: 747747e 2874f66
Author: Andy Wingo <address@hidden>
Date: Fri Jun 22 13:18:02 2012 +0200
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
-----------------------------------------------------------------------
Summary of changes:
THANKS | 1 +
doc/ref/api-io.texi | 15 +++
libguile/foreign.c | 4 +-
libguile/ports.c | 198 +++++++++++++++++---------------
libguile/ports.h | 7 +-
libguile/print.c | 15 ++-
libguile/strings.c | 6 +-
libguile/strports.c | 8 +-
module/ice-9/command-line.scm | 2 +-
module/ice-9/ftw.scm | 19 ++--
module/ice-9/match.scm | 4 +-
module/ice-9/match.upstream.scm | 4 +-
module/ice-9/pretty-print.scm | 7 +-
module/language/ecmascript/base.scm | 6 +-
module/language/tree-il/cse.scm | 4 +-
module/language/tree-il/primitives.scm | 3 +
module/oop/goops/dispatch.scm | 15 ++-
module/srfi/srfi-6.scm | 18 +++-
test-suite/test-suite/lib.scm | 2 +-
test-suite/tests/coverage.test | 12 ++-
test-suite/tests/cse.test | 17 +++-
test-suite/tests/foreign.test | 24 ++++
test-suite/tests/ftw.test | 7 +-
test-suite/tests/ports.test | 66 ++++++++++-
test-suite/tests/r6rs-ports.test | 11 +-
test-suite/tests/srfi-6.test | 26 ++++-
26 files changed, 343 insertions(+), 158 deletions(-)
diff --git a/THANKS b/THANKS
index bdf11ee..1b61a81 100644
--- a/THANKS
+++ b/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
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index 24c2706..de3684c 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -166,6 +166,21 @@ returned. New ports will have this default behavior when
they are
created.
@end deffn
address@hidden {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},
address@hidden, @code{string->pointer}, and
address@hidden>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
address@hidden)}.
address@hidden deffn
@node Reading
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 8329131..072b4b6 100644
--- a/libguile/foreign.c
+++ b/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 ();
diff --git a/libguile/ports.c b/libguile/ports.c
index b453785..f91b80e 100644
--- a/libguile/ports.c
+++ b/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 qm;
- SCM esc;
-
- if (!scm_is_false (port))
- {
- SCM_VALIDATE_OPPORT (1, port);
- }
-
- 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;
- }
+ scm_t_string_failed_conversion_handler handler;
- 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;
- }
+ 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));
- esc = scm_from_latin1_symbol ("escape");
- if (scm_is_true (scm_eqv_p (sym, esc)))
+ if (scm_is_false (port))
+ scm_i_set_default_port_conversion_handler (handler);
+ else
{
- scm_i_set_conversion_strategy_x (port,
- SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
- return SCM_UNSPECIFIED;
+ SCM_VALIDATE_OPPORT (1, port);
+ SCM_PTAB_ENTRY (port)->ilseq_handler = handler;
}
- SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym));
-
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -2857,11 +2866,10 @@ scm_init_ports ()
scm_make_fluid_with_default (SCM_BOOL_F));
scm_port_encoding_init = 1;
- SCM_VARIABLE_SET (scm_conversion_strategy,
- scm_make_fluid_with_default
- (scm_from_int ((int)
SCM_FAILED_CONVERSION_QUESTION_MARK)));
+ SCM_VARIABLE_SET (default_conversion_strategy_var,
+ scm_make_fluid_with_default (sym_substitute));
scm_conversion_strategy_init = 1;
-
+
/* These bindings are used when boot-9 turns `current-input-port' et
al into parameters. They are then removed from the guile module. */
scm_c_define ("%current-input-port-fluid", cur_inport_fluid);
diff --git a/libguile/ports.h b/libguile/ports.h
index f33f792..92e388e 100644
--- a/libguile/ports.h
+++ b/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);
diff --git a/libguile/print.c b/libguile/print.c
index 1f447bb..90bc9ad 100644
--- a/libguile/print.c
+++ b/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);
diff --git a/libguile/strings.c b/libguile/strings.c
index bc715e0..7c5550f 100644
--- a/libguile/strings.c
+++ b/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
@@ -1877,9 +1877,9 @@ scm_to_locale_string (SCM str)
char *
scm_to_locale_stringn (SCM str, size_t *lenp)
{
- return scm_to_stringn (str, lenp,
+ return scm_to_stringn (str, lenp,
locale_charset (),
- scm_i_get_conversion_strategy (SCM_BOOL_F));
+ scm_i_default_port_conversion_handler ());
}
char *
diff --git a/libguile/strports.c b/libguile/strports.c
index 7b51a8c..7020227 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -1,5 +1,6 @@
-/* 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
* as published by the Free Software Foundation; either version 3 of
@@ -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;
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
index 8aed74e..62a2c9e 100644
--- a/module/ice-9/command-line.scm
+++ b/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))
diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm
index 96422b5..6c9db27 100644
--- a/module/ice-9/ftw.scm
+++ b/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)
- (if (select? name)
- (and (pair? result) ; must have a "." entry
- (cons (basename name) result))
+ (define (visit basename result)
+ (if (select? basename)
+ (cons basename 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)
diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm
index 4b078c6..7fd191a 100644
--- a/module/ice-9/match.scm
+++ b/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.
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index 9786556..29f9dbe 100644
--- a/module/ice-9/match.upstream.scm
+++ b/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
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index bf45eed..5c23cb0 100644
--- a/module/ice-9/pretty-print.scm
+++ b/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
- (lambda ()
- (display e))))
+ (with-fluids ((%default-port-conversion-strategy 'error))
+ (with-output-to-string
+ (lambda ()
+ (display e)))))
(lambda (key . args)
"..."))))
diff --git a/module/language/ecmascript/base.scm
b/module/language/ecmascript/base.scm
index b244bec..6f5c65b 100644
--- a/module/language/ecmascript/base.scm
+++ b/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)))
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index 1ac221e..40f6419 100644
--- a/module/language/tree-il/cse.scm
+++ b/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))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index a44bc1a..1812686 100644
--- a/module/language/tree-il/primitives.scm
+++ b/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!.
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index b12ab15..de5359f 100644
--- a/module/oop/goops/dispatch.scm
+++ b/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,11 +179,15 @@
'())
(acons gf gf-sym '()))))
(define (comp exp vals)
- (let ((p ((@ (system base compile) compile) exp
- #:env *dispatch-module*
- #:opts '(#:partial-eval? #f #:cse? #f))))
- (apply p vals)))
-
+ ;; When cross-compiling Guile itself, the native Guile must generate
+ ;; code for the host.
+ (with-target %host-type
+ (lambda ()
+ (let ((p ((@ (system base compile) compile) exp
+ #:env *dispatch-module*
+ #:opts '(#:partial-eval? #f #:cse? #f))))
+ (apply p vals)))))
+
;; kick it.
(scan))
diff --git a/module/srfi/srfi-6.scm b/module/srfi/srfi-6.scm
index 098b586..7b8bcb1 100644
--- a/module/srfi/srfi-6.scm
+++ b/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
-;; is needed, and this file is just a placeholder.
+;; SRFI-6 says nothing about encodings, and assumes that any character
+;; 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))
diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index 5785378..385cdfa 100644
--- a/test-suite/test-suite/lib.scm
+++ b/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
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index 4ac4043..b29de0f 100644
--- a/test-suite/tests/coverage.test
+++ b/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.
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index d09dc53..154cc06 100644
--- a/test-suite/tests/cse.test
+++ b/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)))))
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 47686ee..7c5ecd6 100644
--- a/test-suite/tests/foreign.test
+++ b/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)))))
diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test
index 805c779..33537d0 100644
--- a/test-suite/tests/ftw.test
+++ b/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)
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 2aec1f0..613d269 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -58,6 +58,34 @@
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.
;;; Write out an s-expression, and read it back.
@@ -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)))))))
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index f3e8c2c..46da67f 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/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)
diff --git a/test-suite/tests/srfi-6.test b/test-suite/tests/srfi-6.test
index 68fc70d..bd9167c 100644
--- a/test-suite/tests/srfi-6.test
+++ b/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
@@ -37,13 +37,21 @@
(char=? #\y (read-char port))
(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)
- (and (char=? #\x (read-char port))
+ (unread-char #\x port)
+ (and (char=? #\x (read-char port))
(eof-object? (read-char port)))))
(pass-if "after eof"
@@ -75,7 +83,15 @@
(let ((port (open-output-string)))
(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)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-307-g0dd7c54,
Andy Wingo <=