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; + scm_t_string_failed_conversion_handler handler; - 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,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 (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 ) 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 ) (object->number x)) + ((is-a? x ) (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>? + 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>? + 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 . + +(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* (( (make-struct 0 'pw)) + (proc (lambda args (length args))) + (b (make-struct 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 @@ -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 , 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 . + (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 . + (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)