/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
- * 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ * 2006, 2007, 2008, 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
}
#undef FUNC_NAME
+SCM
+scm_current_warning_port (void)
+{
+ static SCM cwp_var = SCM_BOOL_F;
+
+ if (scm_is_false (cwp_var))
+ cwp_var = scm_c_private_lookup ("guile", "current-warning-port");
+
+ return scm_call_0 (scm_variable_ref (cwp_var));
+}
+
SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
(),
"Return the current-load-port.\n"
}
#undef FUNC_NAME
+
+SCM
+scm_set_current_warning_port (SCM port)
+{
+ static SCM cwp_var = SCM_BOOL_F;
+
+ if (scm_is_false (cwp_var))
+ cwp_var = scm_c_private_lookup ("guile", "current-warning-port");
+
+ return scm_call_1 (scm_variable_ref (cwp_var), port);
+}
+
+
void
scm_dynwind_current_input_port (SCM port)
#define FUNC_NAME NULL
/* Register a finalizer for PORT so that its iconv CDs get freed and
optionally its type's `free' function gets called. */
- GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (port),
- finalize_port, 0,
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port), finalize_port, 0,
&prev_finalizer,
&prev_finalization_data);
}
else
{
scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port);
- scm_t_port *entry;
if (ptob->free)
/* Yes, I really do mean `free' rather than `close'. `close'
is for explicit `close-port' by user. */
ptob->free (port);
- entry = SCM_PTAB_ENTRY (port);
-
- if (entry->input_cd != (iconv_t) -1)
- iconv_close (entry->input_cd);
- if (entry->output_cd != (iconv_t) -1)
- iconv_close (entry->output_cd);
-
SCM_SETSTREAM (port, 0);
SCM_CLR_PORT_OPEN_FLAG (port);
SCM_SET_CELL_WORD_1 (ret, (scm_t_bits) entry);
SCM_SET_CELL_WORD_2 (ret, (scm_t_bits) ptob);
-#if SCM_USE_PTHREAD_THREADS
- scm_i_pthread_mutex_init (&entry->lock, scm_i_pthread_mutexattr_recursive);
-#endif
+ entry->lock = scm_gc_malloc_pointerless (sizeof (*entry->lock), "port lock");
+ scm_i_pthread_mutex_init (entry->lock, scm_i_pthread_mutexattr_recursive);
entry->file_name = SCM_BOOL_F;
entry->rw_active = SCM_PORT_NEITHER;
entry->port = ret;
entry->stream = stream;
entry->encoding = encoding ? scm_gc_strdup (encoding, "port") : NULL;
- /* The conversion descriptors will be opened lazily. */
- entry->input_cd = (iconv_t) -1;
- entry->output_cd = (iconv_t) -1;
+ if (encoding && strcmp (encoding, "UTF-8") == 0)
+ entry->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
+ else
+ entry->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
entry->ilseq_handler = handler;
+ entry->iconv_descriptors = NULL;
scm_weak_set_add_x (scm_i_port_weak_set, ret);
/* Remove a port from the table and destroy it. */
+static void close_iconv_descriptors (scm_t_iconv_descriptors *id);
+
static void
scm_i_remove_port (SCM port)
#define FUNC_NAME "scm_remove_port"
p->putback_buf = NULL;
p->putback_buf_size = 0;
- if (p->input_cd != (iconv_t) -1)
+ if (p->iconv_descriptors)
{
- iconv_close (p->input_cd);
- p->input_cd = (iconv_t) -1;
- }
-
- if (p->output_cd != (iconv_t) -1)
- {
- iconv_close (p->output_cd);
- p->output_cd = (iconv_t) -1;
+ close_iconv_descriptors (p->iconv_descriptors);
+ p->iconv_descriptors = NULL;
}
}
#undef FUNC_NAME
}
}
-void
-scm_i_set_port_encoding_x (SCM port, const char *encoding)
+static void
+finalize_iconv_descriptors (GC_PTR ptr, GC_PTR data)
{
- scm_t_port *pt;
- iconv_t new_input_cd, new_output_cd;
+ close_iconv_descriptors (ptr);
+}
- new_input_cd = (iconv_t) -1;
- new_output_cd = (iconv_t) -1;
+static scm_t_iconv_descriptors *
+open_iconv_descriptors (const char *encoding, int reading, int writing)
+{
+ scm_t_iconv_descriptors *id;
+ iconv_t input_cd, output_cd;
- /* Set the character encoding for this port. */
- pt = SCM_PTAB_ENTRY (port);
+ input_cd = (iconv_t) -1;
+ output_cd = (iconv_t) -1;
- if (encoding == NULL)
- encoding = "ISO-8859-1";
-
- if (pt->encoding != encoding)
- pt->encoding = scm_gc_strdup (encoding, "port");
+ if (reading)
+ {
+ /* Open an input iconv conversion descriptor, from ENCODING
+ to UTF-8. We choose UTF-8, not UTF-32, because iconv
+ implementations can typically convert from anything to
+ UTF-8, but not to UTF-32 (see
+ <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html>). */
+
+ /* Assume opening an iconv descriptor causes about 16 KB of
+ allocation. */
+ scm_gc_register_allocation (16 * 1024);
+
+ input_cd = iconv_open ("UTF-8", encoding);
+ if (input_cd == (iconv_t) -1)
+ goto invalid_encoding;
+ }
- /* If ENCODING is UTF-8, then no conversion descriptor is opened
- because we do I/O ourselves. This saves 100+ KiB for each
- descriptor. */
- if (strcmp (encoding, "UTF-8"))
+ if (writing)
{
- if (SCM_CELL_WORD_0 (port) & SCM_RDNG)
- {
- /* Open an input iconv conversion descriptor, from ENCODING
- to UTF-8. We choose UTF-8, not UTF-32, because iconv
- implementations can typically convert from anything to
- UTF-8, but not to UTF-32 (see
- <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html>). */
- new_input_cd = iconv_open ("UTF-8", encoding);
- if (new_input_cd == (iconv_t) -1)
- goto invalid_encoding;
- }
+ /* Assume opening an iconv descriptor causes about 16 KB of
+ allocation. */
+ scm_gc_register_allocation (16 * 1024);
- if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
- {
- new_output_cd = iconv_open (encoding, "UTF-8");
- if (new_output_cd == (iconv_t) -1)
- {
- if (new_input_cd != (iconv_t) -1)
- iconv_close (new_input_cd);
- goto invalid_encoding;
- }
- }
+ output_cd = iconv_open (encoding, "UTF-8");
+ if (output_cd == (iconv_t) -1)
+ {
+ if (input_cd != (iconv_t) -1)
+ iconv_close (input_cd);
+ goto invalid_encoding;
+ }
}
- if (pt->input_cd != (iconv_t) -1)
- iconv_close (pt->input_cd);
- if (pt->output_cd != (iconv_t) -1)
- iconv_close (pt->output_cd);
+ id = scm_gc_malloc_pointerless (sizeof (*id), "iconv descriptors");
+ id->input_cd = input_cd;
+ id->output_cd = output_cd;
+
+ {
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalization_data;
- pt->input_cd = new_input_cd;
- pt->output_cd = new_output_cd;
+ /* Register a finalizer to close the descriptors. */
+ GC_REGISTER_FINALIZER_NO_ORDER (id, finalize_iconv_descriptors, 0,
+ &prev_finalizer, &prev_finalization_data);
+ }
- return;
+ return id;
invalid_encoding:
{
SCM err;
err = scm_from_locale_string (encoding);
- scm_misc_error ("scm_i_set_port_encoding_x",
+ scm_misc_error ("open_iconv_descriptors",
"invalid or unknown character encoding ~s",
scm_list_1 (err));
}
}
+static void
+close_iconv_descriptors (scm_t_iconv_descriptors *id)
+{
+ if (id->input_cd != (iconv_t) -1)
+ iconv_close (id->input_cd);
+ if (id->output_cd != (iconv_t) -1)
+ iconv_close (id->output_cd);
+ id->input_cd = (void *) -1;
+ id->output_cd = (void *) -1;
+}
+
+scm_t_iconv_descriptors *
+scm_i_port_iconv_descriptors (SCM port)
+{
+ scm_t_port *pt;
+
+ pt = SCM_PTAB_ENTRY (port);
+
+ assert (pt->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV);
+
+ if (!pt->iconv_descriptors)
+ {
+ if (!pt->encoding)
+ pt->encoding = "ISO-8859-1";
+ pt->iconv_descriptors =
+ open_iconv_descriptors (pt->encoding,
+ SCM_INPUT_PORT_P (port),
+ SCM_OUTPUT_PORT_P (port));
+ }
+
+ return pt->iconv_descriptors;
+}
+
+void
+scm_i_set_port_encoding_x (SCM port, const char *encoding)
+{
+ scm_t_port *pt;
+ scm_t_iconv_descriptors *prev;
+
+ /* Set the character encoding for this port. */
+ pt = SCM_PTAB_ENTRY (port);
+ prev = pt->iconv_descriptors;
+
+ if (encoding == NULL)
+ encoding = "ISO-8859-1";
+
+ if (strcmp (encoding, "UTF-8") == 0)
+ {
+ pt->encoding = "UTF-8";
+ pt->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
+ pt->iconv_descriptors = NULL;
+ }
+ else
+ {
+ /* Open descriptors before mutating the port. */
+ pt->iconv_descriptors =
+ open_iconv_descriptors (encoding,
+ SCM_INPUT_PORT_P (port),
+ SCM_OUTPUT_PORT_P (port));
+ pt->encoding = scm_gc_strdup (encoding, "port");
+ pt->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
+ }
+
+ if (prev)
+ close_iconv_descriptors (prev);
+}
+
SCM_DEFINE (scm_port_encoding, "port-encoding", 1, 0, 0,
(SCM port),
"Returns, as a string, the character encoding that @var{port}\n"
/* The port lock. */
static void
-lock_port (SCM port)
+lock_port (void *mutex)
{
- scm_c_lock_port (port);
+ scm_i_pthread_mutex_lock (mutex);
}
static void
-unlock_port (SCM port)
+unlock_port (void *mutex)
{
- scm_c_unlock_port (port);
+ scm_i_pthread_mutex_unlock (mutex);
}
void
scm_dynwind_lock_port (SCM port)
+#define FUNC_NAME "dynwind-lock-port"
{
- scm_dynwind_unwind_handler_with_scm (unlock_port, port,
- SCM_F_WIND_EXPLICITLY);
- scm_dynwind_rewind_handler_with_scm (lock_port, port,
- SCM_F_WIND_EXPLICITLY);
+ scm_i_pthread_mutex_t *lock;
+ SCM_VALIDATE_OPPORT (SCM_ARG1, port);
+ scm_c_lock_port (port, &lock);
+ if (lock)
+ {
+ scm_dynwind_unwind_handler (unlock_port, lock, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_rewind_handler (lock_port, lock, 0);
+ }
}
+#undef FUNC_NAME
\f
int
scm_revealed_count (SCM port)
{
+ scm_i_pthread_mutex_t *lock;
int ret;
- scm_c_lock_port (port);
+ scm_c_lock_port (port, &lock);
ret = SCM_REVEALED (port);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
return ret;
}
#define FUNC_NAME s_scm_set_port_revealed_x
{
int r;
+ scm_i_pthread_mutex_t *lock;
+
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port);
r = scm_to_int (rcount);
- scm_c_lock_port (port);
+ scm_c_lock_port (port, &lock);
SCM_REVEALED (port) = r;
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
(SCM port, SCM addend),
"Add @var{addend} to the revealed count of @var{port}.\n"
"The return value is unspecified.")
-#define FUNC_NAME s_scm_set_port_revealed_x
+#define FUNC_NAME s_scm_adjust_port_revealed_x
{
+ scm_i_pthread_mutex_t *lock;
int a;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port);
a = scm_to_int (addend);
- scm_c_lock_port (port);
+ scm_c_lock_port (port, &lock);
SCM_REVEALED (port) += a;
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
int
scm_get_byte_or_eof (SCM port)
{
+ scm_i_pthread_mutex_t *lock;
int ret;
- scm_c_lock_port (port);
+ scm_c_lock_port (port, &lock);
ret = scm_get_byte_or_eof_unlocked (port);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
return ret;
}
int
scm_peek_byte_or_eof (SCM port)
{
+ scm_i_pthread_mutex_t *lock;
int ret;
- scm_c_lock_port (port);
+ scm_c_lock_port (port, &lock);
ret = scm_peek_byte_or_eof_unlocked (port);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
return ret;
}
size_t
scm_c_read (SCM port, void *buffer, size_t size)
{
+ scm_i_pthread_mutex_t *lock;
size_t ret;
- scm_c_lock_port (port);
+ scm_c_lock_port (port, &lock);
ret = scm_c_read_unlocked (port, buffer, size);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
return ret;
}
get_iconv_codepoint (SCM port, scm_t_wchar *codepoint,
char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
{
- scm_t_port *pt;
+ scm_t_iconv_descriptors *id;
int err, byte_read;
size_t bytes_consumed, output_size;
char *output;
scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE];
- pt = SCM_PTAB_ENTRY (port);
+ id = scm_i_port_iconv_descriptors (port);
for (output_size = 0, output = (char *) utf8_buf,
bytes_consumed = 0, err = 0;
input_left = bytes_consumed + 1;
output_left = sizeof (utf8_buf);
- done = iconv (pt->input_cd, &input, &input_left,
- &output, &output_left);
+ done = iconv (id->input_cd, &input, &input_left, &output, &output_left);
if (done == (size_t) -1)
{
err = errno;
int err;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
- if (pt->input_cd == (iconv_t) -1)
- /* Initialize the conversion descriptors, if needed. */
- scm_i_set_port_encoding_x (port, pt->encoding);
-
- /* FIXME: In 2.1, add a flag to determine whether a port is UTF-8. */
- if (pt->input_cd == (iconv_t) -1)
+ if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
err = get_utf8_codepoint (port, codepoint, (scm_t_uint8 *) buf, len);
else
err = get_iconv_codepoint (port, codepoint, buf, len);
scm_t_wchar
scm_getc (SCM port)
{
+ scm_i_pthread_mutex_t *lock;
scm_t_wchar ret;
- scm_c_lock_port (port);
+ scm_c_lock_port (port, &lock);
ret = scm_getc_unlocked (port);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
return ret;
}
void
scm_unget_byte (int c, SCM port)
{
- scm_c_lock_port (port);
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
scm_unget_byte_unlocked (c, port);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
void
void
scm_ungetc (scm_t_wchar c, SCM port)
{
- scm_c_lock_port (port);
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
scm_ungetc_unlocked (c, port);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
void
void
scm_ungets (const char *s, int n, SCM port)
{
- scm_c_lock_port (port);
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
scm_ungets_unlocked (s, n, port);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
SCM_DEFINE (scm_unread_char, "unread-char", 1, 1, 0,
(SCM cobj, SCM port),
- "Place @var{char} in @var{port} so that it will be read by the\n"
- "next read operation. If called multiple times, the unread characters\n"
- "will be read again in last-in first-out order. If @var{port} is\n"
- "not supplied, the current input port is used.")
+ "Place character @var{cobj} in @var{port} so that it will be\n"
+ "read by the next read operation. If called multiple times, the\n"
+ "unread characters will be read again in last-in first-out\n"
+ "order. If @var{port} is not supplied, the current input port\n"
+ "is used.")
#define FUNC_NAME s_scm_unread_char
{
int c;
int
scm_fill_input (SCM port)
{
+ scm_i_pthread_mutex_t *lock;
int ret;
- scm_c_lock_port (port);
+ scm_c_lock_port (port, &lock);
ret = scm_fill_input_unlocked (port);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
return ret;
}
void
scm_end_input (SCM port)
{
- scm_c_lock_port (port);
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
scm_end_input_unlocked (port);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
void
scm_flush (SCM port)
{
- scm_c_lock_port (port);
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
scm_flush_unlocked (port);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
void
scm_putc (char c, SCM port)
{
- scm_c_lock_port (port);
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
scm_putc_unlocked (c, port);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
void
scm_puts (const char *s, SCM port)
{
- scm_c_lock_port (port);
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
scm_puts_unlocked (s, port);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
/* scm_c_write
void
scm_c_write (SCM port, const void *ptr, size_t size)
{
- scm_c_lock_port (port);
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
scm_c_write_unlocked (port, ptr, size);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
/* scm_lfwrite
void
scm_lfwrite (const char *ptr, size_t size, SCM port)
{
- scm_c_lock_port (port);
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
scm_lfwrite_unlocked (ptr, size, port);
- scm_c_unlock_port (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
/* Write STR to PORT from START inclusive to END exclusive. */
SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
(SCM fd_port, SCM offset, SCM whence),
- "Sets the current position of @var{fd/port} to the integer\n"
+ "Sets the current position of @var{fd_port} to the integer\n"
"@var{offset}, which is interpreted according to the value of\n"
"@var{whence}.\n"
"\n"
"@defvar SEEK_END\n"
"Seek from the end of the file.\n"
"@end defvar\n"
- "If @var{fd/port} is a file descriptor, the underlying system\n"
+ "If @var{fd_port} is a file descriptor, the underlying system\n"
"call is @code{lseek}. @var{port} may be a string port.\n"
"\n"
"The value returned is the new position in the file. This means\n"
SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
(SCM object, SCM length),
- "Truncate @var{file} to @var{length} bytes. @var{file} can be a\n"
- "filename string, a port object, or an integer file descriptor.\n"
+ "Truncate file @var{object} to @var{length} bytes. @var{object}\n"
+ "can be a filename string, a port object, or an integer file\n"
+ "descriptor.\n"
"The return value is unspecified.\n"
"\n"
"For a port or file descriptor @var{length} can be omitted, in\n"
"Apply @var{proc} to each port in the Guile port table\n"
"in turn. The return value is unspecified. More specifically,\n"
"@var{proc} is applied exactly once to every port that exists\n"
- "in the system at the time @var{port-for-each} is invoked.\n"
- "Changes to the port table while @var{port-for-each} is running\n"
- "have no effect as far as @var{port-for-each} is concerned.")
+ "in the system at the time @code{port-for-each} is invoked.\n"
+ "Changes to the port table while @code{port-for-each} is running\n"
+ "have no effect as far as @code{port-for-each} is concerned.")
#define FUNC_NAME s_scm_port_for_each
{
SCM_VALIDATE_PROC (1, proc);
#include "libguile/ports.x"
/* Use Latin-1 as the default port encoding. */
- SCM_VARIABLE_SET (default_port_encoding_var, scm_make_fluid ());
- scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
+ SCM_VARIABLE_SET (default_port_encoding_var,
+ scm_make_fluid_with_default (SCM_BOOL_F));
scm_port_encoding_init = 1;
- SCM_VARIABLE_SET (scm_conversion_strategy, scm_make_fluid ());
- scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy),
- scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK));
+ SCM_VARIABLE_SET (scm_conversion_strategy,
+ scm_make_fluid_with_default
+ (scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK)));
scm_conversion_strategy_init = 1;
+ /* These bindings are used when boot-9 turns `current-input-port' et
+ al into parameters. They are then removed from the guile module. */
+ scm_c_define ("%current-input-port-fluid", cur_inport_fluid);
+ scm_c_define ("%current-output-port-fluid", cur_outport_fluid);
+ scm_c_define ("%current-error-port-fluid", cur_errport_fluid);
}
/*
HCoop / bpt / guile.git / blobdiff