mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

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

Browse source 
Conflicts:
	libguile/deprecated.c
	libguile/ports.c
	libguile/ports.h
	libguile/strports.c
	test-suite/tests/cse.test
This commit is contained in:
Andy Wingo 2012-06-22 13:18:02 +02:00
commit 0dd7c54075
26 changed files with 343 additions and 158 deletions
Download patch file Download diff file Expand all files Collapse all files

1
THANKS
View file

@ -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

15
doc/ref/api-io.texi
View file

@ -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

4
libguile/foreign.c
View file

@ -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 ();

198
libguile/ports.c
View file

@ -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);

7
libguile/ports.h
View file

@ -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);

15
libguile/print.c
View file

@ -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);

6
libguile/strings.c
View file

@ -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 *

8
libguile/strports.c
View file

@ -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;

2
module/ice-9/command-line.scm
View file

@ -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))

19
module/ice-9/ftw.scm
View file

@ -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)

4
module/ice-9/match.scm
View file

@ -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.

4
module/ice-9/match.upstream.scm
View file

@ -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

7
module/ice-9/pretty-print.scm
View file

@ -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)
"..."))))

6
module/language/ecmascript/base.scm
View file

@ -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)))

4
module/language/tree-il/cse.scm
View file

@ -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))

3
module/language/tree-il/primitives.scm
View file

@ -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!.

15
module/oop/goops/dispatch.scm
View file

@ -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))

18
module/srfi/srfi-6.scm
View file

@ -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))

2
test-suite/test-suite/lib.scm
View file

@ -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

12
test-suite/tests/coverage.test
View file

@ -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.

17
test-suite/tests/cse.test
View file

@ -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)))))

24
test-suite/tests/foreign.test
View file

@ -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)))))

7
test-suite/tests/ftw.test
View file

@ -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)

66
test-suite/tests/ports.test
View file

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

11
test-suite/tests/r6rs-ports.test
View file

@ -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)

26
test-suite/tests/srfi-6.test
View file

@ -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)