summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--THANKS1
-rw-r--r--doc/ref/api-io.texi15
-rw-r--r--libguile/foreign.c4
-rw-r--r--libguile/ports.c198
-rw-r--r--libguile/ports.h7
-rw-r--r--libguile/print.c15
-rw-r--r--libguile/strings.c6
-rw-r--r--libguile/strports.c8
-rw-r--r--module/ice-9/command-line.scm2
-rw-r--r--module/ice-9/ftw.scm19
-rw-r--r--module/ice-9/match.scm4
-rw-r--r--module/ice-9/match.upstream.scm4
-rw-r--r--module/ice-9/pretty-print.scm7
-rw-r--r--module/language/ecmascript/base.scm6
-rw-r--r--module/language/tree-il/cse.scm4
-rw-r--r--module/language/tree-il/primitives.scm3
-rw-r--r--module/oop/goops/dispatch.scm15
-rw-r--r--module/srfi/srfi-6.scm18
-rw-r--r--test-suite/test-suite/lib.scm2
-rw-r--r--test-suite/tests/coverage.test12
-rw-r--r--test-suite/tests/cse.test17
-rw-r--r--test-suite/tests/foreign.test24
-rw-r--r--test-suite/tests/ftw.test7
-rw-r--r--test-suite/tests/ports.test66
-rw-r--r--test-suite/tests/r6rs-ports.test11
-rw-r--r--test-suite/tests/srfi-6.test26
26 files changed, 343 insertions, 158 deletions
diff --git a/THANKS b/THANKS
index bdf11ee28..1b61a8190 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 24c2706df..de3684c31 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
+@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
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 832913147..072b4b62b 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 b45378592..f91b80ee3 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 f33f792b9..92e388e82 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 1f447bb99..90bc9adf8 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 bc715e0c1..7c5550fb3 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 7b51a8c87..702022740 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 8aed74ec6..62a2c9e4f 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 96422b5e4..6c9db27ee 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 4b078c69f..7fd191a11 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 978655667..29f9dbe2e 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 bf45eed42..5c23cb009 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 b244bec01..6f5c65ba5 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 1ac221eaa..40f6419e2 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 a44bc1acc..18126863c 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 b12ab15fa..de5359f3c 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 098b586cc..7b8bcb114 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 5785378ad..385cdfae3 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 4ac404344..b29de0f20 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 d09dc53db..154cc0614 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 47686eebd..7c5ecd62f 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 805c779bf..33537d04b 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 2aec1f0b2..613d2693f 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 f3e8c2c5d..46da67f59 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 68fc70dff..bd9167cca 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)