[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-62-g508e4a5
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-62-g508e4a5 |
|
Date: |
Thu, 23 Feb 2012 14:41:44 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=508e4a55df353ec50f005307eb98557c7da79c82
The branch, master has been updated
via 508e4a55df353ec50f005307eb98557c7da79c82 (commit)
via 2bf0e122f0e9937d1a267c2c4825efe357a72541 (commit)
via 81b80b9610798ea910daad78cf525dec211639f9 (commit)
via 44b76a785ce075df07e6af1c2bf7d5ad3f4e3d4f (commit)
via bab917c9a37d8f69ccd9af1d5c37a53637fd0fdf (commit)
via 9d15db65ffd49fd8fda77dcb6b70c3c930ae5153 (commit)
via a2e946f1ef83cd1fd8c87412cc49f6c6d1e0ac61 (commit)
via 7ea70f355e986c79f2c999753642141a0e8985f7 (commit)
via 71cc8d96ee0917474c052fd484cad199be1311b2 (commit)
via 4f6e8ba7bcfd3daeb1179bf0be09d7953bf2458f (commit)
via 1868309a9e34a04a5b3020e147d0ce029038b290 (commit)
via 98385ed20abdc191a67daef8a00b1df0290a074a (commit)
via afc9803113de660a761f476b7957e92cc60bad19 (commit)
via 5de0053178b4acc793ae62838175e5f3ab56c603 (commit)
from 3c65e3fda512cda13de244e853afd0fa0e7b5962 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 508e4a55df353ec50f005307eb98557c7da79c82
Author: Andy Wingo <address@hidden>
Date: Thu Feb 23 14:20:48 2012 +0100
remove atfork on revealed mutex in fports.c
* libguile/fports.c: Remove atfork call.
commit 2bf0e122f0e9937d1a267c2c4825efe357a72541
Author: Andy Wingo <address@hidden>
Date: Thu Feb 23 14:18:57 2012 +0100
Revert "add pthread_atfork helpers to our threading shims"
This reverts commit 2f745b64a1eb06e9e175a1b497d5270bebff9097.
commit 81b80b9610798ea910daad78cf525dec211639f9
Author: Andy Wingo <address@hidden>
Date: Thu Feb 23 14:18:56 2012 +0100
Revert "with a threaded guile, lock weak sets and tables during a fork"
This reverts commit f609480611cfd1585409fd6b1b90beb730b026cf.
commit 44b76a785ce075df07e6af1c2bf7d5ad3f4e3d4f
Author: Andy Wingo <address@hidden>
Date: Thu Feb 23 14:18:56 2012 +0100
Revert "install pthread_atfork handlers for guile's static mutexen"
This reverts commit 6a97b1f93aace5c7c976aef51d36b3ae9cfd5630.
commit bab917c9a37d8f69ccd9af1d5c37a53637fd0fdf
Author: Andy Wingo <address@hidden>
Date: Thu Feb 23 14:18:52 2012 +0100
Revert "wrap iconv_open / iconv_close with a lock to help in thread/fork
issues"
This reverts commit 8dfb7bbfd908ca883d0fdd0d868e13e6b20803ae.
commit 9d15db65ffd49fd8fda77dcb6b70c3c930ae5153
Merge: 3c65e3f a2e946f
Author: Andy Wingo <address@hidden>
Date: Thu Feb 23 14:10:22 2012 +0100
Merge remote-tracking branch 'local-2.0/stable-2.0'
Conflicts:
module/language/tree-il/analyze.scm
commit a2e946f1ef83cd1fd8c87412cc49f6c6d1e0ac61
Author: Andy Wingo <address@hidden>
Date: Thu Feb 23 13:56:06 2012 +0100
rewrite open-process in C, for robustness
* libguile/posix.c (scm_open_process): Rewrite in C, so as to avoid
allocations and other calls that are not async-signal-safe.
(scm_init_popen, scm_init_posix): Register popen extension.
* module/ice-9/popen.scm: Load the popen extension, to get open-process.
-----------------------------------------------------------------------
Summary of changes:
gnulib-local/lib/localcharset.c.diff | 51 +++---
lib/localcharset.c | 8 +-
libguile/async.c | 3 +-
libguile/bytevectors.c | 6 -
libguile/deprecation.c | 3 +-
libguile/fluids.c | 1 -
libguile/fports.c | 1 -
libguile/gc.c | 3 +-
libguile/init.c | 1 -
libguile/instructions.c | 3 +-
libguile/null-threads.h | 5 +-
libguile/ports.c | 11 -
libguile/posix.c | 211 ++++++++++++++++++++-
libguile/pthread-threads.h | 10 +-
libguile/strings.c | 26 ---
libguile/strings.h | 5 +-
libguile/threads.c | 3 -
libguile/threads.h | 6 +-
libguile/weak-set.c | 108 ++---------
libguile/weak-set.h | 5 +-
libguile/weak-table.c | 108 ++---------
module/ice-9/popen.scm | 101 +---------
module/language/tree-il/analyze.scm | 87 ++++++---
module/web/uri.scm | 25 ++--
test-suite/standalone/Makefile.am | 5 +-
test-suite/standalone/test-command-line-encoding2 | 20 ++
test-suite/tests/tree-il.test | 42 ++++-
test-suite/tests/web-uri.test | 6 +-
28 files changed, 418 insertions(+), 446 deletions(-)
create mode 100755 test-suite/standalone/test-command-line-encoding2
diff --git a/gnulib-local/lib/localcharset.c.diff
b/gnulib-local/lib/localcharset.c.diff
index 2b27ee4..6f216ad 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 47a6e5d..2c06328 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/async.c b/libguile/async.c
index e873997..80f561d 100644
--- a/libguile/async.c
+++ b/libguile/async.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009,
2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009,
2010, 2011 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
@@ -133,7 +133,6 @@ SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0,
static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (async_mutex);
/* System asyncs. */
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 6ea60f8..668c46d 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -1934,12 +1934,10 @@ utf_encoding_name (char *name, size_t utf_width, SCM
endianness)
c_strlen = scm_i_string_length (str); \
if (scm_i_is_narrow_string (str)) \
{ \
- scm_i_lock_iconv (); \
err = mem_iconveh (scm_i_string_chars (str), c_strlen, \
"ISO-8859-1", c_utf_name, \
iconveh_question_mark, NULL, \
&c_utf, &c_utf_len); \
- scm_i_unlock_iconv (); \
if (SCM_UNLIKELY (err)) \
scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
scm_list_1 (str), err); \
@@ -1947,12 +1945,10 @@ utf_encoding_name (char *name, size_t utf_width, SCM
endianness)
else \
{ \
const scm_t_wchar *wbuf = scm_i_string_wide_chars (str); \
- scm_i_lock_iconv (); \
c_utf = u32_conv_to_encoding (c_utf_name, \
iconveh_question_mark, \
(scm_t_uint32 *) wbuf, \
c_strlen, NULL, NULL, &c_utf_len); \
- scm_i_unlock_iconv (); \
if (SCM_UNLIKELY (c_utf == NULL)) \
scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
scm_list_1 (str), errno); \
@@ -2054,12 +2050,10 @@ SCM_DEFINE (scm_string_to_utf32, "string->utf32",
c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
utf_encoding_name (c_utf_name, (_utf_width), endianness); \
\
- scm_i_lock_iconv (); \
err = mem_iconveh (c_utf, c_utf_len, \
c_utf_name, "UTF-8", \
iconveh_question_mark, NULL, \
&c_str, &c_strlen); \
- scm_i_unlock_iconv (); \
if (SCM_UNLIKELY (err)) \
scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
scm_list_1 (utf), err); \
diff --git a/libguile/deprecation.c b/libguile/deprecation.c
index cb5377a..5c1a246 100644
--- a/libguile/deprecation.c
+++ b/libguile/deprecation.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2006, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2006, 2010, 2011 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
@@ -48,7 +48,6 @@ struct issued_warning {
};
static scm_i_pthread_mutex_t warn_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (warn_lock);
static struct issued_warning *issued_warnings;
static int print_summary = 0;
diff --git a/libguile/fluids.c b/libguile/fluids.c
index e4906a4..282718e 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -44,7 +44,6 @@ static void **allocated_fluids = NULL;
static size_t allocated_fluids_len = 0;
static scm_i_pthread_mutex_t fluid_admin_mutex =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
-SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (fluid_admin_mutex);
#define IS_FLUID(x) SCM_FLUID_P (x)
#define FLUID_NUM(x) SCM_I_FLUID_NUM (x)
diff --git a/libguile/fports.c b/libguile/fports.c
index 9fcfbcb..2dc2375 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -642,7 +642,6 @@ fport_input_waiting (SCM port)
static SCM revealed_ports = SCM_EOL;
static scm_i_pthread_mutex_t revealed_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (revealed_lock);
/* Find a port in the table and return its revealed count.
Also used by the garbage collector.
diff --git a/libguile/gc.c b/libguile/gc.c
index 2c026b7..6d44f5e 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009, 2010, 2011 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
@@ -647,7 +647,6 @@ scm_storage_prehistory ()
}
scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (scm_i_gc_admin_mutex);
void
scm_init_gc_protect_object ()
diff --git a/libguile/init.c b/libguile/init.c
index 7dec116..dc3f5ec 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -382,7 +382,6 @@ scm_i_init_guile (void *base)
scm_storage_prehistory ();
scm_threads_prehistory (base); /* requires storage_prehistory */
- scm_weak_set_prehistory (); /* requires storage_prehistory */
scm_weak_table_prehistory (); /* requires storage_prehistory */
#ifdef GUILE_DEBUG_MALLOC
scm_debug_malloc_prehistory ();
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 2646f90..f3b8963 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011 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
@@ -48,7 +48,6 @@ struct scm_instruction {
static scm_i_pthread_mutex_t itable_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (itable_lock);
static struct scm_instruction*
diff --git a/libguile/null-threads.h b/libguile/null-threads.h
index 4779ee0..116b845 100644
--- a/libguile/null-threads.h
+++ b/libguile/null-threads.h
@@ -3,7 +3,7 @@
#ifndef SCM_NULL_THREADS_H
#define SCM_NULL_THREADS_H
-/* Copyright (C) 2005, 2006, 2010, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2005, 2006, 2010 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
@@ -102,9 +102,6 @@ SCM_API int scm_i_pthread_key_create (scm_i_pthread_key_t
*key,
#define scm_i_scm_pthread_cond_wait scm_i_pthread_cond_wait
#define scm_i_scm_pthread_cond_timedwait scm_i_pthread_cond_timedwait
-#define SCM_DEFINE_ATFORK_HANDLERS_FOR_MUTEX(m,lock,unlock) /* noop */
-#define scm_i_pthread_atfork(pre,parent,child) do {} while (0)
-
#endif /* SCM_NULL_THREADS_H */
diff --git a/libguile/ports.c b/libguile/ports.c
index 12174bc..5b98bf9 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -103,7 +103,6 @@ static long scm_numptob = 0; /* Number of port types. */
static long scm_ptobs_size = 0; /* Number of slots in the port type
table. */
static scm_i_pthread_mutex_t scm_ptobs_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (scm_ptobs_lock);
long
scm_c_num_port_types (void)
@@ -860,9 +859,7 @@ open_iconv_descriptors (const char *encoding, int reading,
int writing)
allocation. */
scm_gc_register_allocation (16 * 1024);
- scm_i_lock_iconv ();
input_cd = iconv_open ("UTF-8", encoding);
- scm_i_unlock_iconv ();
if (input_cd == (iconv_t) -1)
goto invalid_encoding;
}
@@ -873,15 +870,11 @@ open_iconv_descriptors (const char *encoding, int
reading, int writing)
allocation. */
scm_gc_register_allocation (16 * 1024);
- scm_i_lock_iconv ();
output_cd = iconv_open (encoding, "UTF-8");
- scm_i_unlock_iconv ();
if (output_cd == (iconv_t) -1)
{
- scm_i_lock_iconv ();
if (input_cd != (iconv_t) -1)
iconv_close (input_cd);
- scm_i_unlock_iconv ();
goto invalid_encoding;
}
}
@@ -908,12 +901,10 @@ open_iconv_descriptors (const char *encoding, int
reading, int writing)
static void
close_iconv_descriptors (scm_t_iconv_descriptors *id)
{
- scm_i_lock_iconv ();
if (id->input_cd != (iconv_t) -1)
iconv_close (id->input_cd);
if (id->output_cd != (iconv_t) -1)
iconv_close (id->output_cd);
- scm_i_unlock_iconv ();
id->input_cd = (void *) -1;
id->output_cd = (void *) -1;
}
@@ -1840,12 +1831,10 @@ scm_ungetc_unlocked (scm_t_wchar c, SCM port)
encoding = "ISO-8859-1";
len = sizeof (result_buf);
- scm_i_lock_iconv ();
result = u32_conv_to_encoding (encoding,
(enum iconv_ilseq_handler) pt->ilseq_handler,
(uint32_t *) &c, 1, NULL,
result_buf, &len);
- scm_i_unlock_iconv ();
if (SCM_UNLIKELY (result == NULL || len == 0))
scm_encoding_error (FUNC_NAME, errno,
diff --git a/libguile/posix.c b/libguile/posix.c
index f4d93f0..4f8b8ac 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005,
2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005,
2006, 2007, 2008, 2009, 2010, 2011 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
@@ -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__
@@ -1493,7 +1688,6 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
is also acquired before calls to `nl_langinfo ()'. See `i18n.c' for
details. */
scm_i_pthread_mutex_t scm_i_locale_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (scm_i_locale_mutex);
#ifdef HAVE_SETLOCALE
@@ -2084,6 +2278,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 +2374,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/libguile/pthread-threads.h b/libguile/pthread-threads.h
index 63b47b2..b5fae4e 100644
--- a/libguile/pthread-threads.h
+++ b/libguile/pthread-threads.h
@@ -3,7 +3,7 @@
#ifndef SCM_PTHREADS_THREADS_H
#define SCM_PTHREADS_THREADS_H
-/* Copyright (C) 2002, 2005, 2006, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2005, 2006, 2011 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
@@ -97,14 +97,6 @@ extern pthread_mutexattr_t
scm_i_pthread_mutexattr_recursive[1];
#define scm_i_scm_pthread_cond_wait scm_pthread_cond_wait
#define scm_i_scm_pthread_cond_timedwait scm_pthread_cond_timedwait
-#define SCM_DEFINE_ATFORK_HANDLERS_FOR_MUTEX(m,lock,unlock) \
- static void lock (void) { pthread_mutex_lock (m); } \
- static void unlock (void) { pthread_mutex_unlock (m); }
-
-/* noop */
-#define scm_i_pthread_atfork(pre,parent,child) \
- pthread_atfork (pre, parent, child)
-
#endif /* SCM_PTHREADS_THREADS_H */
/*
diff --git a/libguile/strings.c b/libguile/strings.c
index 977548b..9617057 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -225,24 +225,7 @@ narrow_stringbuf (SCM buf)
return new_buf;
}
-
-
scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (stringbuf_write_mutex);
-
-static scm_i_pthread_mutex_t iconv_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
-void
-scm_i_lock_iconv (void)
-{
- scm_i_pthread_mutex_lock (&iconv_mutex);
-}
-
-void
-scm_i_unlock_iconv (void)
-{
- scm_i_pthread_mutex_unlock (&iconv_mutex);
-}
/* Copy-on-write strings.
@@ -1547,14 +1530,12 @@ scm_from_stringn (const char *str, size_t len, const
char *encoding,
return scm_from_utf8_stringn (str, len);
u32len = 0;
- scm_i_lock_iconv ();
u32 = (scm_t_wchar *) u32_conv_from_encoding (encoding,
(enum iconv_ilseq_handler)
handler,
str, len,
NULL,
NULL, &u32len);
- scm_i_unlock_iconv ();
if (SCM_UNLIKELY (u32 == NULL))
decoding_error (__func__, errno, str, len);
@@ -2089,12 +2070,10 @@ scm_to_stringn (SCM str, size_t *lenp, const char
*encoding,
enc = "ISO-8859-1";
if (scm_i_is_narrow_string (str))
{
- scm_i_lock_iconv ();
ret = mem_iconveh (scm_i_string_chars (str), ilen,
"ISO-8859-1", enc,
(enum iconv_ilseq_handler) handler, NULL,
&buf, &len);
- scm_i_unlock_iconv ();
if (ret != 0)
scm_encoding_error (__func__, errno,
@@ -2105,14 +2084,12 @@ scm_to_stringn (SCM str, size_t *lenp, const char
*encoding,
}
else
{
- scm_i_lock_iconv ();
buf = u32_conv_to_encoding (enc,
(enum iconv_ilseq_handler) handler,
(scm_t_uint32 *) scm_i_string_wide_chars
(str),
ilen,
NULL,
NULL, &len);
- scm_i_unlock_iconv ();
if (buf == NULL)
scm_encoding_error (__func__, errno,
"cannot convert wide string to output locale",
@@ -2356,9 +2333,6 @@ scm_init_strings ()
{
scm_nullstr = scm_i_make_string (0, NULL, 0);
- scm_i_pthread_atfork (scm_i_lock_iconv, scm_i_unlock_iconv,
- scm_i_unlock_iconv);
-
#include "libguile/strings.x"
}
diff --git a/libguile/strings.h b/libguile/strings.h
index b88e97c..04a9762 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -3,7 +3,7 @@
#ifndef SCM_STRINGS_H
#define SCM_STRINGS_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008, 2009,
2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008, 2009,
2010, 2011 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
@@ -220,9 +220,6 @@ SCM_INTERNAL void scm_decoding_error (const char *subr, int
err,
/* internal utility functions. */
-SCM_INTERNAL void scm_i_lock_iconv (void);
-SCM_INTERNAL void scm_i_unlock_iconv (void);
-
SCM_INTERNAL char **scm_i_allocate_string_pointers (SCM list);
SCM_INTERNAL void scm_i_get_substring_spec (size_t len,
SCM start, size_t *cstart,
diff --git a/libguile/threads.c b/libguile/threads.c
index f78889b..d5c51ea 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -500,7 +500,6 @@ SCM_THREAD_LOCAL scm_i_thread *scm_i_current_thread = NULL;
static scm_i_pthread_mutex_t thread_admin_mutex =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
-SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (thread_admin_mutex);
static scm_i_thread *all_threads = NULL;
static int thread_count;
@@ -2135,7 +2134,6 @@ static int threads_initialized_p = 0;
/* This mutex is used by SCM_CRITICAL_SECTION_START/END.
*/
scm_i_pthread_mutex_t scm_i_critical_section_mutex;
-SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (scm_i_critical_section_mutex);
static SCM dynwind_critical_section_mutex;
@@ -2151,7 +2149,6 @@ scm_dynwind_critical_section (SCM mutex)
/*** Initialization */
scm_i_pthread_mutex_t scm_i_misc_mutex;
-SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (scm_i_misc_mutex);
#if SCM_USE_PTHREAD_THREADS
pthread_mutexattr_t scm_i_pthread_mutexattr_recursive[1];
diff --git a/libguile/threads.h b/libguile/threads.h
index f8404cf..54d6414 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -3,7 +3,7 @@
#ifndef SCM_THREADS_H
#define SCM_THREADS_H
-/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008,
2009, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008,
2009, 2011 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
@@ -130,10 +130,6 @@ typedef struct scm_i_thread {
#define SCM_VALIDATE_CONDVAR(pos, a) \
scm_assert_smob_type (scm_tc16_condvar, (a))
-#define SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX(m) \
- SCM_SNARF_HERE(SCM_DEFINE_ATFORK_HANDLERS_FOR_MUTEX(&m,lock_##m,unlock_##m))\
- SCM_SNARF_INIT(scm_i_pthread_atfork (lock_##m, unlock_##m, unlock_##m);)
-
SCM_API SCM scm_spawn_thread (scm_t_catch_body body, void *body_data,
scm_t_catch_handler handler, void *handler_data);
diff --git a/libguile/weak-set.c b/libguile/weak-set.c
index 249c703..bdabedf 100644
--- a/libguile/weak-set.c
+++ b/libguile/weak-set.c
@@ -650,74 +650,6 @@ weak_set_remove_x (scm_t_weak_set *set, unsigned long hash,
-
-static void
-lock_weak_set (scm_t_weak_set *set)
-{
- scm_i_pthread_mutex_lock (&set->lock);
-}
-
-static void
-unlock_weak_set (scm_t_weak_set *set)
-{
- scm_i_pthread_mutex_unlock (&set->lock);
-}
-
-/* A weak set of weak sets, for use in the pthread_atfork handler. */
-static SCM all_weak_sets = SCM_BOOL_F;
-
-#if SCM_USE_PTHREAD_THREADS
-
-static void
-lock_all_weak_sets (void)
-{
- scm_t_weak_set *s;
- scm_t_weak_entry *entries;
- unsigned long k, size;
- scm_t_weak_entry copy;
-
- s = SCM_WEAK_SET (all_weak_sets);
- lock_weak_set (s);
- size = s->size;
- entries = s->entries;
-
- for (k = 0; k < size; k++)
- if (entries[k].hash)
- {
- copy_weak_entry (&entries[k], ©);
- if (copy.key)
- lock_weak_set (SCM_WEAK_SET (SCM_PACK (copy.key)));
- }
-}
-
-static void
-unlock_all_weak_sets (void)
-{
- scm_t_weak_set *s;
- scm_t_weak_entry *entries;
- unsigned long k, size;
- scm_t_weak_entry copy;
-
- s = SCM_WEAK_SET (all_weak_sets);
- size = s->size;
- entries = s->entries;
-
- for (k = 0; k < size; k++)
- if (entries[k].hash)
- {
- copy_weak_entry (&entries[k], ©);
- if (copy.key)
- unlock_weak_set (SCM_WEAK_SET (SCM_PACK (copy.key)));
- }
-
- unlock_weak_set (s);
-}
-
-#endif /* SCM_USE_PTHREAD_THREADS */
-
-
-
-
static SCM
make_weak_set (unsigned long k)
{
@@ -764,7 +696,7 @@ do_vacuum_weak_set (SCM set)
if (scm_i_pthread_mutex_trylock (&s->lock) == 0)
{
vacuum_weak_set (s);
- unlock_weak_set (s);
+ scm_i_pthread_mutex_unlock (&s->lock);
}
return;
@@ -829,9 +761,6 @@ scm_c_make_weak_set (unsigned long k)
scm_c_register_weak_gc_callback (ret, do_vacuum_weak_set);
- if (scm_is_true (all_weak_sets))
- scm_weak_set_add_x (all_weak_sets, ret);
-
return ret;
}
@@ -846,12 +775,12 @@ scm_weak_set_clear_x (SCM set)
{
scm_t_weak_set *s = SCM_WEAK_SET (set);
- lock_weak_set (s);
+ scm_i_pthread_mutex_lock (&s->lock);
memset (s->entries, 0, sizeof (scm_t_weak_entry) * s->size);
s->n_items = 0;
- unlock_weak_set (s);
+ scm_i_pthread_mutex_unlock (&s->lock);
return SCM_UNSPECIFIED;
}
@@ -864,11 +793,11 @@ scm_c_weak_set_lookup (SCM set, unsigned long raw_hash,
SCM ret;
scm_t_weak_set *s = SCM_WEAK_SET (set);
- lock_weak_set (s);
+ scm_i_pthread_mutex_lock (&s->lock);
ret = weak_set_lookup (s, raw_hash, pred, closure, dflt);
- unlock_weak_set (s);
+ scm_i_pthread_mutex_unlock (&s->lock);
return ret;
}
@@ -881,11 +810,11 @@ scm_c_weak_set_add_x (SCM set, unsigned long raw_hash,
SCM ret;
scm_t_weak_set *s = SCM_WEAK_SET (set);
- lock_weak_set (s);
+ scm_i_pthread_mutex_lock (&s->lock);
ret = weak_set_add_x (s, raw_hash, pred, closure, obj);
- unlock_weak_set (s);
+ scm_i_pthread_mutex_unlock (&s->lock);
return ret;
}
@@ -897,11 +826,11 @@ scm_c_weak_set_remove_x (SCM set, unsigned long raw_hash,
{
scm_t_weak_set *s = SCM_WEAK_SET (set);
- lock_weak_set (s);
+ scm_i_pthread_mutex_lock (&s->lock);
weak_set_remove_x (s, raw_hash, pred, closure);
- unlock_weak_set (s);
+ scm_i_pthread_mutex_unlock (&s->lock);
}
static int
@@ -936,7 +865,7 @@ scm_c_weak_set_fold (scm_t_set_fold_fn proc, void *closure,
s = SCM_WEAK_SET (set);
- lock_weak_set (s);
+ scm_i_pthread_mutex_lock (&s->lock);
size = s->size;
entries = s->entries;
@@ -952,14 +881,14 @@ scm_c_weak_set_fold (scm_t_set_fold_fn proc, void
*closure,
if (copy.key)
{
/* Release set lock while we call the function. */
- unlock_weak_set (s);
+ scm_i_pthread_mutex_unlock (&s->lock);
init = proc (closure, SCM_PACK (copy.key), init);
- lock_weak_set (s);
+ scm_i_pthread_mutex_lock (&s->lock);
}
}
}
- unlock_weak_set (s);
+ scm_i_pthread_mutex_unlock (&s->lock);
return init;
}
@@ -1004,17 +933,6 @@ scm_weak_set_map_to_list (SCM proc, SCM set)
}
-
-
-void
-scm_weak_set_prehistory (void)
-{
-#if SCM_USE_PTHREAD_THREADS
- all_weak_sets = scm_c_make_weak_set (0);
- pthread_atfork (lock_all_weak_sets, unlock_all_weak_sets,
unlock_all_weak_sets);
-#endif
-}
-
void
scm_init_weak_set ()
{
diff --git a/libguile/weak-set.h b/libguile/weak-set.h
index 6a1c00d..86781c7 100644
--- a/libguile/weak-set.h
+++ b/libguile/weak-set.h
@@ -3,7 +3,7 @@
#ifndef SCM_WEAK_SET_H
#define SCM_WEAK_SET_H
-/* Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2011 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
@@ -57,10 +57,7 @@ SCM_INTERNAL SCM scm_weak_set_fold (SCM proc, SCM init, SCM
set);
SCM_INTERNAL SCM scm_weak_set_for_each (SCM proc, SCM set);
SCM_INTERNAL SCM scm_weak_set_map_to_list (SCM proc, SCM set);
-SCM_INTERNAL void scm_i_weak_set_lock (SCM set);
-SCM_INTERNAL void scm_i_weak_set_unlock (SCM set);
SCM_INTERNAL void scm_i_weak_set_print (SCM exp, SCM port, scm_print_state
*pstate);
-SCM_INTERNAL void scm_weak_set_prehistory (void);
SCM_INTERNAL void scm_init_weak_set (void);
#endif /* SCM_WEAK_SET_H */
diff --git a/libguile/weak-table.c b/libguile/weak-table.c
index 49d5b6d..7764f52 100644
--- a/libguile/weak-table.c
+++ b/libguile/weak-table.c
@@ -772,79 +772,10 @@ weak_table_remove_x (scm_t_weak_table *table, unsigned
long hash,
-
-static void
-lock_weak_table (scm_t_weak_table *table)
-{
- scm_i_pthread_mutex_lock (&table->lock);
-}
-
-static void
-unlock_weak_table (scm_t_weak_table *table)
-{
- scm_i_pthread_mutex_unlock (&table->lock);
-}
-
-/* A weak table of weak tables, for use in the pthread_atfork handler. */
-static SCM all_weak_tables = SCM_BOOL_F;
-
-#if SCM_USE_PTHREAD_THREADS
-
-static void
-lock_all_weak_tables (void)
-{
- scm_t_weak_table *s;
- scm_t_weak_entry *entries;
- unsigned long k, size;
- scm_t_weak_entry copy;
-
- s = SCM_WEAK_TABLE (all_weak_tables);
- lock_weak_table (s);
- size = s->size;
- entries = s->entries;
-
- for (k = 0; k < size; k++)
- if (entries[k].hash)
- {
- copy_weak_entry (&entries[k], ©);
- if (copy.key)
- lock_weak_table (SCM_WEAK_TABLE (SCM_PACK (copy.key)));
- }
-}
-
-static void
-unlock_all_weak_tables (void)
-{
- scm_t_weak_table *s;
- scm_t_weak_entry *entries;
- unsigned long k, size;
- scm_t_weak_entry copy;
-
- s = SCM_WEAK_TABLE (all_weak_tables);
- size = s->size;
- entries = s->entries;
-
- for (k = 0; k < size; k++)
- if (entries[k].hash)
- {
- copy_weak_entry (&entries[k], ©);
- if (copy.key)
- unlock_weak_table (SCM_WEAK_TABLE (SCM_PACK (copy.key)));
- }
-
- unlock_weak_table (s);
-}
-
-#endif /* SCM_USE_PTHREAD_THREADS */
-
-
-
-
static SCM
make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
{
scm_t_weak_table *table;
- SCM ret;
int i = 0, n = k ? k : 31;
while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
@@ -862,12 +793,7 @@ make_weak_table (unsigned long k, scm_t_weak_table_kind
kind)
table->min_size_index = i;
scm_i_pthread_mutex_init (&table->lock, NULL);
- ret = scm_cell (scm_tc7_weak_table, (scm_t_bits)table);
-
- if (scm_is_true (all_weak_tables))
- scm_weak_table_putq_x (all_weak_tables, ret, SCM_BOOL_T);
-
- return ret;
+ return scm_cell (scm_tc7_weak_table, (scm_t_bits)table);
}
void
@@ -891,7 +817,7 @@ do_vacuum_weak_table (SCM table)
if (scm_i_pthread_mutex_trylock (&t->lock) == 0)
{
vacuum_weak_table (t);
- unlock_weak_table (t);
+ scm_i_pthread_mutex_unlock (&t->lock);
}
return;
@@ -978,11 +904,11 @@ scm_c_weak_table_ref (SCM table, unsigned long raw_hash,
t = SCM_WEAK_TABLE (table);
- lock_weak_table (t);
+ scm_i_pthread_mutex_lock (&t->lock);
ret = weak_table_ref (t, raw_hash, pred, closure, dflt);
- unlock_weak_table (t);
+ scm_i_pthread_mutex_unlock (&t->lock);
return ret;
}
@@ -1000,11 +926,11 @@ scm_c_weak_table_put_x (SCM table, unsigned long
raw_hash,
t = SCM_WEAK_TABLE (table);
- lock_weak_table (t);
+ scm_i_pthread_mutex_lock (&t->lock);
weak_table_put_x (t, raw_hash, pred, closure, key, value);
- unlock_weak_table (t);
+ scm_i_pthread_mutex_unlock (&t->lock);
}
#undef FUNC_NAME
@@ -1020,11 +946,11 @@ scm_c_weak_table_remove_x (SCM table, unsigned long
raw_hash,
t = SCM_WEAK_TABLE (table);
- lock_weak_table (t);
+ scm_i_pthread_mutex_lock (&t->lock);
weak_table_remove_x (t, raw_hash, pred, closure);
- unlock_weak_table (t);
+ scm_i_pthread_mutex_unlock (&t->lock);
}
#undef FUNC_NAME
@@ -1072,12 +998,12 @@ scm_weak_table_clear_x (SCM table)
t = SCM_WEAK_TABLE (table);
- lock_weak_table (t);
+ scm_i_pthread_mutex_lock (&t->lock);
memset (t->entries, 0, sizeof (scm_t_weak_entry) * t->size);
t->n_items = 0;
- unlock_weak_table (t);
+ scm_i_pthread_mutex_unlock (&t->lock);
return SCM_UNSPECIFIED;
}
@@ -1093,7 +1019,7 @@ scm_c_weak_table_fold (scm_t_table_fold_fn proc, void
*closure,
t = SCM_WEAK_TABLE (table);
- lock_weak_table (t);
+ scm_i_pthread_mutex_lock (&t->lock);
size = t->size;
entries = t->entries;
@@ -1109,16 +1035,16 @@ scm_c_weak_table_fold (scm_t_table_fold_fn proc, void
*closure,
if (copy.key && copy.value)
{
/* Release table lock while we call the function. */
- unlock_weak_table (t);
+ scm_i_pthread_mutex_unlock (&t->lock);
init = proc (closure,
SCM_PACK (copy.key), SCM_PACK (copy.value),
init);
- lock_weak_table (t);
+ scm_i_pthread_mutex_lock (&t->lock);
}
}
}
- unlock_weak_table (t);
+ scm_i_pthread_mutex_unlock (&t->lock);
return init;
}
@@ -1273,12 +1199,6 @@ scm_weak_table_prehistory (void)
GC_new_kind (GC_new_free_list (),
GC_MAKE_PROC (GC_new_proc (mark_weak_value_table), 0),
0, 0);
-
-#if SCM_USE_PTHREAD_THREADS
- all_weak_tables = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
- pthread_atfork (lock_all_weak_tables, unlock_all_weak_tables,
- unlock_all_weak_tables);
-#endif
}
void
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index b9debd4..7ca4868 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 2831251..11c19d8 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 67ecbae..a2a930a 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 d8cfafa..daa3d07 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 0000000..536945b
--- /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 78068ff..834ce5f 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 9118eea..940fb31 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";)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-62-g508e4a5,
Andy Wingo <=