/* 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
void
scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port))
{
- scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->flush = flush;
+ scm_t_ptob_descriptor *ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc));
+ ptob->flush = flush;
+ ptob->flags |= SCM_PORT_TYPE_HAS_FLUSH;
}
void
}
#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
long
scm_mode_bits (char *modes)
{
- return scm_i_mode_bits (scm_from_locale_string (modes));
+ /* Valid characters are rw+a0l. So, use latin1. */
+ return scm_i_mode_bits (scm_from_latin1_string (modes));
}
long
/* Port finalization. */
-static void finalize_port (GC_PTR, GC_PTR);
+struct do_free_data
+{
+ scm_t_ptob_descriptor *ptob;
+ SCM port;
+};
-/* Register a finalizer for PORT. */
-static SCM_C_INLINE_KEYWORD void
-register_finalizer_for_port (SCM port)
+static SCM
+do_free (void *body_data)
{
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalization_data;
+ struct do_free_data *data = body_data;
- /* 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,
- &prev_finalizer,
- &prev_finalization_data);
+ /* `close' is for explicit `close-port' by user. `free' is for this
+ purpose: ports collected by the GC. */
+ data->ptob->free (data->port);
+
+ return SCM_BOOL_T;
}
/* Finalize the object (a port) pointed to by PTR. */
if (SCM_OPENP (port))
{
- if (SCM_REVEALED (port) > 0)
- /* Keep "revealed" ports alive and re-register a finalizer. */
- register_finalizer_for_port (port);
- else
- {
- scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port);
- scm_t_port *entry;
+ struct do_free_data data;
- if (ptob->free)
- /* Yes, I really do mean `free' rather than `close'. `close'
- is for explicit `close-port' by user. */
- ptob->free (port);
+ SCM_CLR_PORT_OPEN_FLAG (port);
- entry = SCM_PTAB_ENTRY (port);
+ data.ptob = SCM_PORT_DESCRIPTOR (port);
+ data.port = 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_internal_catch (SCM_BOOL_T, do_free, &data,
+ scm_handle_by_message_noexit, NULL);
- SCM_SETSTREAM (port, 0);
- SCM_CLR_PORT_OPEN_FLAG (port);
-
- scm_gc_ports_collected++;
- }
+ scm_gc_ports_collected++;
}
}
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 if (!encoding || strcmp (encoding, "ISO-8859-1") == 0)
+ entry->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
+ 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);
+ if (SCM_PORT_DESCRIPTOR (ret)->free)
+ scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL);
- /* For each new port, register a finalizer so that it port type's free
- function can be invoked eventually. */
- register_finalizer_for_port (ret);
+ if (SCM_PORT_DESCRIPTOR (ret)->flags & SCM_PORT_TYPE_HAS_FLUSH)
+ scm_weak_set_add_x (scm_i_port_weak_set, ret);
return ret;
}
return scm_c_make_port (tag, 0, 0);
}
-/* Remove a port from the table and destroy it. */
-
-static void
-scm_i_remove_port (SCM port)
-#define FUNC_NAME "scm_remove_port"
-{
- scm_t_port *p;
-
- p = SCM_PTAB_ENTRY (port);
- scm_port_non_buffer (p);
- SCM_SETPTAB_ENTRY (port, 0);
- scm_weak_set_remove_x (scm_i_port_weak_set, port);
-
- p->putback_buf = NULL;
- p->putback_buf_size = 0;
-
- if (p->input_cd != (iconv_t) -1)
- {
- 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;
- }
-}
-#undef FUNC_NAME
-
-
\f
/* Predicates. */
/* Closing ports. */
+static void close_iconv_descriptors (scm_t_iconv_descriptors *id);
+
/* scm_close_port
* Call the close operation on a port object.
* see also scm_close.
"descriptors.")
#define FUNC_NAME s_scm_close_port
{
+ scm_t_port *p;
int rv;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_PORT (1, port);
if (SCM_CLOSEDP (port))
return SCM_BOOL_F;
+
+ p = SCM_PTAB_ENTRY (port);
+ SCM_CLR_PORT_OPEN_FLAG (port);
+
+ if (SCM_PORT_DESCRIPTOR (port)->flags & SCM_PORT_TYPE_HAS_FLUSH)
+ scm_weak_set_remove_x (scm_i_port_weak_set, port);
+
if (SCM_PORT_DESCRIPTOR (port)->close)
+ /* Note! This may throw an exception. Anything after this point
+ should be resilient to non-local exits. */
rv = SCM_PORT_DESCRIPTOR (port)->close (port);
else
rv = 0;
- scm_i_remove_port (port);
- SCM_CLR_PORT_OPEN_FLAG (port);
+
+ if (p->iconv_descriptors)
+ {
+ /* If we don't get here, the iconv_descriptors finalizer will
+ clean up. */
+ close_iconv_descriptors (p->iconv_descriptors);
+ p->iconv_descriptors = NULL;
+ }
+
return scm_from_bool (rv >= 0);
}
#undef FUNC_NAME
|| !strcmp (encoding, "ISO-8859-1"))
scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
else
- scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var),
- scm_from_locale_string (encoding));
+ {
+ SCM str;
+ size_t i;
+
+ str = scm_from_latin1_string (encoding);
+
+ /* Restrict to ASCII. */
+ for (i = 0; encoding[i]; i++)
+ if (encoding[i] > 127)
+ scm_misc_error ("scm_i_set_default_port_encoding",
+ "invalid character encoding ~s", scm_list_1 (str));
+
+ scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), str);
+ }
}
/* Return the name of the default encoding for newly created ports; a
}
}
-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;
+ size_t i;
- /* 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";
+ for (i = 0; encoding[i]; i++)
+ if (encoding[i] > 127)
+ goto invalid_encoding;
- 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;
- pt->input_cd = new_input_cd;
- pt->output_cd = new_output_cd;
+ /* Register a finalizer to close the descriptors. */
+ scm_i_set_finalizer (id, finalize_iconv_descriptors, NULL);
- return;
+ return id;
invalid_encoding:
{
SCM err;
- err = scm_from_locale_string (encoding);
- scm_misc_error ("scm_i_set_port_encoding_x",
+ err = scm_from_latin1_string (encoding);
+ 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;
+}
+
+/* The name of the encoding is itself encoded in ASCII. */
+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 && strcmp (encoding, "UTF-8") == 0)
+ {
+ pt->encoding = "UTF-8";
+ pt->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
+ pt->iconv_descriptors = NULL;
+ }
+ else if (!encoding || strcmp (encoding, "ISO-8859-1") == 0)
+ {
+ pt->encoding = "ISO-8859-1";
+ pt->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
+ 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"
pt = SCM_PTAB_ENTRY (port);
enc = pt->encoding;
if (enc)
- return scm_from_locale_string (pt->encoding);
+ return scm_from_latin1_string (pt->encoding);
else
return SCM_BOOL_F;
}
SCM_VALIDATE_PORT (1, port);
SCM_VALIDATE_STRING (2, enc);
- enc_str = scm_to_locale_string (enc);
+ enc_str = scm_to_latin1_string (enc);
scm_i_set_port_encoding_x (port, enc_str);
free (enc_str);
\f
-/* Revealed counts --- an oddity inherited from SCSH. */
+/* The port lock. */
-/* Find a port in the table and return its revealed count.
- Also used by the garbage collector.
- */
-int
-scm_revealed_count (SCM port)
-{
- int ret;
-
- scm_c_lock_port (port);
- ret = SCM_REVEALED (port);
- scm_c_unlock_port (port);
-
- return ret;
-}
-
-SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
- (SCM port),
- "Return the revealed count for @var{port}.")
-#define FUNC_NAME s_scm_port_revealed
+static void
+lock_port (void *mutex)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return scm_from_int (scm_revealed_count (port));
+ scm_i_pthread_mutex_lock (mutex);
}
-#undef FUNC_NAME
-/* Set the revealed count for a port. */
-SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
- (SCM port, SCM rcount),
- "Sets the revealed count for a port to a given value.\n"
- "The return value is unspecified.")
-#define FUNC_NAME s_scm_set_port_revealed_x
+static void
+unlock_port (void *mutex)
{
- int r;
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- r = scm_to_int (rcount);
- scm_c_lock_port (port);
- SCM_REVEALED (port) = r;
- scm_c_unlock_port (port);
- return SCM_UNSPECIFIED;
+ scm_i_pthread_mutex_unlock (mutex);
}
-#undef FUNC_NAME
-/* Set the revealed count for a port. */
-SCM_DEFINE (scm_adjust_port_revealed_x, "adjust-port-revealed!", 2, 0, 0,
- (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
+void
+scm_dynwind_lock_port (SCM port)
+#define FUNC_NAME "dynwind-lock-port"
{
- int a;
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- a = scm_to_int (addend);
- scm_c_lock_port (port);
- SCM_REVEALED (port) += a;
- scm_c_unlock_port (port);
- return SCM_UNSPECIFIED;
+ 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
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;
}
/* Call scm_fill_input until we have all the bytes that we need,
or we hit EOF. */
- while (pt->read_buf_size && (scm_fill_input (port) != EOF))
+ while (pt->read_buf_size && (scm_fill_input_unlocked (port) != EOF))
{
pt->read_buf_size -= (pt->read_end - pt->read_pos);
pt->read_pos = pt->read_buf = pt->read_end;
that a custom port implementation's entry points (in
particular, fill_input) can rely on the buffer always being
the same as they first set up. */
- while (size && (scm_fill_input (port) != EOF))
+ while (size && (scm_fill_input_unlocked (port) != EOF))
{
n_available = min (size, pt->read_end - pt->read_pos);
memcpy (buffer, pt->read_pos, n_available);
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;
}
#undef ASSERT_NOT_EOF
}
+/* Read an ISO-8859-1 codepoint (a byte) from PORT. On success, return
+ 0 and set *CODEPOINT to the codepoint that was read, fill BUF with
+ its UTF-8 representation, and set *LEN to the length in bytes.
+ Return `EILSEQ' on error. */
+static int
+get_latin1_codepoint (SCM port, scm_t_wchar *codepoint,
+ char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
+{
+ *codepoint = scm_get_byte_or_eof_unlocked (port);
+
+ if (*codepoint == EOF)
+ *len = 0;
+ else
+ {
+ *len = 1;
+ buf[0] = *codepoint;
+ }
+ return 0;
+}
+
/* Likewise, read a byte sequence from PORT, passing it through its
input conversion descriptor. */
static int
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;
with the byte representation of the codepoint in PORT's encoding, and
set *LEN to the length in bytes of that representation. Return 0 on
success and an errno value on error. */
-static int
+static SCM_C_INLINE int
get_codepoint (SCM port, scm_t_wchar *codepoint,
char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
{
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 if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+ err = get_latin1_codepoint (port, codepoint, 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;
}
/* Pushback. */
void
-scm_unget_byte (int c, SCM port)
+scm_unget_byte_unlocked (int c, SCM port)
#define FUNC_NAME "scm_unget_byte"
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
}
#undef FUNC_NAME
+void
+scm_unget_byte (int c, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_unget_byte_unlocked (c, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
+
void
-scm_ungetc (scm_t_wchar c, SCM port)
+scm_ungetc_unlocked (scm_t_wchar c, SCM port)
#define FUNC_NAME "scm_ungetc"
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM_BOOL_F, SCM_MAKE_CHAR (c));
for (i = len - 1; i >= 0; i--)
- scm_unget_byte (result[i], port);
+ scm_unget_byte_unlocked (result[i], port);
if (SCM_UNLIKELY (result != result_buf))
free (result);
}
#undef FUNC_NAME
+void
+scm_ungetc (scm_t_wchar c, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_ungetc_unlocked (c, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
void
-scm_ungets (const char *s, int n, SCM port)
+scm_ungets_unlocked (const char *s, int n, SCM port)
{
/* This is simple minded and inefficient, but unreading strings is
* probably not a common operation, and remember that line and
* Please feel free to write an optimized version!
*/
while (n--)
- scm_ungetc (s[n], port);
+ scm_ungetc_unlocked (s[n], port);
}
+void
+scm_ungets (const char *s, int n, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_ungets_unlocked (s, n, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
(SCM port),
err = get_codepoint (port, &c, bytes, &len);
for (i = len - 1; i >= 0; i--)
- scm_unget_byte (bytes[i], port);
+ scm_unget_byte_unlocked (bytes[i], port);
SCM_COL (port) = column;
SCM_LINUM (port) = line;
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;
c = SCM_CHAR (cobj);
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return cobj;
}
#undef FUNC_NAME
n = scm_i_string_length (str);
while (n--)
- scm_ungetc (scm_i_string_ref (str, n), port);
+ scm_ungetc_unlocked (scm_i_string_ref (str, n), port);
return str;
}
/* Manipulating the buffers. */
+/* This routine does not take any locks, as it is usually called as part
+ of a port implementation. */
void
scm_port_non_buffer (scm_t_port *pt)
{
tries to refill the read buffer. it returns the first char from
the port, which is either EOF or *(pt->read_pos). */
int
-scm_fill_input (SCM port)
+scm_fill_input_unlocked (SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
return SCM_PORT_DESCRIPTOR (port)->fill_input (port);
}
+int
+scm_fill_input (SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ int ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = scm_fill_input_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+
+ return ret;
+}
+
/* move up to read_len chars from port's putback and/or read buffers
into memory starting at dest. returns the number of chars moved. */
size_t
#undef FUNC_NAME
void
-scm_end_input (SCM port)
+scm_end_input_unlocked (SCM port)
{
long offset;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM_PORT_DESCRIPTOR (port)->end_input (port, offset);
}
+void
+scm_end_input (SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_end_input_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
+
SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
(SCM port),
"Flush the specified output port, or the current output port if @var{port}\n"
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPOUTPORT (1, port);
}
- scm_flush (port);
+ scm_flush_unlocked (port);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
void
-scm_flush (SCM port)
+scm_flush_unlocked (SCM port)
{
SCM_PORT_DESCRIPTOR (port)->flush (port);
}
+void
+scm_flush (SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_flush_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
+
\f
/* Output. */
+void
+scm_putc (char c, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_putc_unlocked (c, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
+
+void
+scm_puts (const char *s, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_puts_unlocked (s, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
+
/* scm_c_write
*
* Used by an application to write arbitrary number of bytes to an SCM
* Warning: Doesn't update port line and column counts!
*/
void
-scm_c_write (SCM port, const void *ptr, size_t size)
+scm_c_write_unlocked (SCM port, const void *ptr, size_t size)
#define FUNC_NAME "scm_c_write"
{
scm_t_port *pt;
ptob = SCM_PORT_DESCRIPTOR (port);
if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
+ scm_end_input_unlocked (port);
ptob->write (port, ptr, size);
}
#undef FUNC_NAME
+void
+scm_c_write (SCM port, const void *ptr, size_t size)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_c_write_unlocked (port, ptr, size);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
+
/* scm_lfwrite
*
* This function differs from scm_c_write; it updates port line and
* column. */
void
-scm_lfwrite (const char *ptr, size_t size, SCM port)
+scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port);
if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
+ scm_end_input_unlocked (port);
ptob->write (port, ptr, size);
pt->rw_active = SCM_PORT_WRITE;
}
+void
+scm_lfwrite (const char *ptr, size_t size, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_lfwrite_unlocked (ptr, size, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
+
/* Write STR to PORT from START inclusive to END exclusive. */
void
scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port)
scm_t_port *pt = SCM_PTAB_ENTRY (port);
if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
+ scm_end_input_unlocked (port);
if (end == (size_t) -1)
end = scm_i_string_length (str);
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"
if (!ptob->truncate)
SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (object);
+ scm_end_input_unlocked (object);
else if (pt->rw_active == SCM_PORT_WRITE)
ptob->flush (object);
void
scm_print_port_mode (SCM exp, SCM port)
{
- scm_puts (SCM_CLOSEDP (exp)
+ scm_puts_unlocked (SCM_CLOSEDP (exp)
? "closed: "
: (SCM_RDNG & SCM_CELL_WORD_0 (exp)
? (SCM_WRTNG & SCM_CELL_WORD_0 (exp)
char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp));
if (!type)
type = "port";
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
scm_print_port_mode (exp, port);
- scm_puts (type, port);
- scm_putc (' ', port);
+ scm_puts_unlocked (type, port);
+ scm_putc_unlocked (' ', port);
scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
"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);
flush_output_port (void *closure, SCM port)
{
if (SCM_OPOUTPORTP (port))
- scm_flush (port);
+ scm_flush_unlocked (port);
}
SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
#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