mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: libguile/deprecated.c libguile/ports.c libguile/ports.h libguile/strports.c test-suite/tests/cse.test
This commit is contained in:
Andy Wingo
commit
0dd7c54075
26 changed files with 343 additions and 158 deletions
1
THANKS
1
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ();
|
||||
|
||||
|
|
|
|||
196
libguile/ports.c
196
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,9 +2866,8 @@ scm_init_ports ()
|
|||
scm_make_fluid_with_default (SCM_BOOL_F));
|
||||
scm_port_encoding_init = 1;
|
||||
|
||||
SCM_VARIABLE_SET (scm_conversion_strategy,
|
||||
scm_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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -1578,7 +1578,7 @@ SCM
|
|||
scm_from_locale_stringn (const char *str, size_t len)
|
||||
{
|
||||
return scm_from_stringn (str, len, locale_charset (),
|
||||
scm_i_get_conversion_strategy (SCM_BOOL_F));
|
||||
scm_i_default_port_conversion_handler ());
|
||||
}
|
||||
|
||||
SCM
|
||||
|
|
@ -1879,7 +1879,7 @@ scm_to_locale_stringn (SCM str, size_t *lenp)
|
|||
{
|
||||
return scm_to_stringn (str, lenp,
|
||||
locale_charset (),
|
||||
scm_i_get_conversion_strategy (SCM_BOOL_F));
|
||||
scm_i_default_port_conversion_handler ());
|
||||
}
|
||||
|
||||
char *
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2006,
|
||||
* 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
|
|
@ -292,10 +293,11 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
|
|||
|
||||
z = scm_c_make_port_with_encoding (scm_tc16_strport, modes,
|
||||
encoding,
|
||||
SCM_FAILED_CONVERSION_ERROR,
|
||||
scm_i_default_port_conversion_handler (),
|
||||
(scm_t_bits)buf);
|
||||
|
||||
pt = SCM_PTAB_ENTRY (z);
|
||||
|
||||
pt->write_buf = pt->read_buf = (unsigned char *) c_buf;
|
||||
pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
|
||||
pt->read_buf_size = read_buf_size;
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -320,9 +320,10 @@ sub-expression, via the @var{breadth-first?} keyword argument."
|
|||
(let ((e "…"))
|
||||
(catch 'encoding-error
|
||||
(lambda ()
|
||||
(with-fluids ((%default-port-conversion-strategy 'error))
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(display e))))
|
||||
(display e)))))
|
||||
(lambda (key . args)
|
||||
"..."))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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!.
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@
|
|||
#:use-module (oop goops)
|
||||
#:use-module (oop goops util)
|
||||
#:use-module (oop goops compile)
|
||||
#:use-module (system base target)
|
||||
#:export (memoize-method!)
|
||||
#:no-backtrace)
|
||||
|
||||
|
|
@ -178,10 +179,14 @@
|
|||
'())
|
||||
(acons gf gf-sym '()))))
|
||||
(define (comp exp vals)
|
||||
;; 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)))
|
||||
(apply p vals)))))
|
||||
|
||||
;; kick it.
|
||||
(scan))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; srfi-6.test --- test suite for SRFI-6 -*- scheme -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2003, 2006, 2012 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -38,6 +38,14 @@
|
|||
(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"
|
||||
|
|
@ -76,6 +84,14 @@
|
|||
(display "xyz" port)
|
||||
(string=? "xyz" (get-output-string port))))
|
||||
|
||||
(pass-if "λ"
|
||||
;; Writing to an output string should always work.
|
||||
;; See <http://bugs.gnu.org/11197>.
|
||||
(with-fluids ((%default-port-encoding "ISO-8859-1"))
|
||||
(let ((port (open-output-string)))
|
||||
(display "λ" port)
|
||||
(string=? "λ" (get-output-string port)))))
|
||||
|
||||
(pass-if "seek"
|
||||
(let ((port (open-output-string)))
|
||||
(display "abcdef" port)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue