summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnulib-local/lib/localcharset.c.diff51
-rw-r--r--lib/localcharset.c8
-rw-r--r--libguile/posix.c208
-rw-r--r--module/ice-9/popen.scm101
-rw-r--r--module/language/tree-il/analyze.scm87
-rw-r--r--module/web/uri.scm25
-rw-r--r--test-suite/standalone/Makefile.am5
-rwxr-xr-xtest-suite/standalone/test-command-line-encoding220
-rw-r--r--test-suite/tests/tree-il.test42
-rw-r--r--test-suite/tests/web-uri.test6
10 files changed, 381 insertions, 172 deletions
diff --git a/gnulib-local/lib/localcharset.c.diff b/gnulib-local/lib/localcharset.c.diff
index 2b27ee479..6f216ad80 100644
--- a/gnulib-local/lib/localcharset.c.diff
+++ b/gnulib-local/lib/localcharset.c.diff
@@ -5,28 +5,10 @@ rationale.
--- a/lib/localcharset.c 2011-12-14 23:10:58.000000000 +0100
+++ b/lib/localcharset.c 2011-12-15 00:45:12.000000000 +0100
-@@ -527,6 +527,76 @@ locale_charset (void)
- codeset = "";
+@@ -545,3 +545,74 @@ locale_charset (void)
- /* Resolve alias. */
-+ for (aliases = get_charset_aliases ();
-+ *aliases != '\0';
-+ aliases += strlen (aliases) + 1, aliases += strlen (aliases) + 1)
-+ if (strcmp (codeset, aliases) == 0
-+ || (aliases[0] == '*' && aliases[1] == '\0'))
-+ {
-+ codeset = aliases + strlen (aliases) + 1;
-+ break;
-+ }
-+
-+ /* Don't return an empty string. GNU libc and GNU libiconv interpret
-+ the empty string as denoting "the locale's character encoding",
-+ thus GNU libiconv would call this function a second time. */
-+ if (codeset[0] == '\0')
-+ codeset = "ASCII";
-+
-+ return codeset;
-+}
+ return codeset;
+ }
+
+/* A variant of the above, without calls to `setlocale', `nl_langinfo',
+ etc. */
@@ -71,14 +53,29 @@ rationale.
+ strcpy (buf, "ASCII");
+ return buf;
+ }
-+
-+ /* Resolve through the charset.alias file. */
-+ codeset = locale;
++ else
++ codeset = "";
+ }
+ else
+ codeset = "";
+
+ /* Resolve alias. */
- for (aliases = get_charset_aliases ();
- *aliases != '\0';
- aliases += strlen (aliases) + 1, aliases += strlen (aliases) + 1)
++ for (aliases = get_charset_aliases ();
++ *aliases != '\0';
++ aliases += strlen (aliases) + 1, aliases += strlen (aliases) + 1)
++ if (strcmp (codeset, aliases) == 0
++ || (aliases[0] == '*' && aliases[1] == '\0'))
++ {
++ codeset = aliases + strlen (aliases) + 1;
++ break;
++ }
++
++ /* Don't return an empty string. GNU libc and GNU libiconv interpret
++ the empty string as denoting "the locale's character encoding",
++ thus GNU libiconv would call this function a second time. */
++ if (codeset[0] == '\0')
++ /* Default to Latin-1, for backward compatibility with Guile 1.8. */
++ codeset = "ISO-8859-1";
++
++ return codeset;
++}
diff --git a/lib/localcharset.c b/lib/localcharset.c
index 47a6e5d5b..2c06328cb 100644
--- a/lib/localcharset.c
+++ b/lib/localcharset.c
@@ -589,9 +589,8 @@ environ_locale_charset (void)
strcpy (buf, "ASCII");
return buf;
}
-
- /* Resolve through the charset.alias file. */
- codeset = locale;
+ else
+ codeset = "";
}
else
codeset = "";
@@ -611,7 +610,8 @@ environ_locale_charset (void)
the empty string as denoting "the locale's character encoding",
thus GNU libiconv would call this function a second time. */
if (codeset[0] == '\0')
- codeset = "ASCII";
+ /* Default to Latin-1, for backward compatibility with Guile 1.8. */
+ codeset = "ISO-8859-1";
return codeset;
}
diff --git a/libguile/posix.c b/libguile/posix.c
index f4d93f092..abb1a92dd 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1254,6 +1254,201 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
return scm_from_int (pid);
}
#undef FUNC_NAME
+
+/* Since Guile uses threads, we have to be very careful to avoid calling
+ functions that are not async-signal-safe in the child. That's why
+ this function is implemented in C. */
+static SCM
+scm_open_process (SCM mode, SCM prog, SCM args)
+#define FUNC_NAME "open-process"
+{
+ long mode_bits;
+ int reading, writing;
+ int c2p[2]; /* Child to parent. */
+ int p2c[2]; /* Parent to child. */
+ int in = -1, out = -1, err = -1;
+ int pid;
+ char *exec_file;
+ char **exec_argv;
+ int max_fd = 1024;
+
+ exec_file = scm_to_locale_string (prog);
+ exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
+
+ mode_bits = scm_i_mode_bits (mode);
+ reading = mode_bits & SCM_RDNG;
+ writing = mode_bits & SCM_WRTNG;
+
+ if (reading)
+ {
+ if (pipe (c2p))
+ {
+ int errno_save = errno;
+ free (exec_file);
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
+ out = c2p[1];
+ }
+
+ if (writing)
+ {
+ if (pipe (p2c))
+ {
+ int errno_save = errno;
+ free (exec_file);
+ if (reading)
+ {
+ close (c2p[0]);
+ close (c2p[1]);
+ }
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
+ in = p2c[0];
+ }
+
+ {
+ SCM port;
+
+ if (SCM_OPOUTFPORTP ((port = scm_current_error_port ())))
+ err = SCM_FPORT_FDES (port);
+ if (out == -1 && SCM_OPOUTFPORTP ((port = scm_current_output_port ())))
+ out = SCM_FPORT_FDES (port);
+ if (in == -1 && SCM_OPINFPORTP ((port = scm_current_input_port ())))
+ in = SCM_FPORT_FDES (port);
+ }
+
+#if defined (HAVE_GETRLIMIT) && defined (RLIMIT_NOFILE)
+ {
+ struct rlimit lim = { 0, 0 };
+ if (getrlimit (RLIMIT_NOFILE, &lim) == 0)
+ max_fd = lim.rlim_cur;
+ }
+#endif
+
+ pid = fork ();
+
+ if (pid == -1)
+ {
+ int errno_save = errno;
+ free (exec_file);
+ if (reading)
+ {
+ close (c2p[0]);
+ close (c2p[1]);
+ }
+ if (writing)
+ {
+ close (p2c[0]);
+ close (p2c[1]);
+ }
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
+
+ if (pid)
+ /* Parent. */
+ {
+ SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F, port;
+
+ /* There is no sense in catching errors on close(). */
+ if (reading)
+ {
+ close (c2p[1]);
+ read_port = scm_fdes_to_port (c2p[0], "r", sym_read_pipe);
+ scm_setvbuf (read_port, scm_from_int (_IONBF), SCM_UNDEFINED);
+ }
+ if (writing)
+ {
+ close (p2c[0]);
+ write_port = scm_fdes_to_port (p2c[1], "w", sym_write_pipe);
+ scm_setvbuf (write_port, scm_from_int (_IONBF), SCM_UNDEFINED);
+ }
+
+ if (reading && writing)
+ {
+ static SCM make_rw_port = SCM_BOOL_F;
+
+ if (scm_is_false (make_rw_port))
+ make_rw_port = scm_c_private_variable ("ice-9 popen",
+ "make-rw-port");
+
+ port = scm_call_2 (scm_variable_ref (make_rw_port),
+ read_port, write_port);
+ }
+ else if (reading)
+ port = read_port;
+ else if (writing)
+ port = write_port;
+ else
+ port = scm_sys_make_void_port (mode);
+
+ return scm_cons (port, scm_from_int (pid));
+ }
+
+ /* The child. */
+ if (reading)
+ close (c2p[0]);
+ if (writing)
+ close (p2c[1]);
+
+ /* Close all file descriptors in ports inherited from the parent
+ except for in, out, and err. Heavy-handed, but robust. */
+ while (max_fd--)
+ if (max_fd != in && max_fd != out && max_fd != err)
+ close (max_fd);
+
+ /* Ignore errors on these open() calls. */
+ if (in == -1)
+ in = open ("/dev/null", O_RDONLY);
+ if (out == -1)
+ out = open ("/dev/null", O_WRONLY);
+ if (err == -1)
+ err = open ("/dev/null", O_WRONLY);
+
+ if (in > 0)
+ {
+ if (out == 0)
+ do out = dup (out); while (errno == EINTR);
+ if (err == 0)
+ do err = dup (err); while (errno == EINTR);
+ do dup2 (in, 0); while (errno == EINTR);
+ close (in);
+ }
+ if (out > 1)
+ {
+ if (err == 1)
+ do err = dup (err); while (errno == EINTR);
+ do dup2 (out, 1); while (errno == EINTR);
+ close (out);
+ }
+ if (err > 2)
+ {
+ do dup2 (err, 2); while (errno == EINTR);
+ close (err);
+ }
+
+ execvp (exec_file,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_argv);
+
+ /* The exec failed! There is nothing sensible to do. */
+ if (err > 0)
+ {
+ char *msg = strerror (errno);
+ fprintf (fdopen (err, "a"), "In execlp of %s: %s\n",
+ exec_file, msg);
+ }
+
+ _exit (EXIT_FAILURE);
+ /* Not reached. */
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
#endif /* HAVE_FORK */
#ifdef __MINGW32__
@@ -2084,6 +2279,14 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
#endif /* HAVE_GETHOSTNAME */
+#ifdef HAVE_FORK
+static void
+scm_init_popen (void)
+{
+ scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process);
+}
+#endif
+
void
scm_init_posix ()
{
@@ -2172,6 +2375,11 @@ scm_init_posix ()
#include "libguile/cpp-SIG.c"
#include "libguile/posix.x"
+
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_popen",
+ (scm_t_extension_init_func) scm_init_popen,
+ NULL);
}
/*
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index b9debd444..7ca486805 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -1,6 +1,6 @@
;; popen emulation, for non-stdio based ports.
-;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 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
@@ -21,6 +21,10 @@
:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
open-output-pipe open-input-output-pipe))
+(eval-when (load eval compile)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_popen"))
+
(define (make-rw-port read-port write-port)
(make-soft-port
(vector
@@ -38,100 +42,6 @@
;; a weak hash-table to store the process ids.
(define port/pid-table (make-weak-key-hash-table 31))
-(define (ensure-fdes port mode)
- (or (false-if-exception (fileno port))
- (open-fdes *null-device* mode)))
-
-;; run a process connected to an input, an output or an
-;; input/output port
-;; mode: OPEN_READ, OPEN_WRITE or OPEN_BOTH
-;; returns port/pid pair.
-(define (open-process mode prog . args)
- (let* ((reading (or (equal? mode OPEN_READ)
- (equal? mode OPEN_BOTH)))
- (writing (or (equal? mode OPEN_WRITE)
- (equal? mode OPEN_BOTH)))
- (c2p (if reading (pipe) #f)) ; child to parent
- (p2c (if writing (pipe) #f))) ; parent to child
-
- (if c2p (setvbuf (cdr c2p) _IONBF))
- (if p2c (setvbuf (cdr p2c) _IONBF))
- (let ((pid (primitive-fork)))
- (cond ((= pid 0)
- ;; child
- (ensure-batch-mode!)
-
- ;; select the three file descriptors to be used as
- ;; standard descriptors 0, 1, 2 for the new
- ;; process. They are pipes to/from the parent or taken
- ;; from the current Scheme input/output/error ports if
- ;; possible.
-
- (let ((input-fdes (if writing
- (fileno (car p2c))
- (ensure-fdes (current-input-port)
- O_RDONLY)))
- (output-fdes (if reading
- (fileno (cdr c2p))
- (ensure-fdes (current-output-port)
- O_WRONLY)))
- (error-fdes (ensure-fdes (current-error-port)
- O_WRONLY)))
-
- ;; close all file descriptors in ports inherited from
- ;; the parent except for the three selected above.
- ;; this is to avoid causing problems for other pipes in
- ;; the parent.
-
- ;; use low-level system calls, not close-port or the
- ;; scsh routines, to avoid side-effects such as
- ;; flushing port buffers or evicting ports.
-
- (port-for-each (lambda (pt-entry)
- (false-if-exception
- (let ((pt-fileno (fileno pt-entry)))
- (if (not (or (= pt-fileno input-fdes)
- (= pt-fileno output-fdes)
- (= pt-fileno error-fdes)))
- (close-fdes pt-fileno))))))
-
- ;; Copy the three selected descriptors to the standard
- ;; descriptors 0, 1, 2, if not already there
-
- (cond ((not (= input-fdes 0))
- (if (= output-fdes 0)
- (set! output-fdes (dup->fdes 0)))
- (if (= error-fdes 0)
- (set! error-fdes (dup->fdes 0)))
- (dup2 input-fdes 0)
- ;; it's possible input-fdes is error-fdes
- (if (not (= input-fdes error-fdes))
- (close-fdes input-fdes))))
-
- (cond ((not (= output-fdes 1))
- (if (= error-fdes 1)
- (set! error-fdes (dup->fdes 1)))
- (dup2 output-fdes 1)
- ;; it's possible output-fdes is error-fdes
- (if (not (= output-fdes error-fdes))
- (close-fdes output-fdes))))
-
- (cond ((not (= error-fdes 2))
- (dup2 error-fdes 2)
- (close-fdes error-fdes)))
-
- (apply execlp prog prog args)))
-
- (else
- ;; parent
- (if c2p (close-port (cdr c2p)))
- (if p2c (close-port (car p2c)))
- (cons (cond ((not writing) (car c2p))
- ((not reading) (cdr p2c))
- (else (make-rw-port (car c2p)
- (cdr p2c))))
- pid))))))
-
(define (open-pipe* mode command . args)
"Executes the program @var{command} with optional arguments
@var{args} (all strings) in a subprocess.
@@ -213,3 +123,4 @@ information on how to interpret this value."
(define (open-input-output-pipe command)
"Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
(open-pipe command OPEN_BOTH))
+
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 28312514a..11c19d8ec 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1353,16 +1353,41 @@ accurate information is missing from a given `tree-il' element."
min-count max-count))))
(else (error "computer bought the farm" state))))))
-(define (const-fmt x)
- ;; Return the literal format pattern for X, or #f.
+(define (proc-ref? exp proc special-name env)
+ "Return #t when EXP designates procedure PROC in ENV. As a last
+resort, return #t when EXP refers to the global variable SPECIAL-NAME."
+ (match exp
+ (($ <toplevel-ref> _ name)
+ (let ((var (false-if-exception (module-variable env name))))
+ (if var
+ (eq? (variable-ref var) proc)
+ (eq? name special-name)))) ; special hack to support local aliases
+ (($ <module-ref> _ module name public?)
+ (let ((m (false-if-exception (if public?
+ (resolve-interface module)
+ (resolve-module module)))))
+ (and m (eq? (false-if-exception (module-ref module name)) proc))))
+ (_ #f)))
+
+(define gettext? (cut proc-ref? <> gettext '_ <>))
+(define ngettext? (cut proc-ref? <> ngettext 'N_ <>))
+
+(define (const-fmt x env)
+ ;; Return the literal format string for X, or #f.
(match x
- (($ <const> _ exp)
+ (($ <const> _ (? string? exp))
exp)
- (($ <call> _
- (or ($ <toplevel-ref> _ '_) ($ <module-ref> _ '_))
- (($ <const> _ (and (? string?) fmt))))
+ (($ <call> _ (? (cut gettext? <> env))
+ (($ <const> _ (? string? fmt))))
;; Gettexted literals, like `(_ "foo")'.
fmt)
+ (($ <call> _ (? (cut ngettext? <> env))
+ (($ <const> _ (? string? fmt)) ($ <const> _ (? string?)) _ ..1))
+ ;; Plural gettextized literals, like `(N_ "singular" "plural" n)'.
+
+ ;; TODO: Check whether the singular and plural strings have the
+ ;; same format escapes.
+ fmt)
(_ #f)))
(define format-analysis
@@ -1377,36 +1402,38 @@ accurate information is missing from a given `tree-il' element."
(define (check-format-args args loc)
(pmatch args
((,port ,fmt . ,rest)
- (guard (const-fmt fmt))
+ (guard (const-fmt fmt env))
(if (and (const? port)
(not (boolean? (const-exp port))))
(warning 'format loc 'wrong-port (const-exp port)))
- (let ((fmt (const-fmt fmt))
+ (let ((fmt (const-fmt fmt env))
(count (length rest)))
- (if (string? fmt)
- (catch &syntax-error
- (lambda ()
- (let-values (((min max)
- (format-string-argument-count fmt)))
- (and min max
- (or (and (or (eq? min 'any) (>= count min))
- (or (eq? max 'any) (<= count max)))
- (warning 'format loc 'wrong-format-arg-count
- fmt min max count)))))
- (lambda (_ key)
- (warning 'format loc 'syntax-error key fmt)))
- (warning 'format loc 'wrong-format-string fmt))))
+ (catch &syntax-error
+ (lambda ()
+ (let-values (((min max)
+ (format-string-argument-count fmt)))
+ (and min max
+ (or (and (or (eq? min 'any) (>= count min))
+ (or (eq? max 'any) (<= count max)))
+ (warning 'format loc 'wrong-format-arg-count
+ fmt min max count)))))
+ (lambda (_ key)
+ (warning 'format loc 'syntax-error key fmt)))))
((,port ,fmt . ,rest)
(if (and (const? port)
(not (boolean? (const-exp port))))
(warning 'format loc 'wrong-port (const-exp port)))
- ;; Warn on non-literal format strings, unless they refer to a
- ;; lexical variable named "fmt".
- (if (record-case fmt
- ((<lexical-ref> name)
- (not (eq? name 'fmt)))
- (else #t))
- (warning 'format loc 'non-literal-format-string)))
+
+ (match fmt
+ (($ <const> loc* (? (negate string?) fmt))
+ (warning 'format (or loc* loc) 'wrong-format-string fmt))
+
+ ;; Warn on non-literal format strings, unless they refer to
+ ;; a lexical variable named "fmt".
+ (($ <lexical-ref> _ fmt)
+ #t)
+ ((? (negate const?))
+ (warning 'format loc 'non-literal-format-string))))
(else
(warning 'format loc 'wrong-num-args (length args)))))
@@ -1436,8 +1463,8 @@ accurate information is missing from a given `tree-il' element."
(warning 'format loc 'simple-format fmt
(find (negate (cut memq <> allowed-chars)) opts))
#f))))
- ((port (($ <const> _ '_) fmt) args ...)
- (check-simple-format-args `(,port ,fmt ,args) loc))
+ ((port (= (cut const-fmt <> env) (? string? fmt)) args ...)
+ (check-simple-format-args `(,port ,(make-const loc fmt) ,args) loc))
(_ #t)))
(define (resolve-toplevel name)
diff --git a/module/web/uri.scm b/module/web/uri.scm
index 67ecbaeb2..a2a930a6a 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -1,6 +1,6 @@
;;;; (web uri) --- URI manipulation tools
;;;;
-;;;; Copyright (C) 1997,2001,2002,2010,2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997,2001,2002,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
@@ -89,9 +89,9 @@ consistency checks to make sure that the constructed URI is valid."
;; 3490), and non-ASCII host names.
;;
(define ipv4-regexp
- (make-regexp "^([0-9.]+)"))
+ (make-regexp "^([0-9.]+)$"))
(define ipv6-regexp
- (make-regexp "^\\[([0-9a-fA-F:]+)\\]+"))
+ (make-regexp "^\\[([0-9a-fA-F:]+)\\]+$"))
(define domain-label-regexp
(make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
(define top-label-regexp
@@ -100,18 +100,17 @@ consistency checks to make sure that the constructed URI is valid."
(define (valid-host? host)
(cond
((regexp-exec ipv4-regexp host)
- => (lambda (m)
- (false-if-exception (inet-pton AF_INET (match:substring m 1)))))
+ (false-if-exception (inet-pton AF_INET host)))
((regexp-exec ipv6-regexp host)
- => (lambda (m)
- (false-if-exception (inet-pton AF_INET6 (match:substring m 1)))))
+ (false-if-exception (inet-pton AF_INET6 host)))
(else
- (let ((labels (reverse (string-split host #\.))))
- (and (pair? labels)
- (regexp-exec top-label-regexp (car labels))
- (and-map (lambda (label)
- (regexp-exec domain-label-regexp label))
- (cdr labels)))))))
+ (let lp ((start 0))
+ (let ((end (string-index host #\. start)))
+ (if end
+ (and (regexp-exec domain-label-regexp
+ (substring host start end))
+ (lp (1+ end)))
+ (regexp-exec top-label-regexp host start)))))))
(define userinfo-pat
"[a-zA-Z0-9_.!~*'();:&=+$,-]+")
diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am
index d8cfafa25..daa3d0744 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -1,7 +1,7 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-## 2011 Free Software Foundation, Inc.
+## 2011, 2012 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -85,6 +85,9 @@ EXTRA_DIST += test-import-order-a.scm test-import-order-b.scm \
check_SCRIPTS += test-command-line-encoding
TESTS += test-command-line-encoding
+check_SCRIPTS += test-command-line-encoding2
+TESTS += test-command-line-encoding2
+
# test-num2integral
test_num2integral_SOURCES = test-num2integral.c
test_num2integral_CFLAGS = ${test_cflags}
diff --git a/test-suite/standalone/test-command-line-encoding2 b/test-suite/standalone/test-command-line-encoding2
new file mode 100755
index 000000000..536945bc2
--- /dev/null
+++ b/test-suite/standalone/test-command-line-encoding2
@@ -0,0 +1,20 @@
+#!/bin/sh
+
+# Choose a locale name that lacks a dot followed by the encoding name.
+# This should not confuse `environ_locale_charset'.
+# See <http://bugs.gnu.org/10742> for the original bug report.
+LC_ALL="en_US"
+export LC_ALL
+unset LANG
+unset LC_CTYPE
+
+exec guile -q -s "$0" "hello"
+!#
+
+;; Make sure our argument was suitable decoded.
+(exit (string=? (cadr (program-arguments)) "hello"))
+
+;; Local Variables:
+;; mode: scheme
+;; coding: iso-8859-1
+;; End:
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 78068ffcd..834ce5f47 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -2174,10 +2174,32 @@
(pass-if "non-literal format string using gettext"
(null? (call-with-warnings
(lambda ()
+ (compile '(format #t (gettext "~A ~A!") "hello" "world")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string using gettext as _"
+ (null? (call-with-warnings
+ (lambda ()
(compile '(format #t (_ "~A ~A!") "hello" "world")
#:opts %opts-w-format
#:to 'assembly)))))
+ (pass-if "non-literal format string using ngettext"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(format #t
+ (ngettext "~a thing" "~a things" n "dom") n)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string using ngettext as N_"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(format #t (N_ "~a thing" "~a things" n) n)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
(pass-if "wrong format string"
(let ((w (call-with-warnings
(lambda ()
@@ -2219,7 +2241,7 @@
(pass-if "one missing argument, gettext"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format some-port (_ "foo ~A~%"))
+ (compile '(format some-port (gettext "foo ~A~%"))
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@@ -2551,4 +2573,22 @@
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
+ (number? (string-contains (car w) "unsupported format option")))))
+
+ (pass-if "unsupported, gettext"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "unsupported format option")))))
+
+ (pass-if "unsupported, ngettext"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
(number? (string-contains (car w) "unsupported format option"))))))))
diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test
index 9118eea4b..940fb3147 100644
--- a/test-suite/tests/web-uri.test
+++ b/test-suite/tests/web-uri.test
@@ -1,6 +1,6 @@
;;;; web-uri.test --- URI library -*- 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
@@ -143,6 +143,10 @@
(uri=? (string->uri "http://foo:/")
#:scheme 'http #:host "foo" #:path "/"))
+ (pass-if "http://2012.jsconf.us/"
+ (uri=? (string->uri "http://2012.jsconf.us/")
+ #:scheme 'http #:host "2012.jsconf.us" #:path "/"))
+
(pass-if "http://foo:not-a-port"
(not (string->uri "http://foo:not-a-port")))