diff options
Diffstat (limited to 'libguile/ports.c')
-rw-r--r-- | libguile/ports.c | 4236 |
1 files changed, 4236 insertions, 0 deletions
diff --git a/libguile/ports.c b/libguile/ports.c new file mode 100644 index 000000000..4a2e384db --- /dev/null +++ b/libguile/ports.c @@ -0,0 +1,4236 @@ +/* Copyright 1995-2001,2003-2004,2006-2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ + + + + +#define _LARGEFILE64_SOURCE /* ask for stat64 etc */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <assert.h> +#include <assert.h> +#include <errno.h> +#include <fcntl.h> /* for chsize on mingw */ +#include <iconv.h> +#include <poll.h> +#include <stdio.h> +#include <striconveh.h> +#include <string.h> +#include <uniconv.h> +#include <unistd.h> +#include <unistr.h> + +#ifdef HAVE_IO_H +#include <io.h> +#endif + +#ifdef HAVE_SYS_IOCTL_H +#include <sys/ioctl.h> +#endif + +#include "alist.h" +#include "async.h" +#include "atomics-internal.h" +#include "boolean.h" +#include "chars.h" +#include "deprecation.h" +#include "dynwind.h" +#include "eq.h" +#include "eval.h" +#include "extensions.h" +#include "finalizers.h" +#include "fluids.h" +#include "fports.h" /* direct access for seek and truncate */ +#include "goops.h" +#include "gsubr.h" +#include "hashtab.h" +#include "keywords.h" +#include "mallocs.h" +#include "modules.h" +#include "numbers.h" +#include "pairs.h" +#include "ports-internal.h" +#include "private-options.h" +#include "procs.h" +#include "smob.h" +#include "strings.h" +#include "symbols.h" +#include "syscalls.h" +#include "variable.h" +#include "vectors.h" +#include "version.h" +#include "weak-set.h" + +#include "ports.h" + + +/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize + already, but have this code here in case that wasn't so in past versions, + or perhaps to help other minimal DOS environments. + + gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which + might be possibilities if we've got other systems without ftruncate. */ + +#if defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE +#define ftruncate(fd, size) chsize (fd, size) +#undef HAVE_FTRUNCATE +#define HAVE_FTRUNCATE 1 +#endif + + + +/* We need these symbols early, before (ice-9 ports) loads in the + snarfed definitions, so we can't use SCM_SYMBOL. */ +static SCM sym_UTF_8; +static SCM sym_ISO_8859_1; +static SCM sym_UTF_16; +static SCM sym_UTF_16LE; +static SCM sym_UTF_16BE; +static SCM sym_UTF_32; +static SCM sym_UTF_32LE; +static SCM sym_UTF_32BE; + +/* Port conversion strategies. */ +static SCM sym_error; +static SCM sym_substitute; +static SCM sym_escape; + +/* See scm_port_auxiliary_write_buffer and scm_c_write. */ +static const size_t AUXILIARY_WRITE_BUFFER_SIZE = 256; + +/* Maximum number of bytes in a UTF-8 sequence. */ +static const size_t UTF8_BUFFER_SIZE = 4; + +/* Maximum number of codepoints to write an escape sequence. */ +static const size_t ESCAPE_BUFFER_SIZE = 9; + + + + +/* We have to serialize operations on any given iconv descriptor. */ +static scm_i_pthread_mutex_t iconv_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; + + + +/* See Unicode 8.0 section 5.22, "Best Practice for U+FFFD + Substitution". */ +static const scm_t_wchar UNICODE_REPLACEMENT_CHARACTER = 0xFFFD; + + + +static void +release_port (SCM port) +{ + scm_t_port *pt = SCM_PORT (port); + + /* It's possible for two close-port invocations to race, and since + close-port is defined to be idempotent we need to avoid + decrementing the refcount past 0. The normal case is that it's + open with a refcount of 1 and we're going to change it to 0. + Otherwise if the refcount is higher we just subtract 1 and we're + done. However if the current refcount is 0 then the port has been + closed or is closing and we just return. */ + uint32_t cur = 1, next = 0; + while (!scm_atomic_compare_and_swap_uint32 (&pt->refcount, &cur, next)) + { + if (cur == 0) + return; + next = cur - 1; + } + if (cur > 1) + return; + + /* FIXME: `catch' around the close call? It could throw an exception, + and in that case we'd leak the iconv descriptors, if any. */ + if (SCM_PORT_TYPE (port)->close) + SCM_PORT_TYPE (port)->close (port); + + scm_i_pthread_mutex_lock (&iconv_lock); + pt = SCM_PORT (port); + if (scm_is_true (pt->precise_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); + pt->precise_encoding = SCM_BOOL_F; + pt->input_cd = pt->output_cd = (iconv_t) -1; + } + scm_i_pthread_mutex_unlock (&iconv_lock); +} + +static void +scm_dynwind_acquire_port (SCM port) +{ + scm_t_port *pt = SCM_PORT (port); + /* We're acquiring a lease on the port so that we only close it when + no one is using it. The normal case is that it's open with a + refcount of 1 and we're going to push it to 2. Otherwise perhaps + there is someone else using it; that's fine, we just add our + refcount. However if the current refcount is 0 then the port has + been closed or is closing and we must throw an error. */ + uint32_t cur = 1, next = 2; + while (!scm_atomic_compare_and_swap_uint32 (&pt->refcount, &cur, next)) + { + if (cur == 0) + scm_wrong_type_arg_msg (NULL, 0, port, "open port"); + next = cur + 1; + } + scm_dynwind_unwind_handler_with_scm (release_port, port, + SCM_F_WIND_EXPLICITLY); +} + + + +static SCM trampoline_to_c_read_subr; +static SCM trampoline_to_c_write_subr; + +static int +default_random_access_p (SCM port) +{ + return SCM_PORT_TYPE (port)->seek != NULL; +} + +static int +default_read_wait_fd (SCM port) +{ + scm_misc_error ("read_wait_fd", "unimplemented", SCM_EOL); +} + +static int +default_write_wait_fd (SCM port) +{ + scm_misc_error ("write_wait_fd", "unimplemented", SCM_EOL); +} + +scm_t_port_type * +scm_make_port_type (char *name, + size_t (*read) (SCM port, SCM dst, size_t start, + size_t count), + size_t (*write) (SCM port, SCM src, size_t start, + size_t count)) +{ + scm_t_port_type *desc; + + desc = scm_gc_malloc_pointerless (sizeof (*desc), "port-type"); + memset (desc, 0, sizeof (*desc)); + + desc->name = name; + desc->print = scm_port_print; + desc->c_read = read; + desc->c_write = write; + desc->scm_read = read ? trampoline_to_c_read_subr : SCM_BOOL_F; + desc->scm_write = write ? trampoline_to_c_write_subr : SCM_BOOL_F; + desc->read_wait_fd = default_read_wait_fd; + desc->write_wait_fd = default_write_wait_fd; + desc->random_access_p = default_random_access_p; + scm_make_port_classes (desc); + + return desc; +} + +static SCM +trampoline_to_c_read (SCM port, SCM dst, SCM start, SCM count) +#define FUNC_NAME "port-read" +{ + size_t c_start, c_count, ret; + + SCM_VALIDATE_OPPORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, dst); + c_start = scm_to_size_t (start); + c_count = scm_to_size_t (count); + SCM_ASSERT_RANGE (3, start, c_start <= SCM_BYTEVECTOR_LENGTH (dst)); + SCM_ASSERT_RANGE (4, count, c_count <= SCM_BYTEVECTOR_LENGTH (dst) - c_start); + + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + ret = SCM_PORT_TYPE (port)->c_read (port, dst, c_start, c_count); + scm_dynwind_end (); + + return ret == (size_t) -1 ? SCM_BOOL_F : scm_from_size_t (ret); +} +#undef FUNC_NAME + +static size_t +trampoline_to_scm_read (SCM port, SCM dst, size_t start, size_t count) +{ + SCM ret = scm_call_4 (SCM_PORT_TYPE (port)->scm_read, port, dst, + scm_from_size_t (start), scm_from_size_t (count)); + return scm_is_true (ret) ? scm_to_size_t (ret) : (size_t) -1; +} + +static SCM +trampoline_to_c_write (SCM port, SCM src, SCM start, SCM count) +#define FUNC_NAME "port-write" +{ + size_t c_start, c_count, ret; + + SCM_VALIDATE_OPPORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, src); + c_start = scm_to_size_t (start); + c_count = scm_to_size_t (count); + SCM_ASSERT_RANGE (3, start, c_start <= SCM_BYTEVECTOR_LENGTH (src)); + SCM_ASSERT_RANGE (4, count, c_count <= SCM_BYTEVECTOR_LENGTH (src) - c_start); + + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + ret = SCM_PORT_TYPE (port)->c_write (port, src, c_start, c_count); + scm_dynwind_end (); + + return ret == (size_t) -1 ? SCM_BOOL_F : scm_from_size_t (ret); +} +#undef FUNC_NAME + +static size_t +trampoline_to_scm_write (SCM port, SCM src, size_t start, size_t count) +{ + SCM ret = scm_call_4 (SCM_PORT_TYPE (port)->scm_write, port, src, + scm_from_size_t (start), scm_from_size_t (count)); + return scm_is_true (ret) ? scm_to_size_t (ret) : (size_t) -1; +} + +void +scm_set_port_scm_read (scm_t_port_type *ptob, SCM read) +{ + ptob->scm_read = read; + ptob->c_read = trampoline_to_scm_read; +} + +void +scm_set_port_scm_write (scm_t_port_type *ptob, SCM write) +{ + ptob->scm_write = write; + ptob->c_write = trampoline_to_scm_write; +} + +void +scm_set_port_read_wait_fd (scm_t_port_type *ptob, int (*get_fd) (SCM)) +{ + ptob->read_wait_fd = get_fd; +} + +void +scm_set_port_write_wait_fd (scm_t_port_type *ptob, int (*get_fd) (SCM)) +{ + ptob->write_wait_fd = get_fd; +} + +void +scm_set_port_print (scm_t_port_type *ptob, + int (*print) (SCM exp, SCM port, scm_print_state *pstate)) +{ + ptob->print = print; +} + +void +scm_set_port_close (scm_t_port_type *ptob, void (*close) (SCM)) +{ + ptob->close = close; +} + +void +scm_set_port_needs_close_on_gc (scm_t_port_type *ptob, int needs_close_p) +{ + if (needs_close_p) + ptob->flags |= SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC; + else + ptob->flags &= ~SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC; +} + +void +scm_set_port_seek (scm_t_port_type *ptob, + scm_t_off (*seek) (SCM, scm_t_off, int)) +{ + ptob->seek = seek; +} + +void +scm_set_port_truncate (scm_t_port_type *ptob, void (*truncate) (SCM, scm_t_off)) +{ + ptob->truncate = truncate; +} + +void +scm_set_port_input_waiting (scm_t_port_type *ptob, int (*input_waiting) (SCM)) +{ + ptob->input_waiting = input_waiting; +} + +void +scm_set_port_random_access_p (scm_t_port_type *ptob, + int (*random_access_p) (SCM)) +{ + ptob->random_access_p = random_access_p; +} + +void +scm_set_port_get_natural_buffer_sizes + (scm_t_port_type *ptob, + void (*get_natural_buffer_sizes) (SCM, size_t *, size_t *)) +{ + ptob->get_natural_buffer_sizes = get_natural_buffer_sizes; +} + +static void +scm_i_clear_pending_eof (SCM port) +{ + scm_port_buffer_set_has_eof_p (SCM_PORT (port)->read_buf, + SCM_BOOL_F); +} + +SCM_DEFINE (scm_i_port_property, "%port-property", 2, 0, 0, + (SCM port, SCM key), + "Return the property of @var{port} associated with @var{key}.") +#define FUNC_NAME s_scm_i_port_property +{ + SCM_VALIDATE_OPPORT (1, port); + + return scm_assq_ref (SCM_PORT (port)->alist, key); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_i_set_port_property_x, "%set-port-property!", 3, 0, 0, + (SCM port, SCM key, SCM value), + "Set the property of @var{port} associated with @var{key} to @var{value}.") +#define FUNC_NAME s_scm_i_set_port_property_x +{ + scm_t_port *pt; + + SCM_VALIDATE_OPPORT (1, port); + + pt = SCM_PORT (port); + pt->alist = scm_assq_set_x (pt->alist, key, value); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + +/* Standard ports --- current input, output, error, and more(!). */ + +static SCM cur_inport_fluid = SCM_BOOL_F; +static SCM cur_outport_fluid = SCM_BOOL_F; +static SCM cur_errport_fluid = SCM_BOOL_F; +static SCM cur_warnport_fluid = SCM_BOOL_F; +static SCM cur_loadport_fluid = SCM_BOOL_F; + +SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0, + (void), + "Return the current input port. This is the default port used\n" + "by many input procedures. Initially, @code{current-input-port}\n" + "returns the @dfn{standard input} in Unix and C terminology.") +#define FUNC_NAME s_scm_current_input_port +{ + if (scm_is_true (cur_inport_fluid)) + return scm_fluid_ref (cur_inport_fluid); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0, + (void), + "Return the current output port. This is the default port used\n" + "by many output procedures. Initially,\n" + "@code{current-output-port} returns the @dfn{standard output} in\n" + "Unix and C terminology.") +#define FUNC_NAME s_scm_current_output_port +{ + if (scm_is_true (cur_outport_fluid)) + return scm_fluid_ref (cur_outport_fluid); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0, + (void), + "Return the port to which errors and warnings should be sent (the\n" + "@dfn{standard error} in Unix and C terminology).") +#define FUNC_NAME s_scm_current_error_port +{ + if (scm_is_true (cur_errport_fluid)) + return scm_fluid_ref (cur_errport_fluid); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_current_warning_port, "current-warning-port", 0, 0, 0, + (void), + "Return the port to which diagnostic warnings should be sent.") +#define FUNC_NAME s_scm_current_warning_port +{ + if (scm_is_true (cur_warnport_fluid)) + return scm_fluid_ref (cur_warnport_fluid); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0, + (), + "Return the current-load-port.\n" + "The load port is used internally by @code{primitive-load}.") +#define FUNC_NAME s_scm_current_load_port +{ + return scm_fluid_ref (cur_loadport_fluid); +} +#undef FUNC_NAME + +SCM +scm_set_current_input_port (SCM port) +#define FUNC_NAME "set-current-input-port" +{ + SCM oinp = scm_fluid_ref (cur_inport_fluid); + SCM_VALIDATE_OPINPORT (1, port); + scm_fluid_set_x (cur_inport_fluid, port); + return oinp; +} +#undef FUNC_NAME + +SCM +scm_set_current_output_port (SCM port) +#define FUNC_NAME "scm-set-current-output-port" +{ + SCM ooutp = scm_fluid_ref (cur_outport_fluid); + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPOUTPORT (1, port); + scm_fluid_set_x (cur_outport_fluid, port); + return ooutp; +} +#undef FUNC_NAME + +SCM +scm_set_current_error_port (SCM port) +#define FUNC_NAME "set-current-error-port" +{ + SCM oerrp = scm_fluid_ref (cur_errport_fluid); + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPOUTPORT (1, port); + scm_fluid_set_x (cur_errport_fluid, port); + return oerrp; +} +#undef FUNC_NAME + +SCM +scm_set_current_warning_port (SCM port) +#define FUNC_NAME "set-current-warning-port" +{ + SCM owarnp = scm_fluid_ref (cur_warnport_fluid); + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPOUTPORT (1, port); + scm_fluid_set_x (cur_warnport_fluid, port); + return owarnp; +} +#undef FUNC_NAME + +void +scm_dynwind_current_input_port (SCM port) +#define FUNC_NAME NULL +{ + SCM_VALIDATE_OPINPORT (1, port); + scm_dynwind_fluid (cur_inport_fluid, port); +} +#undef FUNC_NAME + +void +scm_dynwind_current_output_port (SCM port) +#define FUNC_NAME NULL +{ + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPOUTPORT (1, port); + scm_dynwind_fluid (cur_outport_fluid, port); +} +#undef FUNC_NAME + +void +scm_dynwind_current_error_port (SCM port) +#define FUNC_NAME NULL +{ + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPOUTPORT (1, port); + scm_dynwind_fluid (cur_errport_fluid, port); +} +#undef FUNC_NAME + +void +scm_i_dynwind_current_load_port (SCM port) +{ + scm_dynwind_fluid (cur_loadport_fluid, port); +} + + + + +/* Port buffers. */ + +static SCM +make_port_buffer (SCM port, size_t size) +{ + SCM ret = scm_c_make_vector (SCM_PORT_BUFFER_FIELD_COUNT, SCM_INUM0); + + SCM_SIMPLE_VECTOR_SET (ret, SCM_PORT_BUFFER_FIELD_BYTEVECTOR, + scm_c_make_bytevector (size)); + SCM_SIMPLE_VECTOR_SET (ret, SCM_PORT_BUFFER_FIELD_POSITION, + SCM_PORT (port)->position); + scm_port_buffer_set_has_eof_p (ret, SCM_BOOL_F); + + return ret; +} + + + + +/* Retrieving a port's mode. */ + +/* Return the flags that characterize a port based on the mode + * string used to open a file for that port. + * + * See PORT FLAGS in scm.h + */ + +static long +scm_i_mode_bits_n (SCM modes) +{ + return ((scm_i_string_contains_char (modes, 'r') + || scm_i_string_contains_char (modes, '+') ? SCM_RDNG : 0) + | (scm_i_string_contains_char (modes, 'w') + || scm_i_string_contains_char (modes, 'a') + || scm_i_string_contains_char (modes, '+') ? SCM_WRTNG : 0) + | (scm_i_string_contains_char (modes, '0') ? SCM_BUF0 : 0) + | (scm_i_string_contains_char (modes, 'l') ? SCM_BUFLINE : 0)); +} + +long +scm_mode_bits (char *modes) +{ + /* Valid characters are rw+a0l. So, use latin1. */ + return scm_i_mode_bits (scm_from_latin1_string (modes)); +} + +long +scm_i_mode_bits (SCM modes) +{ + long bits; + + if (!scm_is_string (modes)) + scm_wrong_type_arg_msg (NULL, 0, modes, "string"); + + bits = scm_i_mode_bits_n (modes); + scm_remember_upto_here_1 (modes); + return bits; +} + +/* Return the mode flags from an open port. + * Some modes such as "append" are only used when opening + * a file and are not returned here. */ + +SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0, + (SCM port), + "Return the port modes associated with the open port @var{port}.\n" + "These will not necessarily be identical to the modes used when\n" + "the port was opened, since modes such as \"append\" which are\n" + "used only during port creation are not retained.") +#define FUNC_NAME s_scm_port_mode +{ + char modes[4]; + modes[0] = '\0'; + + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPPORT (1, port); + if (SCM_CELL_WORD_0 (port) & SCM_RDNG) { + if (SCM_CELL_WORD_0 (port) & SCM_WRTNG) + strcpy (modes, "r+"); + else + strcpy (modes, "r"); + } + else if (SCM_CELL_WORD_0 (port) & SCM_WRTNG) + strcpy (modes, "w"); + if (SCM_CELL_WORD_0 (port) & SCM_BUF0) + strcat (modes, "0"); + + return scm_from_latin1_string (modes); +} +#undef FUNC_NAME + + + +/* The port table --- a weak set of all ports. + + We need a global registry of ports to flush them all at exit, and to + get all the ports matching a file descriptor. */ +SCM scm_i_port_weak_set; + + + + +/* Port finalization. */ + +static SCM close_port (SCM, int); + +static SCM +do_close (void *data) +{ + return close_port (SCM_PACK_POINTER (data), 0); +} + +/* Finalize the object (a port) pointed to by PTR. */ +static void +finalize_port (void *ptr, void *data) +{ + SCM port = SCM_PACK_POINTER (ptr); + + if (!SCM_PORTP (port)) + abort (); + + if (SCM_OPENP (port)) + { + SCM_SET_PORT_FINALIZING (port); + scm_internal_catch (SCM_BOOL_T, do_close, ptr, + scm_handle_by_message_noexit, NULL); + scm_gc_ports_collected++; + } +} + + + + +/* Default buffer size. Used if the port type won't supply a value. */ +static const size_t default_buffer_size = 1024; + +static void +initialize_port_buffers (SCM port) +{ + scm_t_port *pt = SCM_PORT (port); + scm_t_port_type *ptob = SCM_PORT_TYPE (port); + size_t read_buf_size, write_buf_size; + + if (SCM_CELL_WORD_0 (port) & SCM_BUF0) + read_buf_size = write_buf_size = 1; + else + { + read_buf_size = write_buf_size = default_buffer_size; + if (ptob->get_natural_buffer_sizes) + ptob->get_natural_buffer_sizes (port, &read_buf_size, &write_buf_size); + if (read_buf_size == 0) + read_buf_size = 1; + if (write_buf_size == 0) + write_buf_size = 1; + } + + if (!SCM_INPUT_PORT_P (port)) + read_buf_size = 1; + if (!SCM_OUTPUT_PORT_P (port)) + write_buf_size = 1; + + pt->read_buffering = read_buf_size; + pt->read_buf = make_port_buffer (port, read_buf_size); + pt->write_buf = make_port_buffer (port, write_buf_size); + pt->write_buf_aux = SCM_BOOL_F; +} + +SCM +scm_c_make_port_with_encoding (scm_t_port_type *ptob, unsigned long mode_bits, + SCM encoding, SCM conversion_strategy, + scm_t_bits stream) +{ + SCM ret; + scm_t_port *pt; + + pt = scm_gc_typed_calloc (scm_t_port); + + ret = scm_words (scm_tc7_port | mode_bits | SCM_OPN, 4); + SCM_SET_CELL_WORD_1 (ret, stream); + SCM_SET_CELL_WORD_2 (ret, (scm_t_bits) pt); + SCM_SET_CELL_WORD_3 (ret, (scm_t_bits) ptob); + + pt->encoding = encoding; + pt->conversion_strategy = conversion_strategy; + pt->file_name = SCM_BOOL_F; + pt->position = scm_cons (SCM_INUM0, SCM_INUM0); + + pt->refcount = 1; + + pt->at_stream_start_for_bom_read = 1; + pt->at_stream_start_for_bom_write = 1; + + pt->precise_encoding = SCM_BOOL_F; + pt->input_cd = (iconv_t) -1; + pt->output_cd = (iconv_t) -1; + + pt->alist = SCM_EOL; + + if (SCM_PORT_TYPE (ret)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC) + { + scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL); + scm_weak_set_add_x (scm_i_port_weak_set, ret); + } + + initialize_port_buffers (ret); + + pt->rw_random = ptob->random_access_p (ret); + + return ret; +} + +SCM +scm_c_make_port (scm_t_port_type *ptob, + unsigned long mode_bits, scm_t_bits stream) +{ + return scm_c_make_port_with_encoding (ptob, mode_bits, + scm_i_default_port_encoding (), + scm_i_default_port_conversion_strategy (), + stream); +} + + + +/* Predicates. */ + +SCM_DEFINE (scm_port_p, "port?", 1, 0, 0, + (SCM x), + "Return a boolean indicating whether @var{x} is a port.\n" + "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n" + "@var{x}))}.") +#define FUNC_NAME s_scm_port_p +{ + return scm_from_bool (SCM_PORTP (x)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0, + (SCM x), + "Return @code{#t} if @var{x} is an input port, otherwise return\n" + "@code{#f}. Any object satisfying this predicate also satisfies\n" + "@code{port?}.") +#define FUNC_NAME s_scm_input_port_p +{ + return scm_from_bool (SCM_INPUT_PORT_P (x)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0, + (SCM x), + "Return @code{#t} if @var{x} is an output port, otherwise return\n" + "@code{#f}. Any object satisfying this predicate also satisfies\n" + "@code{port?}.") +#define FUNC_NAME s_scm_output_port_p +{ + x = SCM_COERCE_OUTPORT (x); + return scm_from_bool (SCM_OUTPUT_PORT_P (x)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0, + (SCM port), + "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n" + "open.") +#define FUNC_NAME s_scm_port_closed_p +{ + SCM_VALIDATE_PORT (1, port); + return scm_from_bool (!SCM_OPPORTP (port)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0, + (SCM x), + "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n" + "return @code{#f}.") +#define FUNC_NAME s_scm_eof_object_p +{ + return scm_from_bool (SCM_EOF_OBJECT_P (x)); +} +#undef FUNC_NAME + + + + +/* Closing ports. */ + +/* Close PORT. If EXPLICIT is true, then we are explicitly closing PORT + with 'close-port'; otherwise PORT is just being GC'd. */ +static SCM +close_port (SCM port, int explicit) +{ + if (SCM_CLOSEDP (port)) + return SCM_BOOL_F; + + /* May throw an exception. */ + if (SCM_OUTPUT_PORT_P (port)) + scm_flush (port); + + if (explicit && SCM_FPORTP (port)) + /* We're closing PORT explicitly so clear its revealed count so that + it really gets closed. */ + SCM_FSTREAM (port)->revealed = 0; + + SCM_CLR_PORT_OPEN_FLAG (port); + + if (SCM_PORT_TYPE (port)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC) + scm_weak_set_remove_x (scm_i_port_weak_set, port); + + release_port (port); + + return SCM_BOOL_T; +} + +SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, + (SCM port), + "Close the specified port object. Return @code{#t} if it\n" + "successfully closes a port or @code{#f} if it was already\n" + "closed. An exception may be raised if an error occurs, for\n" + "example when flushing buffered output. See also @ref{Ports and\n" + "File Descriptors, close}, for a procedure which can close file\n" + "descriptors.") +#define FUNC_NAME s_scm_close_port +{ + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_PORT (1, port); + + return close_port (port, 1); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_close_input_port, "close-input-port", 1, 0, 0, + (SCM port), + "Close the specified input port object. The routine has no effect if\n" + "the file has already been closed. An exception may be raised if an\n" + "error occurs. The value returned is unspecified.\n\n" + "See also @ref{Ports and File Descriptors, close}, for a procedure\n" + "which can close file descriptors.") +#define FUNC_NAME s_scm_close_input_port +{ + SCM_VALIDATE_INPUT_PORT (1, port); + scm_close_port (port); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_close_output_port, "close-output-port", 1, 0, 0, + (SCM port), + "Close the specified output port object. The routine has no effect if\n" + "the file has already been closed. An exception may be raised if an\n" + "error occurs. The value returned is unspecified.\n\n" + "See also @ref{Ports and File Descriptors, close}, for a procedure\n" + "which can close file descriptors.") +#define FUNC_NAME s_scm_close_output_port +{ + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OUTPUT_PORT (1, port); + scm_close_port (port); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + + +/* Encoding characters to byte streams, and decoding byte streams to + characters. */ + +/* Port encodings are case-insensitive ASCII strings. */ +static char +ascii_toupper (char c) +{ + return (c < 'a' || c > 'z') ? c : ('A' + (c - 'a')); +} + +/* It is only necessary to use this function on encodings that come from + the user and have not been canonicalized yet. Encodings that are set + on ports or in the default encoding fluid are in upper-case, and can + be compared with strcmp. */ +static int +encoding_matches (const char *enc, SCM upper_symbol) +{ + const char *upper = scm_i_symbol_chars (upper_symbol); + + if (!enc) + enc = "ISO-8859-1"; + + while (*enc) + if (ascii_toupper (*enc++) != *upper++) + return 0; + + return !*upper; +} + +static SCM +canonicalize_encoding (const char *enc) +{ + char *ret; + int i; + + if (!enc || encoding_matches (enc, sym_ISO_8859_1)) + return sym_ISO_8859_1; + if (encoding_matches (enc, sym_UTF_8)) + return sym_UTF_8; + + ret = scm_gc_strdup (enc, "port"); + + for (i = 0; ret[i]; i++) + { + if (ret[i] > 127) + /* Restrict to ASCII. */ + scm_misc_error (NULL, "invalid character encoding ~s", + scm_list_1 (scm_from_latin1_string (enc))); + else + ret[i] = ascii_toupper (ret[i]); + } + + return scm_from_latin1_symbol (ret); +} + +/* A fluid specifying the default encoding for newly created ports. If it is + a string, that is the encoding. If it is #f, it is in the "native" + (Latin-1) encoding. */ +static SCM default_port_encoding_var; + +/* Use ENCODING as the default encoding for future ports. */ +void +scm_i_set_default_port_encoding (const char *encoding) +{ + if (encoding_matches (encoding, sym_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_symbol_to_string (canonicalize_encoding (encoding))); +} + +/* Return the name of the default encoding for newly created ports. */ +SCM +scm_i_default_port_encoding (void) +{ + SCM encoding; + + encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var)); + if (!scm_is_string (encoding)) + return sym_ISO_8859_1; + else + return canonicalize_encoding (scm_i_string_chars (encoding)); +} + +/* A fluid specifying the default conversion handler for newly created + ports. Its value should be one of the symbols below. */ +static SCM default_conversion_strategy_var; + +/* Return the default failed encoding conversion policy for new created + ports. */ +SCM +scm_i_default_port_conversion_strategy (void) +{ + SCM value; + + value = scm_fluid_ref (SCM_VARIABLE_REF (default_conversion_strategy_var)); + + if (scm_is_eq (sym_substitute, value) || scm_is_eq (sym_escape, value)) + return value; + + /* Default to 'error also when the fluid's value is not one of the + valid symbols. */ + return sym_error; +} + +/* Use HANDLER as the default conversion strategy for future ports. */ +void +scm_i_set_default_port_conversion_strategy (SCM sym) +{ + if (!scm_is_eq (sym, sym_error) + && !scm_is_eq (sym, sym_substitute) + && !scm_is_eq (sym, sym_escape)) + /* Internal error. */ + abort (); + + scm_fluid_set_x (SCM_VARIABLE_REF (default_conversion_strategy_var), sym); +} + +static const unsigned char scm_utf8_bom[3] = {0xEF, 0xBB, 0xBF}; +static const unsigned char scm_utf16be_bom[2] = {0xFE, 0xFF}; +static const unsigned char scm_utf16le_bom[2] = {0xFF, 0xFE}; +static const unsigned char scm_utf32be_bom[4] = {0x00, 0x00, 0xFE, 0xFF}; +static const unsigned char scm_utf32le_bom[4] = {0xFF, 0xFE, 0x00, 0x00}; + +/* Called with the iconv lock. Will release the lock before throwing + any error. */ +static void +prepare_iconv_descriptors (SCM port, SCM precise_encoding) +{ + scm_t_port *pt = SCM_PORT (port); + iconv_t input_cd, output_cd; + const char *encoding; + size_t i; + + /* If the specified encoding is UTF-16 or UTF-32, then default to + big-endian byte order. This fallback isn't necessary if you read + on the port before writing to it, as the read will sniff the BOM if + any and specialize the encoding; see the manual. */ + if (scm_is_eq (precise_encoding, sym_UTF_16)) + precise_encoding = sym_UTF_16BE; + else if (scm_is_eq (precise_encoding, sym_UTF_32)) + precise_encoding = sym_UTF_32BE; + + if (scm_is_eq (pt->precise_encoding, precise_encoding)) + return; + + input_cd = output_cd = (iconv_t) -1; + + if (!scm_is_symbol (precise_encoding)) + goto invalid_encoding; + + encoding = scm_i_symbol_chars (precise_encoding); + for (i = 0; encoding[i]; i++) + if (encoding[i] > 127) + goto invalid_encoding; + + /* Open a iconv conversion descriptors between ENCODING and 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, + for more details). */ + + if (SCM_INPUT_PORT_P (port)) + { + input_cd = iconv_open ("UTF-8", encoding); + if (input_cd == (iconv_t) -1) + goto invalid_encoding; + } + + if (SCM_OUTPUT_PORT_P (port)) + { + 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); + + pt->precise_encoding = precise_encoding; + pt->input_cd = input_cd; + pt->output_cd = output_cd; + + /* Make sure this port has a finalizer. */ + scm_i_set_finalizer (SCM2PTR (port), finalize_port, NULL); + + return; + + invalid_encoding: + scm_i_pthread_mutex_unlock (&iconv_lock); + scm_misc_error ("open_iconv_descriptors", + "invalid or unknown character encoding ~s", + scm_list_1 (precise_encoding)); +} + +SCM_INTERNAL SCM scm_specialize_port_encoding_x (SCM port, SCM encoding); +SCM_DEFINE (scm_specialize_port_encoding_x, + "specialize-port-encoding!", 2, 0, 0, + (SCM port, SCM encoding), + "") +#define FUNC_NAME s_scm_specialize_port_encoding_x +{ + SCM_VALIDATE_PORT (1, port); + SCM_VALIDATE_SYMBOL (2, encoding); + + if (scm_is_eq (SCM_PORT (port)->encoding, sym_UTF_16)) + { + if (!scm_is_eq (encoding, sym_UTF_16LE) + && !scm_is_eq (encoding, sym_UTF_16BE)) + SCM_OUT_OF_RANGE (2, encoding); + } + else if (scm_is_eq (SCM_PORT (port)->encoding, sym_UTF_32)) + { + if (!scm_is_eq (encoding, sym_UTF_32LE) + && !scm_is_eq (encoding, sym_UTF_32BE)) + SCM_OUT_OF_RANGE (2, encoding); + } + else + SCM_OUT_OF_RANGE (2, encoding); + + scm_i_pthread_mutex_lock (&iconv_lock); + prepare_iconv_descriptors (port, encoding); + scm_i_pthread_mutex_unlock (&iconv_lock); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +/* Acquire the iconv lock and fill in *INPUT_CD and/or *OUTPUT_CD. */ +void +scm_port_acquire_iconv_descriptors (SCM port, iconv_t *input_cd, + iconv_t *output_cd) +{ + scm_t_port *pt = SCM_PORT (port); + + scm_i_pthread_mutex_lock (&iconv_lock); + if (scm_is_false (pt->precise_encoding)) + prepare_iconv_descriptors (port, pt->encoding); + if (input_cd) + *input_cd = pt->input_cd; + if (output_cd) + *output_cd = pt->output_cd; +} + +void +scm_port_release_iconv_descriptors (SCM port) +{ + scm_i_pthread_mutex_unlock (&iconv_lock); +} + +/* 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_PORT (port); + + /* In order to handle cases where the encoding changes mid-stream + (e.g. within an HTTP stream, or within a file that is composed of + segments with different encodings), we consider this to be "stream + start" for purposes of BOM handling, regardless of our actual file + position. */ + pt->at_stream_start_for_bom_read = 1; + pt->at_stream_start_for_bom_write = 1; + pt->encoding = canonicalize_encoding (encoding); + + scm_i_pthread_mutex_lock (&iconv_lock); + if (pt->input_cd != (iconv_t) -1) + iconv_close (pt->input_cd); + if (pt->output_cd != (iconv_t) -1) + iconv_close (pt->output_cd); + pt->precise_encoding = SCM_BOOL_F; + pt->input_cd = pt->output_cd = (iconv_t) -1; + scm_i_pthread_mutex_unlock (&iconv_lock); +} + +SCM_DEFINE (scm_sys_port_encoding, "%port-encoding", 1, 0, 0, + (SCM port), + "Returns, as a symbol, the character encoding that @var{port}\n" + "uses to interpret its input and output.\n") +#define FUNC_NAME s_scm_sys_port_encoding +{ + SCM_VALIDATE_OPPORT (1, port); + + return SCM_PORT (port)->encoding; +} +#undef FUNC_NAME + +SCM +scm_port_encoding (SCM port) +{ + return scm_symbol_to_string (scm_sys_port_encoding (port)); +} + +SCM_DEFINE (scm_sys_set_port_encoding_x, "%set-port-encoding!", 2, 0, 0, + (SCM port, SCM enc), + "Sets the character encoding that will be used to interpret all\n" + "port I/O. New ports are created with the encoding\n" + "appropriate for the current locale if @code{setlocale} has \n" + "been called or ISO-8859-1 otherwise\n" + "and this procedure can be used to modify that encoding.\n") +#define FUNC_NAME s_scm_sys_set_port_encoding_x +{ + SCM_VALIDATE_OPPORT (1, port); + SCM_VALIDATE_SYMBOL (2, enc); + + scm_i_set_port_encoding_x (port, scm_i_symbol_chars (enc)); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM +scm_set_port_encoding_x (SCM port, SCM enc) +{ + return scm_sys_set_port_encoding_x (port, scm_string_to_symbol (enc)); +} + +scm_t_string_failed_conversion_handler +scm_i_string_failed_conversion_handler (SCM conversion_strategy) +{ + if (scm_is_eq (conversion_strategy, sym_substitute)) + return SCM_FAILED_CONVERSION_QUESTION_MARK; + if (scm_is_eq (conversion_strategy, sym_escape)) + return SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE; + + /* Default to error. */ + return SCM_FAILED_CONVERSION_ERROR; +} + +SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy", + 1, 0, 0, (SCM port), + "Returns the behavior of the port when handling a character that\n" + "is not representable in the port's current encoding.\n" + "It returns the symbol @code{error} if unrepresentable characters\n" + "should cause exceptions, @code{substitute} if the port should\n" + "try to replace unrepresentable characters with question marks or\n" + "approximate characters, or @code{escape} if unrepresentable\n" + "characters should be converted to string escapes.\n" + "\n" + "If @var{port} is @code{#f}, then the current default behavior\n" + "will be returned. New ports will have this default behavior\n" + "when they are created.\n") +#define FUNC_NAME s_scm_port_conversion_strategy +{ + if (scm_is_false (port)) + return scm_i_default_port_conversion_strategy (); + + SCM_VALIDATE_OPPORT (1, port); + return SCM_PORT (port)->conversion_strategy; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!", + 2, 0, 0, + (SCM port, SCM sym), + "Sets the behavior of the interpreter when outputting a character\n" + "that is not representable in the port's current encoding.\n" + "@var{sym} can be either @code{'error}, @code{'substitute}, or\n" + "@code{'escape}. If it is @code{'error}, an error will be thrown\n" + "when an unconvertible character is encountered. If it is\n" + "@code{'substitute}, then unconvertible characters will \n" + "be replaced with approximate characters, or with question marks\n" + "if no approximately correct character is available.\n" + "If it is @code{'escape},\n" + "it will appear as a hex escape when output.\n" + "\n" + "If @var{port} is an open port, the conversion error behavior\n" + "is set for that port. If it is @code{#f}, it is set as the\n" + "default behavior for any future ports that get created in\n" + "this thread.\n") +#define FUNC_NAME s_scm_set_port_conversion_strategy_x +{ + if (!scm_is_eq (sym, sym_error) + && !scm_is_eq (sym, sym_substitute) + && !scm_is_eq (sym, sym_escape)) + SCM_MISC_ERROR ("unknown conversion strategy ~s", scm_list_1 (sym)); + + if (scm_is_false (port)) + scm_i_set_default_port_conversion_strategy (sym); + else + { + SCM_VALIDATE_OPPORT (1, port); + SCM_PORT (port)->conversion_strategy = sym; + } + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + + +/* Non-blocking I/O. */ + +static int +port_read_wait_fd (SCM port) +{ + scm_t_port_type *ptob = SCM_PORT_TYPE (port); + return ptob->read_wait_fd (port); +} + +static int +port_write_wait_fd (SCM port) +{ + scm_t_port_type *ptob = SCM_PORT_TYPE (port); + return ptob->write_wait_fd (port); +} + +SCM_INTERNAL SCM scm_port_read_wait_fd (SCM); +SCM_DEFINE (scm_port_read_wait_fd, "port-read-wait-fd", 1, 0, 0, + (SCM port), "") +#define FUNC_NAME s_scm_port_read_wait_fd +{ + int fd; + + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPINPORT (1, port); + + fd = port_read_wait_fd (port); + return fd < 0 ? SCM_BOOL_F : scm_from_int (fd); +} +#undef FUNC_NAME + +SCM_INTERNAL SCM scm_port_write_wait_fd (SCM); +SCM_DEFINE (scm_port_write_wait_fd, "port-write-wait-fd", 1, 0, 0, + (SCM port), "") +#define FUNC_NAME s_scm_port_write_wait_fd +{ + int fd; + + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPOUTPORT (1, port); + + fd = port_write_wait_fd (port); + return fd < 0 ? SCM_BOOL_F : scm_from_int (fd); +} +#undef FUNC_NAME + +/* Call while having acquired the port. */ +static int +port_poll (SCM port, short events, int timeout) +#define FUNC_NAME "port-poll" +{ + struct pollfd pollfd[2]; + int nfds = 0, rv = 0; + + if (events & POLLIN) + { + pollfd[nfds].fd = port_read_wait_fd (port); + pollfd[nfds].events = events & (POLLIN | POLLPRI); + pollfd[nfds].revents = 0; + nfds++; + } + if (events & POLLOUT) + { + pollfd[nfds].fd = port_write_wait_fd (port); + pollfd[nfds].events = events & (POLLOUT | POLLPRI); + pollfd[nfds].revents = 0; + nfds++; + } + + if (nfds == 2 && pollfd[0].fd == pollfd[1].fd) + { + pollfd[0].events |= pollfd[1].events; + nfds--; + } + + SCM_SYSCALL (rv = poll (pollfd, nfds, timeout)); + if (rv < 0) + SCM_SYSERROR; + + return rv; +} +#undef FUNC_NAME + +SCM_INTERNAL SCM scm_port_poll (SCM, SCM, SCM); +SCM_DEFINE (scm_port_poll, "port-poll", 2, 1, 0, + (SCM port, SCM events, SCM timeout), + "") +#define FUNC_NAME s_scm_port_poll +{ + short c_events = 0; + int c_timeout; + SCM ret; + + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_PORT (1, port); + SCM_VALIDATE_STRING (2, events); + c_timeout = SCM_UNBNDP (timeout) ? -1 : SCM_NUM2INT (3, timeout); + + if (scm_i_string_contains_char (events, 'r')) + c_events |= POLLIN; + if (scm_i_string_contains_char (events, '!')) + c_events |= POLLPRI; + if (scm_i_string_contains_char (events, 'w')) + c_events |= POLLIN; + + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + ret = scm_from_int (port_poll (port, c_events, c_timeout)); + scm_dynwind_end (); + + return ret; +} +#undef FUNC_NAME + + + + +/* Input. */ + +static int +get_byte_or_eof (SCM port) +{ + SCM buf = SCM_PORT (port)->read_buf; + SCM buf_bv, buf_cur, buf_end; + size_t cur, avail; + + buf_bv = scm_port_buffer_bytevector (buf); + buf_cur = scm_port_buffer_cur (buf); + buf_end = scm_port_buffer_end (buf); + cur = SCM_I_INUM (buf_cur); + + if (SCM_LIKELY (SCM_I_INUMP (buf_cur)) + && SCM_LIKELY (SCM_I_INUMP (buf_end)) + && SCM_LIKELY (cur < SCM_I_INUM (buf_end)) + && SCM_LIKELY (cur < SCM_BYTEVECTOR_LENGTH (buf_bv))) + { + uint8_t ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; + scm_port_buffer_set_cur (buf, SCM_I_MAKINUM (cur + 1)); + return ret; + } + + buf = scm_fill_input (port, 0, &cur, &avail); + buf_bv = scm_port_buffer_bytevector (buf); + if (avail > 0) + { + uint8_t ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; + scm_port_buffer_set_cur (buf, SCM_I_MAKINUM (cur + 1)); + return ret; + } + + /* The next peek or get should cause the read() function to be called + to see if we still have EOF. */ + scm_port_buffer_set_has_eof_p (buf, SCM_BOOL_F); + return EOF; +} + +/* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */ +static int +peek_byte_or_eof (SCM port, SCM *buf_out, size_t *cur_out) +{ + SCM buf = SCM_PORT (port)->read_buf; + SCM buf_bv, buf_cur, buf_end; + size_t cur, avail; + + buf_bv = scm_port_buffer_bytevector (buf); + buf_cur = scm_port_buffer_cur (buf); + buf_end = scm_port_buffer_end (buf); + cur = scm_to_size_t (buf_cur); + if (SCM_LIKELY (SCM_I_INUMP (buf_cur)) + && SCM_LIKELY (SCM_I_INUMP (buf_end)) + && SCM_LIKELY (cur < SCM_I_INUM (buf_end)) + && SCM_LIKELY (cur < SCM_BYTEVECTOR_LENGTH (buf_bv))) + { + uint8_t ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; + *buf_out = buf; + *cur_out = cur; + return ret; + } + + buf = scm_fill_input (port, 0, &cur, &avail); + buf_bv = scm_port_buffer_bytevector (buf); + *buf_out = buf; + *cur_out = cur; + if (avail > 0) + { + uint8_t ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; + return ret; + } + + return EOF; +} + +int +scm_get_byte_or_eof (SCM port) +{ + return get_byte_or_eof (port); +} + +int +scm_peek_byte_or_eof (SCM port) +{ + SCM buf; + size_t cur; + return peek_byte_or_eof (port, &buf, &cur); +} + +static size_t +scm_i_read_bytes (SCM port, SCM dst, size_t start, size_t count) +{ + size_t filled; + scm_t_port_type *ptob = SCM_PORT_TYPE (port); + + assert (count <= SCM_BYTEVECTOR_LENGTH (dst)); + assert (start + count <= SCM_BYTEVECTOR_LENGTH (dst)); + + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + + retry: + filled = ptob->c_read (port, dst, start, count); + + if (filled == (size_t) -1) + { + port_poll (port, POLLIN, -1); + goto retry; + } + + scm_dynwind_end (); + + assert (filled <= count); + + return filled; +} + +/* In text mode, we will slurp a BOM from the beginning of a UTF-8, + UTF-16, or UTF-32 stream, and write one at the beginning of a UTF-16 + or UTF-32 stream. In binary mode, we won't. The mode depends on the + caller. */ +enum bom_io_mode { BOM_IO_TEXT, BOM_IO_BINARY }; +static size_t port_clear_stream_start_for_bom_read (SCM, enum bom_io_mode); + +/* Used by an application to read arbitrary number of bytes from an SCM + port. Same semantics as libc read, except that scm_c_read_bytes only + returns less than SIZE bytes if at end-of-file. + + Warning: Doesn't update port line and column counts! */ +size_t +scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) +#define FUNC_NAME "scm_c_read_bytes" +{ + size_t to_read = count; + scm_t_port *pt; + SCM read_buf; + uint8_t *dst_ptr = (uint8_t *) SCM_BYTEVECTOR_CONTENTS (dst) + start; + + SCM_VALIDATE_OPINPORT (1, port); + + pt = SCM_PORT (port); + read_buf = pt->read_buf; + + if (pt->rw_random) + scm_flush (port); + + port_clear_stream_start_for_bom_read (port, BOM_IO_BINARY); + + /* Take bytes first from the port's read buffer. */ + { + size_t cur, avail, did_read; + avail = scm_port_buffer_can_take (read_buf, &cur); + did_read = scm_port_buffer_take (read_buf, dst_ptr, to_read, cur, avail); + dst_ptr += did_read; + to_read -= did_read; + } + + while (to_read) + { + size_t did_read; + + /* If the read is smaller than the buffering on the read side of + this port, then go through the buffer. Otherwise fill our + buffer directly. */ + if (to_read < pt->read_buffering) + { + size_t cur, avail; + + read_buf = scm_fill_input (port, 0, &cur, &avail); + did_read = scm_port_buffer_take (read_buf, dst_ptr, to_read, + cur, avail); + dst_ptr += did_read; + to_read -= did_read; + if (did_read == 0) + { + /* Consider that we've read off this EOF. */ + scm_port_buffer_set_has_eof_p (read_buf, SCM_BOOL_F); + break; + } + } + else + { + did_read = scm_i_read_bytes (port, dst, + start + count - to_read, + to_read); + to_read -= did_read; + dst_ptr += did_read; + if (did_read == 0) + break; + } + } + + return count - to_read; +} +#undef FUNC_NAME + +/* Like scm_c_read_bytes, but always proxies reads through the port's + read buffer. Used by an application when it wants to read into a + memory chunk that's not owned by Guile's GC. */ +size_t +scm_c_read (SCM port, void *buffer, size_t size) +#define FUNC_NAME "scm_c_read" +{ + size_t copied = 0; + scm_t_port *pt; + SCM read_buf; + uint8_t *dst = buffer; + + SCM_VALIDATE_OPINPORT (1, port); + + pt = SCM_PORT (port); + read_buf = pt->read_buf; + + if (pt->rw_random) + scm_flush (port); + + while (copied < size) + { + size_t cur, avail, count; + read_buf = scm_fill_input (port, 0, &cur, &avail); + count = scm_port_buffer_take (read_buf, dst + copied, size - copied, + cur, avail); + copied += count; + if (count == 0) + { + /* Consider that we've read off this EOF. */ + scm_port_buffer_set_has_eof_p (read_buf, SCM_BOOL_F); + break; + } + } + + return copied; +} +#undef FUNC_NAME + +/* Update the line and column number of PORT after consumption of C. */ +static inline void +update_port_position (SCM position, scm_t_wchar c) +{ + int column = scm_to_int (scm_port_position_column (position)); + + switch (c) + { + case '\a': + case EOF: + break; + case '\b': + if (column > 0) + scm_port_position_set_column (position, scm_from_int (column - 1)); + break; + case '\n': + { + long line = scm_to_long (scm_port_position_line (position)); + scm_port_position_set_line (position, scm_from_long (line + 1)); + scm_port_position_set_column (position, SCM_INUM0); + } + break; + case '\r': + scm_port_position_set_column (position, SCM_INUM0); + break; + case '\t': + scm_port_position_set_column (position, + scm_from_int (column + 8 - column % 8)); + break; + default: + scm_port_position_set_column (position, scm_from_int (column + 1)); + break; + } +} + +/* Convert the SIZE-byte UTF-8 sequence in UTF8_BUF to a codepoint. + UTF8_BUF is assumed to contain a valid UTF-8 sequence. */ +static scm_t_wchar +utf8_to_codepoint (const uint8_t *utf8_buf, size_t size) +{ + scm_t_wchar codepoint; + + if (utf8_buf[0] <= 0x7f) + { + assert (size >= 1); + codepoint = utf8_buf[0]; + } + else if ((utf8_buf[0] & 0xe0) == 0xc0) + { + assert (size >= 2); + codepoint = ((scm_t_wchar) utf8_buf[0] & 0x1f) << 6UL + | (utf8_buf[1] & 0x3f); + } + else if ((utf8_buf[0] & 0xf0) == 0xe0) + { + assert (size >= 3); + codepoint = ((scm_t_wchar) utf8_buf[0] & 0x0f) << 12UL + | ((scm_t_wchar) utf8_buf[1] & 0x3f) << 6UL + | (utf8_buf[2] & 0x3f); + } + else + { + assert (size >= 4); + codepoint = ((scm_t_wchar) utf8_buf[0] & 0x07) << 18UL + | ((scm_t_wchar) utf8_buf[1] & 0x3f) << 12UL + | ((scm_t_wchar) utf8_buf[2] & 0x3f) << 6UL + | (utf8_buf[3] & 0x3f); + } + + return codepoint; +} + +/* Peek a UTF-8 sequence from PORT. On success, return the codepoint + that was read, and set *LEN to the length in bytes. If there was a + decoding error and the port conversion strategy was `substitute', + then return #\? and set *LEN to the length of the shortest prefix + that cannot begin a valid UTF-8 sequence. Otherwise signal an + error. */ +static scm_t_wchar +peek_utf8_codepoint (SCM port, SCM *buf_out, size_t *cur_out, size_t *len_out) +{ +#define DECODING_ERROR(bytes) \ + do { *buf_out = buf; *cur_out = cur; *len_out = bytes; goto decoding_error; } while (0) +#define RETURN(bytes, codepoint) \ + do { *buf_out = buf; *cur_out = cur; *len_out = bytes; return codepoint; } while (0) + + SCM buf; + size_t cur, avail; + int first_byte; + const uint8_t *ptr; + + first_byte = peek_byte_or_eof (port, &buf, &cur); + if (first_byte == EOF) + RETURN (0, EOF); + else if (first_byte < 0x80) + RETURN (1, first_byte); + else if (first_byte >= 0xc2 && first_byte <= 0xdf) + { + buf = scm_fill_input (port, 2, &cur, &avail); + ptr = scm_port_buffer_take_pointer (buf, cur); + + if (avail < 2 || (ptr[1] & 0xc0) != 0x80) + DECODING_ERROR (1); + + RETURN (2, (first_byte & 0x1f) << 6UL | (ptr[1] & 0x3f)); + } + else if ((first_byte & 0xf0) == 0xe0) + { + buf = scm_fill_input (port, 3, &cur, &avail); + ptr = scm_port_buffer_take_pointer (buf, cur); + + if (avail < 2 || (ptr[1] & 0xc0) != 0x80 + || (ptr[0] == 0xe0 && ptr[1] < 0xa0) + || (ptr[0] == 0xed && ptr[1] > 0x9f)) + DECODING_ERROR (1); + + if (avail < 3 || (ptr[2] & 0xc0) != 0x80) + DECODING_ERROR (2); + + RETURN (3, + ((scm_t_wchar) ptr[0] & 0x0f) << 12UL + | ((scm_t_wchar) ptr[1] & 0x3f) << 6UL + | (ptr[2] & 0x3f)); + } + else if (first_byte >= 0xf0 && first_byte <= 0xf4) + { + buf = scm_fill_input (port, 4, &cur, &avail); + ptr = scm_port_buffer_take_pointer (buf, cur); + + if (avail < 2 || (ptr[1] & 0xc0) != 0x80 + || (ptr[0] == 0xf0 && ptr[1] < 0x90) + || (ptr[0] == 0xf4 && ptr[1] > 0x8f)) + DECODING_ERROR (1); + + if (avail < 3 || (ptr[2] & 0xc0) != 0x80) + DECODING_ERROR (2); + + if (avail < 4 || (ptr[3] & 0xc0) != 0x80) + DECODING_ERROR (3); + + RETURN (4, + ((scm_t_wchar) ptr[0] & 0x07) << 18UL + | ((scm_t_wchar) ptr[1] & 0x3f) << 12UL + | ((scm_t_wchar) ptr[2] & 0x3f) << 6UL + | (ptr[3] & 0x3f)); + } + else + DECODING_ERROR (1); + + decoding_error: + if (scm_is_eq (SCM_PORT (port)->conversion_strategy, sym_substitute)) + /* *len already set. */ + return UNICODE_REPLACEMENT_CHARACTER; + + scm_decoding_error ("peek-char", EILSEQ, "input decoding error", port); + /* Not reached. */ + return 0; +#undef DECODING_ERROR +#undef RETURN +} + +/* Peek an ISO-8859-1 codepoint (a byte) from PORT. On success, return + the codepoint, and set *LEN to 1. Otherwise on EOF set *LEN to 0. */ +static scm_t_wchar +peek_latin1_codepoint (SCM port, SCM *buf, size_t *cur, size_t *len) +{ + scm_t_wchar ret = peek_byte_or_eof (port, buf, cur); + + *len = ret == EOF ? 0 : 1; + + return ret; +} + +SCM_INTERNAL SCM scm_port_decode_char (SCM, SCM, SCM, SCM); +SCM_DEFINE (scm_port_decode_char, "port-decode-char", 4, 0, 0, + (SCM port, SCM bv, SCM start, SCM count), + "") +#define FUNC_NAME s_scm_port_decode_char +{ + char *input, *output; + uint8_t utf8_buf[UTF8_BUFFER_SIZE]; + iconv_t input_cd; + size_t c_start, c_count; + size_t input_left, output_left, done; + + SCM_VALIDATE_OPINPORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, bv); + c_start = scm_to_size_t (start); + c_count = scm_to_size_t (count); + SCM_ASSERT_RANGE (3, start, c_start <= SCM_BYTEVECTOR_LENGTH (bv)); + SCM_ASSERT_RANGE (4, count, c_count <= SCM_BYTEVECTOR_LENGTH (bv) - c_start); + + input = (char *) SCM_BYTEVECTOR_CONTENTS (bv) + c_start; + input_left = c_count; + output = (char *) utf8_buf; + output_left = sizeof (utf8_buf); + + /* FIXME: locking! */ + scm_port_acquire_iconv_descriptors (port, &input_cd, NULL); + done = iconv (input_cd, &input, &input_left, &output, &output_left); + scm_port_release_iconv_descriptors (port); + + if (done == (size_t) -1) + { + int err = errno; + if (err == EINVAL) + /* The input byte sequence did not form a complete + character. Read another byte and try again. */ + return SCM_BOOL_F; + else if (scm_is_eq (SCM_PORT (port)->conversion_strategy, + sym_substitute)) + return SCM_MAKE_CHAR (UNICODE_REPLACEMENT_CHARACTER); + else + scm_decoding_error ("decode-char", err, "input decoding error", port); + } + + { + size_t output_size = sizeof (utf8_buf) - output_left; + if (output_size == 0) + /* iconv consumed some bytes without producing any output. + Most likely this means that a Unicode byte-order mark + (BOM) was consumed. In any case, keep going until we get + output. */ + return SCM_BOOL_F; + + return SCM_MAKE_CHAR (utf8_to_codepoint (utf8_buf, output_size)); + } +} +#undef FUNC_NAME + +/* Peek a codepoint from PORT, decoding it through iconv. On success, + return the codepoint and set *LEN to the length in bytes. If there + was a decoding error and the port conversion strategy was + `substitute', then return #\? and set *LEN to the length of the + shortest prefix that cannot begin a valid UTF-8 sequence. Otherwise + signal an error. */ +static scm_t_wchar +peek_iconv_codepoint (SCM port, SCM *buf, size_t *cur, size_t *len) +{ + size_t input_size = 0; + SCM maybe_char = SCM_BOOL_F; + + while (scm_is_false (maybe_char)) + { + size_t avail; + *buf = scm_fill_input (port, input_size + 1, cur, &avail); + + if (avail <= input_size) + { + *len = input_size; + if (input_size == 0) + /* Normal EOF. */ + { + /* Make sure iconv descriptors have been opened even if + there were no bytes, to be sure that a decoding error + is signalled if the encoding itself was invalid. */ + scm_port_acquire_iconv_descriptors (port, NULL, NULL); + scm_port_release_iconv_descriptors (port); + return EOF; + } + + /* EOF found in the middle of a multibyte character. */ + if (scm_is_eq (SCM_PORT (port)->conversion_strategy, + sym_substitute)) + return UNICODE_REPLACEMENT_CHARACTER; + + scm_decoding_error ("peek-char", EILSEQ, + "input decoding error", port); + /* Not reached. */ + return 0; + } + + input_size++; + maybe_char = scm_port_decode_char (port, + scm_port_buffer_bytevector (*buf), + SCM_I_MAKINUM (*cur), + SCM_I_MAKINUM (input_size)); + } + + *len = input_size; + return SCM_CHAR (maybe_char); +} + +/* Peek a codepoint from PORT and return it in *CODEPOINT. Set *LEN to + the length in bytes of that representation. Return 0 on success and + an errno value on error. */ +static SCM_C_INLINE scm_t_wchar +peek_codepoint (SCM port, SCM *buf, size_t *cur, size_t *len) +{ + SCM encoding = SCM_PORT (port)->encoding; + + if (scm_is_eq (encoding, sym_UTF_8)) + return peek_utf8_codepoint (port, buf, cur, len); + else if (scm_is_eq (encoding, sym_ISO_8859_1)) + return peek_latin1_codepoint (port, buf, cur, len); + else + return peek_iconv_codepoint (port, buf, cur, len); +} + +/* Read a codepoint from PORT and return it. */ +scm_t_wchar +scm_getc (SCM port) +#define FUNC_NAME "scm_getc" +{ + size_t len = 0; + size_t cur; + SCM buf; + scm_t_wchar codepoint; + + codepoint = peek_codepoint (port, &buf, &cur, &len); + scm_port_buffer_did_take (buf, cur, len); + if (codepoint == EOF) + scm_i_clear_pending_eof (port); + update_port_position (SCM_PORT (port)->position, codepoint); + + return codepoint; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0, + (SCM port), + "Return the next character available from @var{port}, updating\n" + "@var{port} to point to the following character. If no more\n" + "characters are available, the end-of-file object is returned.\n" + "\n" + "When @var{port}'s data cannot be decoded according to its\n" + "character encoding, a @code{decoding-error} is raised and\n" + "@var{port} points past the erroneous byte sequence.\n") +#define FUNC_NAME s_scm_read_char +{ + scm_t_wchar c; + if (SCM_UNBNDP (port)) + port = scm_current_input_port (); + SCM_VALIDATE_OPINPORT (1, port); + c = scm_getc (port); + if (EOF == c) + return SCM_EOF_VAL; + return SCM_MAKE_CHAR (c); +} +#undef FUNC_NAME + + + + +/* Pushback. */ + + + +void +scm_unget_bytes (const uint8_t *buf, size_t len, SCM port) +#define FUNC_NAME "scm_unget_bytes" +{ + scm_t_port *pt = SCM_PORT (port); + SCM read_buf = pt->read_buf; + size_t cur; + + if (pt->rw_random) + scm_flush (port); + + cur = scm_port_buffer_can_putback (read_buf); + + if (cur < len) + { + /* The bytes don't fit directly in the read_buf. */ + size_t buffered, size; + + buffered = scm_port_buffer_can_take (read_buf, &cur); + size = scm_port_buffer_size (read_buf); + + if (len <= size - buffered) + { + /* But they would fit if we shift the not-yet-read bytes from + the read_buf right. Let's do that. */ + const uint8_t *to_shift = scm_port_buffer_take_pointer (read_buf, cur); + scm_port_buffer_reset_end (read_buf); + scm_port_buffer_putback (read_buf, to_shift, buffered, size); + } + else + { + /* Bah, have to expand the read_buf for the putback. */ + while (size < len + buffered) + size *= 2; + read_buf = scm_expand_port_read_buffer_x (port, + scm_from_size_t (size), + SCM_BOOL_T); + } + + cur = size - buffered; + } + + scm_port_buffer_putback (read_buf, buf, len, cur); +} +#undef FUNC_NAME + +void +scm_unget_byte (int c, SCM port) +{ + unsigned char byte = c; + scm_unget_bytes (&byte, 1, port); +} + +void +scm_ungetc (scm_t_wchar c, SCM port) +#define FUNC_NAME "scm_ungetc" +{ + scm_t_port *pt = SCM_PORT (port); + char *result; + char result_buf[10]; + size_t len; + + len = sizeof (result_buf); + + if (scm_is_eq (pt->encoding, sym_UTF_8)) + { + if (c < 0x80) + { + result_buf[0] = (char) c; + result = result_buf; + len = 1; + } + else + result = + (char *) u32_to_u8 ((uint32_t *) &c, 1, (uint8_t *) result_buf, &len); + } + else if (scm_is_eq (pt->encoding, sym_ISO_8859_1) && c <= 0xff) + { + result_buf[0] = (char) c; + result = result_buf; + len = 1; + } + else + { + scm_t_string_failed_conversion_handler handler = + scm_i_string_failed_conversion_handler (pt->conversion_strategy); + + result = u32_conv_to_encoding (scm_i_symbol_chars (pt->encoding), + (enum iconv_ilseq_handler) handler, + (uint32_t *) &c, 1, NULL, + result_buf, &len); + } + + if (SCM_UNLIKELY (result == NULL || len == 0)) + scm_encoding_error (FUNC_NAME, errno, + "conversion to port encoding failed", + port, SCM_MAKE_CHAR (c)); + + scm_unget_bytes ((unsigned char *) result, len, port); + + if (SCM_UNLIKELY (result != result_buf)) + free (result); + + { + long line; + int column; + + line = scm_to_long (scm_port_position_line (pt->position)); + column = scm_to_int (scm_port_position_column (pt->position)); + + if (c == '\n') + scm_port_position_set_line (pt->position, scm_from_long (line - 1)); + if (column > 0) + scm_port_position_set_column (pt->position, scm_from_int (column - 1)); + } +} +#undef FUNC_NAME + +void +scm_ungets (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 + * column numbers have to be handled... + * + * Please feel free to write an optimized version! + */ + while (n--) + scm_ungetc (s[n], port); +} + +SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, + (SCM port), + "Return the next character available from @var{port},\n" + "@emph{without} updating @var{port} to point to the following\n" + "character. If no more characters are available, the\n" + "end-of-file object is returned.\n" + "\n" + "The value returned by\n" + "a call to @code{peek-char} is the same as the value that would\n" + "have been returned by a call to @code{read-char} on the same\n" + "port. The only difference is that the very next call to\n" + "@code{read-char} or @code{peek-char} on that @var{port} will\n" + "return the value returned by the preceding call to\n" + "@code{peek-char}. In particular, a call to @code{peek-char} on\n" + "an interactive port will hang waiting for input whenever a call\n" + "to @code{read-char} would have hung.\n" + "\n" + "As for @code{read-char}, a @code{decoding-error} may be raised\n" + "if such a situation occurs. However, unlike with @code{read-char},\n" + "@var{port} still points at the beginning of the erroneous byte\n" + "sequence when the error is raised.\n") +#define FUNC_NAME s_scm_peek_char +{ + SCM buf; + scm_t_wchar c; + size_t cur, len = 0; + + if (SCM_UNBNDP (port)) + port = scm_current_input_port (); + SCM_VALIDATE_OPINPORT (1, port); + + c = peek_codepoint (port, &buf, &cur, &len); + + return c == EOF ? SCM_EOF_VAL : SCM_MAKE_CHAR (c); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_unread_char, "unread-char", 1, 1, 0, + (SCM cobj, SCM port), + "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; + + SCM_VALIDATE_CHAR (1, cobj); + if (SCM_UNBNDP (port)) + port = scm_current_input_port (); + SCM_VALIDATE_OPINPORT (2, port); + + c = SCM_CHAR (cobj); + + scm_ungetc (c, port); + return cobj; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0, + (SCM str, SCM port), + "Place the string @var{str} in @var{port} so that its characters will be\n" + "read in subsequent read operations. If called multiple times, the\n" + "unread characters will be read again in last-in first-out order. If\n" + "@var{port} is not supplied, the current-input-port is used.") +#define FUNC_NAME s_scm_unread_string +{ + int n; + SCM_VALIDATE_STRING (1, str); + if (SCM_UNBNDP (port)) + port = scm_current_input_port (); + SCM_VALIDATE_OPINPORT (2, port); + + n = scm_i_string_length (str); + + while (n--) + scm_ungetc (scm_i_string_ref (str, n), port); + + return str; +} +#undef FUNC_NAME + + + + +/* Manipulating the buffers. */ + +SCM_SYMBOL (sym_none, "none"); +SCM_SYMBOL (sym_line, "line"); +SCM_SYMBOL (sym_block, "block"); + +SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, + (SCM port, SCM mode, SCM size), + "Set the buffering mode for @var{port}. @var{mode} can be one\n" + "of the following symbols:\n" + "@table @code\n" + "@item none\n" + "no buffering\n" + "@item line\n" + "line buffering\n" + "@item block\n" + "block buffering, using a newly allocated buffer of @var{size} bytes.\n" + "If @var{size} is omitted, a default size will be used.\n" + "@end table\n\n" + "Only certain types of ports are supported, most importantly\n" + "file ports.") +#define FUNC_NAME s_scm_setvbuf +{ + long csize; + scm_t_port *pt; + scm_t_port_type *ptob; + scm_t_bits tag_word; + size_t read_buf_size, write_buf_size, cur, avail; + SCM saved_read_buf; + + port = SCM_COERCE_OUTPORT (port); + + SCM_VALIDATE_OPENPORT (1, port); + pt = SCM_PORT (port); + ptob = SCM_PORT_TYPE (port); + tag_word = SCM_CELL_WORD_0 (port) & ~(SCM_BUF0 | SCM_BUFLINE); + + if (scm_is_eq (mode, sym_none)) + { + tag_word |= SCM_BUF0; + if (!SCM_UNBNDP (size) && !scm_is_eq (size, SCM_INUM0)) + scm_out_of_range (FUNC_NAME, size); + csize = 0; + } + else if (scm_is_eq (mode, sym_line)) + { + csize = SCM_UNBNDP (size) ? -1 : scm_to_int (size); + tag_word |= SCM_BUFLINE; + } + else if (scm_is_eq (mode, sym_block)) + { + csize = SCM_UNBNDP (size) ? -1 : scm_to_int (size); + } + else + scm_out_of_range (FUNC_NAME, mode); + + if (!SCM_UNBNDP (size) && csize < 0) + scm_out_of_range (FUNC_NAME, size); + + if (csize >= 0) + read_buf_size = write_buf_size = csize; + else + { + read_buf_size = write_buf_size = default_buffer_size; + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + if (ptob->get_natural_buffer_sizes) + ptob->get_natural_buffer_sizes (port, &read_buf_size, &write_buf_size); + scm_dynwind_end (); + } + + /* Minimum buffer size is one byte. */ + if (read_buf_size == 0) + read_buf_size = 1; + if (write_buf_size == 0) + write_buf_size = 1; + + if (SCM_OUTPUT_PORT_P (port)) + scm_flush (port); + + saved_read_buf = pt->read_buf; + + SCM_SET_CELL_WORD_0 (port, tag_word); + pt->read_buffering = read_buf_size; + pt->read_buf = make_port_buffer (port, read_buf_size); + pt->write_buf = make_port_buffer (port, write_buf_size); + + avail = scm_port_buffer_can_take (saved_read_buf, &cur); + scm_unget_bytes (scm_port_buffer_take_pointer (saved_read_buf, cur), avail, + port); + scm_port_buffer_set_has_eof_p (pt->read_buf, + scm_port_buffer_has_eof_p (saved_read_buf)); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +/* Move up to READ_LEN bytes from PORT's read buffer into memory + starting at DEST. Return the number of bytes moved. PORT's + line/column numbers are left unchanged. */ +size_t +scm_take_from_input_buffers (SCM port, char *dest, size_t read_len) +{ + SCM read_buf = SCM_PORT (port)->read_buf; + size_t cur, avail; + avail = scm_port_buffer_can_take (read_buf, &cur); + return scm_port_buffer_take (read_buf, (uint8_t *) dest, read_len, + cur, avail); +} + +/* Clear a port's read buffers, returning the contents. */ +SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, + (SCM port), + "This procedure clears a port's input buffers, similar\n" + "to the way that force-output clears the output buffer. The\n" + "contents of the buffers are returned as a single string, e.g.,\n" + "\n" + "@lisp\n" + "(define p (open-input-file ...))\n" + "(drain-input p) => empty string, nothing buffered yet.\n" + "(unread-char (read-char p) p)\n" + "(drain-input p) => initial chars from p, up to the buffer size.\n" + "@end lisp\n\n" + "Draining the buffers may be useful for cleanly finishing\n" + "buffered I/O so that the file descriptor can be used directly\n" + "for further input.") +#define FUNC_NAME s_scm_drain_input +{ + SCM read_buf, result; + size_t avail, cur; + + SCM_VALIDATE_OPINPORT (1, port); + read_buf = SCM_PORT (port)->read_buf; + avail = scm_port_buffer_can_take (read_buf, &cur); + + if (avail) + { + const uint8_t *ptr = scm_port_buffer_take_pointer (read_buf, cur); + result = scm_from_port_stringn ((const char *) ptr, avail, port); + scm_port_buffer_did_take (read_buf, cur, avail); + } + else + result = scm_nullstr; + + return result; +} +#undef FUNC_NAME + +void +scm_end_input (SCM port) +{ + SCM buf; + size_t cur, avail; + scm_t_off offset; + + buf = SCM_PORT (port)->read_buf; + avail = scm_port_buffer_can_take (buf, &cur); + scm_port_buffer_did_take (buf, cur, avail); + offset = - (scm_t_off) avail; + + if (offset != 0) + { + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + SCM_PORT_TYPE (port)->seek (port, offset, SEEK_CUR); + scm_dynwind_end (); + } +} + +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" + "is omitted. The current output buffer contents are passed to the\n" + "underlying port implementation (e.g., in the case of fports, the\n" + "data will be written to the file and the output buffer will be cleared.)\n" + "It has no effect on an unbuffered port.\n\n" + "The return value is unspecified.") +#define FUNC_NAME s_scm_force_output +{ + if (SCM_UNBNDP (port)) + port = scm_current_output_port (); + else + { + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPOUTPORT (1, port); + } + scm_flush (port); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +static void scm_i_write (SCM port, SCM buf); + +void +scm_flush (SCM port) +{ + SCM buf = SCM_PORT (port)->write_buf; + size_t cur; + if (scm_port_buffer_can_take (buf, &cur)) + scm_i_write (port, buf); +} + +/* Return number of bytes consumed, or zero if no BOM was consumed. */ +static size_t +maybe_consume_bom (SCM port, const unsigned char *bom, size_t bom_len) +{ + SCM read_buf; + const uint8_t *buf; + size_t cur, avail; + + if (peek_byte_or_eof (port, &read_buf, &cur) != bom[0]) + return 0; + + /* Make sure there's enough space in the buffer for a BOM. Now that + we matched the first byte, we know we're going to have to read this + many bytes anyway. */ + read_buf = scm_fill_input (port, bom_len, &cur, &avail); + buf = scm_port_buffer_take_pointer (read_buf, cur); + + if (avail < bom_len) + return 0; + + if (memcmp (buf, bom, bom_len) != 0) + return 0; + + scm_port_buffer_did_take (read_buf, cur, bom_len); + return bom_len; +} + +static size_t +port_clear_stream_start_for_bom_read (SCM port, enum bom_io_mode io_mode) +{ + scm_t_port *pt = SCM_PORT (port); + + if (!pt->at_stream_start_for_bom_read) + return 0; + + /* Maybe slurp off a byte-order marker. */ + pt->at_stream_start_for_bom_read = 0; + if (pt->rw_random) + pt->at_stream_start_for_bom_write = 0; + + if (io_mode == BOM_IO_BINARY) + return 0; + + if (scm_is_eq (pt->encoding, sym_UTF_8)) + return maybe_consume_bom (port, scm_utf8_bom, sizeof (scm_utf8_bom)); + + if (scm_is_eq (pt->encoding, sym_UTF_16)) + { + if (maybe_consume_bom (port, scm_utf16le_bom, sizeof (scm_utf16le_bom))) + { + scm_specialize_port_encoding_x (port, sym_UTF_16LE); + return 2; + } + if (maybe_consume_bom (port, scm_utf16be_bom, sizeof (scm_utf16be_bom))) + { + scm_specialize_port_encoding_x (port, sym_UTF_16BE); + return 2; + } + /* Big-endian by default. */ + scm_specialize_port_encoding_x (port, sym_UTF_16BE); + return 0; + } + + if (scm_is_eq (pt->encoding, sym_UTF_32)) + { + if (maybe_consume_bom (port, scm_utf32le_bom, sizeof (scm_utf32le_bom))) + { + /* Big-endian by default. */ + scm_specialize_port_encoding_x (port, sym_UTF_32LE); + return 4; + } + if (maybe_consume_bom (port, scm_utf32be_bom, sizeof (scm_utf32be_bom))) + { + scm_specialize_port_encoding_x (port, sym_UTF_32BE); + return 4; + } + /* Big-endian by default. */ + scm_specialize_port_encoding_x (port, sym_UTF_32BE); + return 0; + } + + return 0; +} + +SCM_INTERNAL SCM scm_port_clear_stream_start_for_bom_read (SCM port); +SCM_DEFINE (scm_port_clear_stream_start_for_bom_read, + "port-clear-stream-start-for-bom-read", 1, 0, 0, + (SCM port), + "") +#define FUNC_NAME s_scm_port_clear_stream_start_for_bom_read +{ + scm_t_port *pt; + + SCM_VALIDATE_PORT (1, port); + + pt = SCM_PORT (port); + if (!pt->at_stream_start_for_bom_read) + return SCM_BOOL_F; + + /* Maybe slurp off a byte-order marker. */ + pt->at_stream_start_for_bom_read = 0; + if (pt->rw_random) + pt->at_stream_start_for_bom_write = 0; + + return SCM_BOOL_T; +} +#undef FUNC_NAME + +SCM_INTERNAL SCM scm_port_clear_stream_start_for_bom_write (SCM, SCM); +SCM_DEFINE (scm_port_clear_stream_start_for_bom_write, + "port-clear-stream-start-for-bom-write", 1, 1, 0, + (SCM port, SCM buf), + "") +#define FUNC_NAME s_scm_port_clear_stream_start_for_bom_write +{ + scm_t_port *pt; + + SCM_VALIDATE_PORT (1, port); + + pt = SCM_PORT (port); + if (!pt->at_stream_start_for_bom_write) + return SCM_INUM0; + + pt->at_stream_start_for_bom_write = 0; + if (pt->rw_random) + pt->at_stream_start_for_bom_read = 0; + + if (SCM_UNBNDP (buf)) + return SCM_INUM0; + + /* Write a BOM if appropriate. */ + if (scm_is_eq (pt->encoding, sym_UTF_16)) + { + SCM precise_encoding; + size_t end, avail, ret; + + scm_port_acquire_iconv_descriptors (port, NULL, NULL); + precise_encoding = pt->precise_encoding; + scm_port_release_iconv_descriptors (port); + + avail = scm_port_buffer_can_put (buf, &end); + if (scm_is_eq (precise_encoding, sym_UTF_16LE)) + ret = scm_port_buffer_put (buf, scm_utf16le_bom, + sizeof (scm_utf16le_bom), end, avail); + else + ret = scm_port_buffer_put (buf, scm_utf16be_bom, + sizeof (scm_utf16be_bom), end, avail); + + return scm_from_size_t (ret); + } + else if (scm_is_eq (pt->encoding, sym_UTF_32)) + { + SCM precise_encoding; + size_t end, avail, ret; + + scm_port_acquire_iconv_descriptors (port, NULL, NULL); + precise_encoding = pt->precise_encoding; + scm_port_release_iconv_descriptors (port); + + avail = scm_port_buffer_can_put (buf, &end); + if (scm_is_eq (precise_encoding, sym_UTF_32LE)) + ret = scm_port_buffer_put (buf, scm_utf32le_bom, + sizeof (scm_utf32le_bom), end, avail); + else + ret = scm_port_buffer_put (buf, scm_utf32be_bom, + sizeof (scm_utf32be_bom), end, avail); + + return scm_from_size_t (ret); + } + + return SCM_INUM0; +} +#undef FUNC_NAME + +SCM +scm_fill_input (SCM port, size_t minimum_size, size_t *cur_out, + size_t *avail_out) +{ + scm_t_port *pt = SCM_PORT (port); + SCM read_buf; + size_t cur, buffered; + + if (minimum_size == 0) + minimum_size = 1; + + /* The default is BOM_IO_TEXT. Binary input procedures should + port_clear_stream_start_for_bom_read with BOM_IO_BINARY before + filling the input buffers. */ + port_clear_stream_start_for_bom_read (port, BOM_IO_TEXT); + read_buf = pt->read_buf; + buffered = scm_port_buffer_can_take (read_buf, &cur); + + if (buffered >= minimum_size + || scm_is_true (scm_port_buffer_has_eof_p (read_buf))) + { + *cur_out = cur; + *avail_out = buffered; + return read_buf; + } + + if (pt->rw_random) + scm_flush (port); + + /* Prepare to read. Make sure there is enough space in the buffer for + minimum_size, and ensure that cur is zero so that we fill towards + the end of the buffer. */ + if (minimum_size > scm_port_buffer_size (read_buf)) + /* Grow the read buffer. */ + read_buf = scm_expand_port_read_buffer_x (port, + scm_from_size_t (minimum_size), + SCM_BOOL_F); + else if (buffered == 0) + scm_port_buffer_reset (read_buf); + else + { + const uint8_t *to_shift; + to_shift = scm_port_buffer_take_pointer (read_buf, cur); + scm_port_buffer_reset (read_buf); + memmove (scm_port_buffer_put_pointer (read_buf, 0), to_shift, buffered); + scm_port_buffer_did_put (read_buf, 0, buffered); + } + + while (buffered < minimum_size + && !scm_is_true (scm_port_buffer_has_eof_p (read_buf))) + { + size_t count; + size_t buffering = pt->read_buffering; + size_t to_read; + + if (pt->read_buffering < minimum_size) + buffering = minimum_size; + to_read = buffering - buffered; + + count = scm_i_read_bytes (port, scm_port_buffer_bytevector (read_buf), + buffered, to_read); + scm_port_buffer_did_put (read_buf, buffered, count); + buffered += count; + scm_port_buffer_set_has_eof_p (read_buf, scm_from_bool (count == 0)); + } + + /* We ensured cur was zero. */ + *cur_out = 0; + *avail_out = buffered; + return read_buf; +} + +SCM_DEFINE (scm_port_random_access_p, "port-random-access?", 1, 0, 0, + (SCM port), + "Return true if the port is random-access, or false otherwise.") +#define FUNC_NAME s_scm_port_random_access_p +{ + SCM_VALIDATE_OPPORT (1, port); + return scm_from_bool (SCM_PORT (port)->rw_random); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_read_buffering, "port-read-buffering", 1, 0, 0, + (SCM port), + "Return the amount of read buffering on a port, in bytes.") +#define FUNC_NAME s_scm_port_read_buffering +{ + SCM_VALIDATE_OPINPORT (1, port); + return scm_from_size_t (SCM_PORT (port)->read_buffering); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_expand_port_read_buffer_x, "expand-port-read-buffer!", 2, 1, 0, + (SCM port, SCM size, SCM putback_p), + "Expand the read buffer of @var{port} to @var{size}. Copy the\n" + "old buffered data, if, any, to the beginning of the new\n" + "buffer, unless @var{putback_p} is true, in which case copy it\n" + "to the end instead. Return the new buffer.") +#define FUNC_NAME s_scm_expand_port_read_buffer_x +{ + scm_t_port *pt; + size_t c_size, cur, avail; + SCM new_buf; + + SCM_VALIDATE_OPINPORT (1, port); + pt = SCM_PORT (port); + c_size = scm_to_size_t (size); + SCM_ASSERT_RANGE (2, size, c_size > scm_port_buffer_size (pt->read_buf)); + if (SCM_UNBNDP (putback_p)) + putback_p = SCM_BOOL_F; + + new_buf = make_port_buffer (port, c_size); + scm_port_buffer_set_has_eof_p (new_buf, + scm_port_buffer_has_eof_p (pt->read_buf)); + avail = scm_port_buffer_can_take (pt->read_buf, &cur); + + if (scm_is_true (putback_p)) + { + scm_port_buffer_reset_end (new_buf); + scm_port_buffer_putback (new_buf, + scm_port_buffer_take_pointer (pt->read_buf, cur), + avail, c_size); + } + else + { + scm_port_buffer_reset (new_buf); + scm_port_buffer_put (new_buf, + scm_port_buffer_take_pointer (pt->read_buf, cur), + avail, 0, c_size); + } + pt->read_buf = new_buf; + + return new_buf; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_read, "port-read", 1, 0, 0, (SCM port), + "Return the read function for an input port.") +#define FUNC_NAME s_scm_port_read +{ + SCM_VALIDATE_OPINPORT (1, port); + return SCM_PORT_TYPE (port)->scm_read; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_write, "port-write", 1, 0, 0, + (SCM port), + "Return the write function for an output port.") +#define FUNC_NAME s_scm_port_write +{ + SCM_VALIDATE_OPOUTPORT (1, port); + return SCM_PORT_TYPE (port)->scm_write; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_read_buffer, "port-read-buffer", 1, 0, 0, + (SCM port), + "Return the read buffer for a port.") +#define FUNC_NAME s_scm_port_read_buffer +{ + SCM_VALIDATE_OPPORT (1, port); + return SCM_PORT (port)->read_buf; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_write_buffer, "port-write-buffer", 1, 0, 0, + (SCM port), + "Return the write buffer for a port.") +#define FUNC_NAME s_scm_port_write_buffer +{ + SCM_VALIDATE_OPPORT (1, port); + return SCM_PORT (port)->write_buf; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_auxiliary_write_buffer, "port-auxiliary-write-buffer", + 1, 0, 0, (SCM port), + "Return the auxiliary write buffer for a port.") +#define FUNC_NAME s_scm_port_auxiliary_write_buffer +{ + scm_t_port *pt; + + SCM_VALIDATE_OPPORT (1, port); + + pt = SCM_PORT (port); + if (scm_is_false (pt->write_buf_aux)) + pt->write_buf_aux = make_port_buffer (port, AUXILIARY_WRITE_BUFFER_SIZE); + + return pt->write_buf_aux; +} +#undef FUNC_NAME + +SCM_INTERNAL SCM scm_port_line_buffered_p (SCM); +SCM_DEFINE (scm_port_line_buffered_p, "port-line-buffered?", 1, 0, 0, + (SCM port), + "Return true if the port is line buffered.") +#define FUNC_NAME s_scm_port_line_buffered_p +{ + SCM_VALIDATE_OPPORT (1, port); + return scm_from_bool (SCM_CELL_WORD_0 (port) & SCM_BUFLINE); +} +#undef FUNC_NAME + + + + +/* Output. */ + +static void +scm_i_write_bytes (SCM port, SCM src, size_t start, size_t count) +{ + size_t written = 0; + scm_t_port_type *ptob = SCM_PORT_TYPE (port); + + if (count > SCM_BYTEVECTOR_LENGTH (src)) + fprintf (stderr, "count: %zu %zu\n", count, scm_c_bytevector_length (src)); + assert (count <= SCM_BYTEVECTOR_LENGTH (src)); + assert (start + count <= SCM_BYTEVECTOR_LENGTH (src)); + + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + + do + { + size_t ret = ptob->c_write (port, src, start + written, count - written); + + if (ret == (size_t) -1) + { + if (SCM_PORT_FINALIZING_P (port)) + { + /* This port is being closed because it became unreachable + and was finalized, but it has buffered output, and the + resource is not currently writable. Instead of + blocking, discard buffered output and warn. To avoid + this situation, force-output on the port before letting + it go! */ + scm_puts + ("Warning: Discarding buffered output on non-blocking port\n" + " ", + scm_current_warning_port ()); + scm_display (port, scm_current_warning_port()); + scm_puts + ("\n" + " closed by the garbage collector. To avoid this\n" + " behavior and this warning, call `force-output' or\n" + " `close-port' on the port before letting go of it.\n", + scm_current_warning_port ()); + break; + } + else + port_poll (port, POLLOUT, -1); + } + else + written += ret; + } + while (written < count); + + scm_dynwind_end (); + + assert (written == count); +} + +static void +scm_i_write (SCM port, SCM buf) +{ + size_t start, count; + + scm_port_clear_stream_start_for_bom_write (port, SCM_UNDEFINED); + + /* Update cursors before attempting to write, assuming that I/O errors + are sticky. That way if the write throws an error, causing the + computation to abort, and possibly causing the port to be collected + by GC when it's open, any subsequent close-port / force-output + won't signal *another* error. */ + + count = scm_port_buffer_can_take (buf, &start); + scm_port_buffer_reset (buf); + scm_i_write_bytes (port, scm_port_buffer_bytevector (buf), start, + count); +} + +/* Used by an application to write arbitrary number of bytes to an SCM + port. Similar semantics as libc write. However, unlike libc write, + scm_c_write writes the requested number of bytes. + + Warning: Doesn't update port line and column counts! */ +void +scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count) +#define FUNC_NAME "scm_c_write_bytes" +{ + scm_t_port *pt; + SCM write_buf; + + SCM_VALIDATE_OPOUTPORT (1, port); + + pt = SCM_PORT (port); + write_buf = pt->write_buf; + + if (pt->rw_random) + scm_end_input (port); + + if (count < scm_port_buffer_size (write_buf)) + { + size_t cur, end; + + /* Make it so that the write_buf "end" cursor is only nonzero if + there are buffered bytes already. */ + if (scm_port_buffer_can_take (write_buf, &cur) == 0) + { + scm_port_buffer_reset (write_buf); + cur = 0; + } + + /* We buffer writes that are smaller in size than the write + buffer. If the buffer is too full to hold the new data, we + flush it beforehand. Otherwise it could be that the buffer is + full after filling it with the new data; if that's the case, we + flush then instead. */ + if (scm_port_buffer_can_put (write_buf, &end) < count) + { + scm_i_write (port, write_buf); + end = 0; + } + + { + signed char *src_ptr = SCM_BYTEVECTOR_CONTENTS (src) + start; + scm_port_buffer_put (write_buf, (uint8_t *) src_ptr, count, + end, count); + } + + if (scm_port_buffer_can_put (write_buf, &end) == 0) + scm_i_write (port, write_buf); + } + else + { + size_t tmp; + + /* Our write would overflow the buffer. Flush buffered bytes (if + needed), then write our bytes with just one syscall. */ + if (scm_port_buffer_can_take (write_buf, &tmp)) + scm_i_write (port, write_buf); + + scm_i_write_bytes (port, src, start, count); + } +} +#undef FUNC_NAME + +/* Like scm_c_write_bytes, but always writes through the write buffer. + Used when an application wants to write bytes stored in an area not + managed by GC. */ +void +scm_c_write (SCM port, const void *ptr, size_t size) +#define FUNC_NAME "scm_c_write" +{ + scm_t_port *pt; + SCM write_buf; + size_t end, avail, written = 0; + int using_aux_buffer = 0; + const uint8_t *src = ptr; + + SCM_VALIDATE_OPOUTPORT (1, port); + + pt = SCM_PORT (port); + + if (pt->rw_random) + scm_end_input (port); + + /* Imagine we are writing 40 bytes on an unbuffered port. If we were + writing from a bytevector we could pass that write directly to the + port. But since we aren't, we need to go through a bytevector, and + if we went through the port buffer we'd have to make 40 individual + calls to the write function. That would be terrible. Really we + need an intermediate bytevector. But, we shouldn't use a trick + analogous to what we do with expand-port-read-buffer!, because the + way we use the cur and end cursors doesn't seem to facilitate that. + So instead we buffer through an auxiliary write buffer if needed. + To avoid re-allocating this buffer all the time, we store it on the + port. It should never be left with buffered data. + + Use of an auxiliary write buffer is triggered if the buffer is + smaller than the size we would make for an auxiliary write buffer, + and the write is bigger than the buffer. */ + write_buf = pt->write_buf; + if (scm_port_buffer_size (write_buf) < size && + scm_port_buffer_size (write_buf) < AUXILIARY_WRITE_BUFFER_SIZE) + { + using_aux_buffer = 1; + write_buf = scm_port_auxiliary_write_buffer (port); + } + + if (using_aux_buffer) + { + end = 0; + avail = AUXILIARY_WRITE_BUFFER_SIZE; + } + else + avail = scm_port_buffer_can_put (write_buf, &end); + + while (written < size) + { + size_t did_put = scm_port_buffer_put (write_buf, src, size - written, + end, avail); + written += did_put; + src += did_put; + if (using_aux_buffer || did_put == avail) + { + scm_i_write (port, write_buf); + end = 0; + avail = scm_port_buffer_size (write_buf); + } + } +} +#undef FUNC_NAME + +/* The encoded escape sequence will be written to BUF, and will be valid + ASCII (so also valid ISO-8859-1 and UTF-8). Return the number of + bytes written. */ +static size_t +encode_escape_sequence (scm_t_wchar ch, uint8_t buf[ESCAPE_BUFFER_SIZE]) +{ + /* Represent CH using the in-string escape syntax. */ + static const char hex[] = "0123456789abcdef"; + static const char escapes[7] = "abtnvfr"; + size_t i = 0; + + buf[i++] = '\\'; + + if (ch >= 0x07 && ch <= 0x0D && ch != 0x0A) + /* Use special escapes for some C0 controls. */ + buf[i++] = escapes[ch - 0x07]; + else if (!SCM_R6RS_ESCAPES_P) + { + if (ch <= 0xFF) + { + buf[i++] = 'x'; + buf[i++] = hex[ch / 16]; + buf[i++] = hex[ch % 16]; + } + else if (ch <= 0xFFFF) + { + buf[i++] = 'u'; + buf[i++] = hex[(ch & 0xF000) >> 12]; + buf[i++] = hex[(ch & 0xF00) >> 8]; + buf[i++] = hex[(ch & 0xF0) >> 4]; + buf[i++] = hex[(ch & 0xF)]; + } + else if (ch > 0xFFFF) + { + buf[i++] = 'U'; + buf[i++] = hex[(ch & 0xF00000) >> 20]; + buf[i++] = hex[(ch & 0xF0000) >> 16]; + buf[i++] = hex[(ch & 0xF000) >> 12]; + buf[i++] = hex[(ch & 0xF00) >> 8]; + buf[i++] = hex[(ch & 0xF0) >> 4]; + buf[i++] = hex[(ch & 0xF)]; + } + } + else + { + buf[i++] = 'x'; + if (ch > 0xfffff) buf[i++] = hex[(ch >> 20) & 0xf]; + if (ch > 0x0ffff) buf[i++] = hex[(ch >> 16) & 0xf]; + if (ch > 0x00fff) buf[i++] = hex[(ch >> 12) & 0xf]; + if (ch > 0x000ff) buf[i++] = hex[(ch >> 8) & 0xf]; + if (ch > 0x0000f) buf[i++] = hex[(ch >> 4) & 0xf]; + buf[i++] = hex[ch & 0xf]; + buf[i++] = ';'; + } + + return i; +} + +void +scm_c_put_escaped_char (SCM port, scm_t_wchar ch) +{ + uint8_t escape[ESCAPE_BUFFER_SIZE]; + size_t len = encode_escape_sequence (ch, escape); + scm_c_put_latin1_chars (port, escape, len); +} + +/* Convert CODEPOINT to UTF-8 and store the result in UTF8. Return the + number of bytes of the UTF-8-encoded string. */ +static size_t +codepoint_to_utf8 (uint32_t codepoint, uint8_t utf8[UTF8_BUFFER_SIZE]) +{ + size_t len; + + if (codepoint <= 0x7f) + { + len = 1; + utf8[0] = codepoint; + } + else if (codepoint <= 0x7ffUL) + { + len = 2; + utf8[0] = 0xc0 | (codepoint >> 6); + utf8[1] = 0x80 | (codepoint & 0x3f); + } + else if (codepoint <= 0xffffUL) + { + len = 3; + utf8[0] = 0xe0 | (codepoint >> 12); + utf8[1] = 0x80 | ((codepoint >> 6) & 0x3f); + utf8[2] = 0x80 | (codepoint & 0x3f); + } + else + { + len = 4; + utf8[0] = 0xf0 | (codepoint >> 18); + utf8[1] = 0x80 | ((codepoint >> 12) & 0x3f); + utf8[2] = 0x80 | ((codepoint >> 6) & 0x3f); + utf8[3] = 0x80 | (codepoint & 0x3f); + } + + return len; +} + +static size_t +try_encode_char_to_iconv_buf (SCM port, SCM buf, uint32_t ch) +{ + uint8_t utf8[UTF8_BUFFER_SIZE]; + size_t utf8_len = codepoint_to_utf8 (ch, utf8); + size_t end; + size_t can_put = scm_port_buffer_can_put (buf, &end); + uint8_t *aux = scm_port_buffer_put_pointer (buf, end); + iconv_t output_cd; + int saved_errno; + + char *input = (char *) utf8; + size_t input_left = utf8_len; + char *output = (char *) aux; + size_t output_left = can_put; + size_t res; + + scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); + res = iconv (output_cd, &input, &input_left, &output, &output_left); + saved_errno = errno; + /* Emit bytes needed to get back to initial state, if needed. */ + iconv (output_cd, NULL, NULL, &output, &output_left); + scm_port_release_iconv_descriptors (port); + + if (res != (size_t) -1) + { + /* Success. */ + scm_port_buffer_did_put (buf, end, can_put - output_left); + return 1; + } + + if (saved_errno == E2BIG) + /* No space to encode the character; try again next time. */ + return 0; + + /* Otherwise, re-set the output buffer and try to escape or substitute + the character, as appropriate. */ + output = (char *) aux; + output_left = can_put; + + /* The source buffer is valid UTF-8, so we shouldn't get EILSEQ + because of the input encoding; if we get EILSEQ, that means the + codepoint is not accessible in the target encoding. We have whole + codepoints in the source buffer, so we shouldn't get EINVAL. We + already handled E2BIG. The descriptor should be valid so we + shouldn't get EBADF. In summary, we only need to handle EILSEQ. */ + + if (scm_is_eq (SCM_PORT (port)->conversion_strategy, sym_escape)) + { + uint8_t escape[ESCAPE_BUFFER_SIZE]; + input = (char *) escape; + input_left = encode_escape_sequence (ch, escape); + scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); + res = iconv (output_cd, &input, &input_left, &output, &output_left); + saved_errno = errno; + iconv (output_cd, NULL, NULL, &output, &output_left); + scm_port_release_iconv_descriptors (port); + } + else if (scm_is_eq (SCM_PORT (port)->conversion_strategy, sym_substitute)) + { + uint8_t substitute[2] = "?"; + input = (char *) substitute; + input_left = 1; + scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); + res = iconv (output_cd, &input, &input_left, &output, &output_left); + saved_errno = errno; + iconv (output_cd, NULL, NULL, &output, &output_left); + scm_port_release_iconv_descriptors (port); + } + + if (res != (size_t) -1) + { + scm_port_buffer_did_put (buf, end, can_put - output_left); + return 1; + } + + /* No space to write the substitution or escape, or maybe there was an + error. If there are buffered bytes, the caller should flush and + try again; otherwise the caller should raise an error. */ + return 0; +} + +static size_t +encode_latin1_chars_to_latin1_buf (SCM port, SCM buf, + const uint8_t *chars, size_t count) +{ + size_t end; + size_t avail = scm_port_buffer_can_put (buf, &end); + return scm_port_buffer_put (buf, chars, count, end, avail); +} + +static size_t +encode_latin1_chars_to_utf8_buf (SCM port, SCM buf, + const uint8_t *chars, size_t count) +{ + size_t end; + size_t buf_size = scm_port_buffer_can_put (buf, &end); + uint8_t *dst = scm_port_buffer_put_pointer (buf, end); + size_t read, written; + for (read = 0, written = 0; + read < count && written + UTF8_BUFFER_SIZE < buf_size; + read++) + written += codepoint_to_utf8 (chars[read], dst + written); + scm_port_buffer_did_put (buf, end, written); + return read; +} + +static size_t +encode_latin1_chars_to_iconv_buf (SCM port, SCM buf, + const uint8_t *chars, size_t count) +{ + size_t read; + for (read = 0; read < count; read++) + if (!try_encode_char_to_iconv_buf (port, buf, chars[read])) + break; + return read; +} + +static size_t +encode_latin1_chars (SCM port, SCM buf, const uint8_t *chars, size_t count) +{ + scm_t_port *pt = SCM_PORT (port); + SCM position; + size_t ret, i; + + if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) + ret = encode_latin1_chars_to_latin1_buf (port, buf, chars, count); + else if (scm_is_eq (pt->encoding, sym_UTF_8)) + ret = encode_latin1_chars_to_utf8_buf (port, buf, chars, count); + else + ret = encode_latin1_chars_to_iconv_buf (port, buf, chars, count); + + if (ret == 0 && count > 0) + scm_encoding_error ("put-char", EILSEQ, + "conversion to port encoding failed", + port, SCM_MAKE_CHAR (chars[0])); + + position = pt->position; + for (i = 0; i < ret; i++) + update_port_position (position, chars[i]); + + return ret; +} + +static size_t +encode_utf32_chars_to_latin1_buf (SCM port, SCM buf, + const uint32_t *chars, size_t count) +{ + scm_t_port *pt = SCM_PORT (port); + size_t end; + size_t buf_size = scm_port_buffer_can_put (buf, &end); + uint8_t *dst = scm_port_buffer_put_pointer (buf, end); + size_t read, written; + for (read = 0, written = 0; read < count && written < buf_size; read++) + { + uint32_t ch = chars[read]; + if (ch <= 0xff) + dst[written++] = ch; + else if (scm_is_eq (pt->conversion_strategy, sym_substitute)) + dst[written++] = '?'; + else if (scm_is_eq (pt->conversion_strategy, sym_escape)) + { + uint8_t escape[ESCAPE_BUFFER_SIZE]; + size_t escape_len = encode_escape_sequence (ch, escape); + if (escape_len > buf_size - written) + break; + memcpy (dst + written, escape, escape_len); + written += escape_len; + } + else + break; + } + scm_port_buffer_did_put (buf, end, written); + return read; +} + +static size_t +encode_utf32_chars_to_utf8_buf (SCM port, SCM buf, const uint32_t *chars, + size_t count) +{ + size_t end; + size_t buf_size = scm_port_buffer_can_put (buf, &end); + uint8_t *dst = scm_port_buffer_put_pointer (buf, end); + size_t read, written; + for (read = 0, written = 0; + read < count && written + UTF8_BUFFER_SIZE < buf_size; + read++) + written += codepoint_to_utf8 (chars[read], dst + written); + scm_port_buffer_did_put (buf, end, written); + return read; +} + +static size_t +encode_utf32_chars_to_iconv_buf (SCM port, SCM buf, const uint32_t *chars, + size_t count) +{ + size_t read; + for (read = 0; read < count; read++) + if (!try_encode_char_to_iconv_buf (port, buf, chars[read])) + break; + return read; +} + +static size_t +encode_utf32_chars (SCM port, SCM buf, const uint32_t *chars, size_t count) +{ + scm_t_port *pt = SCM_PORT (port); + SCM position; + size_t ret, i; + + if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) + ret = encode_utf32_chars_to_latin1_buf (port, buf, chars, count); + else if (scm_is_eq (pt->encoding, sym_UTF_8)) + ret = encode_utf32_chars_to_utf8_buf (port, buf, chars, count); + else + ret = encode_utf32_chars_to_iconv_buf (port, buf, chars, count); + + if (ret == 0 && count > 0) + scm_encoding_error ("put-char", EILSEQ, + "conversion to port encoding failed", + port, SCM_MAKE_CHAR (chars[0])); + + position = pt->position; + for (i = 0; i < ret; i++) + update_port_position (position, chars[i]); + + return ret; +} + +static size_t +port_encode_chars (SCM port, SCM buf, SCM str, size_t start, size_t count) +{ + if (count == 0) + return 0; + + if (scm_i_is_narrow_string (str)) + { + const char *chars = scm_i_string_chars (str); + return encode_latin1_chars (port, buf, + ((const uint8_t *) chars) + start, + count); + } + else + { + const scm_t_wchar *chars = scm_i_string_wide_chars (str); + return encode_utf32_chars (port, buf, + ((const uint32_t *) chars) + start, + count); + } +} + +SCM scm_port_encode_chars (SCM, SCM, SCM, SCM, SCM); +SCM_DEFINE (scm_port_encode_chars, "port-encode-chars", 5, 0, 0, + (SCM port, SCM buf, SCM str, SCM start, SCM count), + "") +#define FUNC_NAME s_scm_port_encode_chars +{ + size_t c_start, c_count, c_len, encoded; + + SCM_VALIDATE_OPOUTPORT (1, port); + SCM_VALIDATE_VECTOR (2, buf); + SCM_VALIDATE_STRING (3, str); + c_len = scm_i_string_length (str); + SCM_VALIDATE_SIZE_COPY (4, start, c_start); + SCM_ASSERT_RANGE (4, start, c_start <= c_len); + SCM_VALIDATE_SIZE_COPY (5, count, c_count); + SCM_ASSERT_RANGE (5, count, c_count <= c_len - c_start); + + encoded = port_encode_chars (port, buf, str, c_start, c_count); + + return scm_from_size_t (encoded); +} +#undef FUNC_NAME + +SCM scm_port_encode_char (SCM, SCM, SCM); +SCM_DEFINE (scm_port_encode_char, "port-encode-char", 3, 0, 0, + (SCM port, SCM buf, SCM ch), + "") +#define FUNC_NAME s_scm_port_encode_char +{ + uint32_t codepoint; + + SCM_VALIDATE_OPOUTPORT (1, port); + SCM_VALIDATE_VECTOR (2, buf); + SCM_VALIDATE_CHAR (3, ch); + + codepoint = SCM_CHAR (ch); + encode_utf32_chars (port, buf, &codepoint, 1); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +void +scm_c_put_latin1_chars (SCM port, const uint8_t *chars, size_t len) +{ + SCM aux_buf = scm_port_auxiliary_write_buffer (port); + SCM aux_bv = scm_port_buffer_bytevector (aux_buf); + SCM position = SCM_PORT (port)->position; + SCM saved_line = scm_port_position_line (position); + + scm_port_clear_stream_start_for_bom_write (port, aux_buf); + + while (len) + { + size_t encoded = encode_latin1_chars (port, aux_buf, chars, len); + assert(encoded <= len); + scm_c_write_bytes (port, aux_bv, 0, + scm_to_size_t (scm_port_buffer_end (aux_buf))); + scm_port_buffer_reset (aux_buf); + chars += encoded; + len -= encoded; + } + + /* Handle line buffering. */ + if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && + !scm_is_eq (saved_line, scm_port_position_line (position))) + scm_flush (port); +} + +void +scm_c_put_utf32_chars (SCM port, const uint32_t *chars, size_t len) +{ + SCM aux_buf = scm_port_auxiliary_write_buffer (port); + SCM aux_bv = scm_port_buffer_bytevector (aux_buf); + SCM position = SCM_PORT (port)->position; + SCM saved_line = scm_port_position_line (position); + + scm_port_clear_stream_start_for_bom_write (port, aux_buf); + + while (len) + { + size_t encoded = encode_utf32_chars (port, aux_buf, chars, len); + assert(encoded <= len); + scm_c_write_bytes (port, aux_bv, 0, + scm_to_size_t (scm_port_buffer_end (aux_buf))); + scm_port_buffer_reset (aux_buf); + chars += encoded; + len -= encoded; + } + + /* Handle line buffering. */ + if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && + !scm_is_eq (saved_line, scm_port_position_line (position))) + scm_flush (port); +} + +void +scm_c_put_char (SCM port, scm_t_wchar ch) +{ + if (ch <= 0xff) + { + uint8_t narrow_ch = ch; + scm_c_put_latin1_chars (port, &narrow_ch, 1); + } + else + { + uint32_t wide_ch = ch; + scm_c_put_utf32_chars (port, &wide_ch, 1); + } +} + +/* Return 0 unless the port can be written out to the port's encoding + without errors, substitutions, or escapes. */ +int +scm_c_can_put_char (SCM port, scm_t_wchar ch) +{ + SCM encoding = SCM_PORT (port)->encoding; + + if (scm_is_eq (encoding, sym_UTF_8) + || (scm_is_eq (encoding, sym_ISO_8859_1) && ch <= 0xff) + || scm_is_eq (encoding, sym_UTF_16) + || scm_is_eq (encoding, sym_UTF_16LE) + || scm_is_eq (encoding, sym_UTF_16BE) + || scm_is_eq (encoding, sym_UTF_32) + || scm_is_eq (encoding, sym_UTF_32LE) + || scm_is_eq (encoding, sym_UTF_32BE)) + return 1; + + { + SCM bv = scm_port_buffer_bytevector (scm_port_auxiliary_write_buffer (port)); + uint8_t buf[UTF8_BUFFER_SIZE]; + char *input = (char *) buf; + size_t input_len; + char *output = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + size_t output_len = SCM_BYTEVECTOR_LENGTH (bv); + size_t result; + iconv_t output_cd; + + input_len = codepoint_to_utf8 (ch, buf); + + scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); + iconv (output_cd, NULL, NULL, &output, &output_len); + result = iconv (output_cd, &input, &input_len, &output, &output_len); + iconv (output_cd, NULL, NULL, &output, &output_len); + scm_port_release_iconv_descriptors (port); + + return result != (size_t) -1; + } +} + +void +scm_c_put_string (SCM port, SCM string, size_t start, size_t count) +{ + if (scm_i_is_narrow_string (string)) + { + const char *ptr = scm_i_string_chars (string); + scm_c_put_latin1_chars (port, ((const uint8_t *) ptr) + start, count); + } + else + { + const scm_t_wchar *ptr = scm_i_string_wide_chars (string); + scm_c_put_utf32_chars (port, ((const uint32_t *) ptr) + start, count); + } +} + +SCM_DEFINE (scm_put_char, "put-char", 2, 0, 0, (SCM port, SCM ch), + "Encode @var{ch} to bytes, and send those bytes to @var{port}.") +#define FUNC_NAME s_scm_put_char +{ + SCM_VALIDATE_OPOUTPORT (1, port); + SCM_VALIDATE_CHAR (2, ch); + + scm_c_put_char (port, SCM_CHAR (ch)); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_put_string, "put-string", 2, 2, 0, + (SCM port, SCM string, SCM start, SCM count), + "Display the @var{count} characters from @var{string} to\n" + "@var{port}, starting with the character at index @var{start}.\n" + "@var{start} defaults to 0, and @var{count} defaults to\n" + "displaying all characters until the end of the string.\n\n" + "Calling @code{put-string} is equivalent in all respects to\n" + "calling @code{put-char} on the relevant sequence of characters,\n" + "except that it will attempt to write multiple characters to\n" + "the port at a time, even if the port is unbuffered.") +#define FUNC_NAME s_scm_put_string +{ + size_t c_start, c_count, c_len; + + SCM_VALIDATE_OPOUTPORT (1, port); + SCM_VALIDATE_STRING (2, string); + c_len = scm_i_string_length (string); + c_start = SCM_UNBNDP (start) ? 0 : scm_to_size_t (start); + SCM_ASSERT_RANGE (3, start, c_start <= c_len); + c_count = SCM_UNBNDP (count) ? c_len - c_start : scm_to_size_t (count); + SCM_ASSERT_RANGE (4, count, c_count <= c_len - c_start); + + scm_c_put_string (port, string, c_start, c_count); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +void +scm_putc (char c, SCM port) +{ + SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); + scm_c_put_char (port, (uint8_t) c); +} + +void +scm_puts (const char *s, SCM port) +{ + SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); + scm_c_put_latin1_chars (port, (const uint8_t *) s, strlen (s)); +} + +/* scm_lfwrite + * + * This function differs from scm_c_write; it updates port line and + * column, flushing line-buffered ports when appropriate. */ +void +scm_lfwrite (const char *ptr, size_t size, SCM port) +{ + scm_c_put_latin1_chars (port, (const uint8_t *) ptr, size); +} + +/* Write STR to PORT from START inclusive to END exclusive. */ +void +scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port) +{ + if (end == (size_t) -1) + end = scm_i_string_length (str); + + scm_c_put_string (port, str, start, end - start); +} + + + + +/* Querying and setting positions, and character availability. */ + +SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, + (SCM port), + "Return @code{#t} if a character is ready on input @var{port}\n" + "and return @code{#f} otherwise. If @code{char-ready?} returns\n" + "@code{#t} then the next @code{read-char} operation on\n" + "@var{port} is guaranteed not to hang. If @var{port} is a file\n" + "port at end of file then @code{char-ready?} returns @code{#t}.\n" + "\n" + "@code{char-ready?} exists to make it possible for a\n" + "program to accept characters from interactive ports without\n" + "getting stuck waiting for input. Any input editors associated\n" + "with such ports must make sure that characters whose existence\n" + "has been asserted by @code{char-ready?} cannot be rubbed out.\n" + "If @code{char-ready?} were to return @code{#f} at end of file,\n" + "a port at end of file would be indistinguishable from an\n" + "interactive port that has no ready characters.") +#define FUNC_NAME s_scm_char_ready_p +{ + SCM read_buf; + size_t tmp; + + if (SCM_UNBNDP (port)) + port = scm_current_input_port (); + /* It's possible to close the current input port, so validate even in + this case. */ + SCM_VALIDATE_OPINPORT (1, port); + + read_buf = SCM_PORT (port)->read_buf; + + if (scm_port_buffer_can_take (read_buf, &tmp) || + scm_is_true (scm_port_buffer_has_eof_p (read_buf))) + /* FIXME: Verify that a whole character is available? */ + return SCM_BOOL_T; + else + { + scm_t_port_type *ptob = SCM_PORT_TYPE (port); + + if (ptob->input_waiting) + { + SCM ret; + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + ret = scm_from_bool (ptob->input_waiting (port)); + scm_dynwind_end (); + return ret; + } + else + return SCM_BOOL_T; + } +} +#undef FUNC_NAME + +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" + "@var{offset}, which is interpreted according to the value of\n" + "@var{whence}.\n" + "\n" + "One of the following variables should be supplied for\n" + "@var{whence}:\n" + "@defvar SEEK_SET\n" + "Seek from the beginning of the file.\n" + "@end defvar\n" + "@defvar SEEK_CUR\n" + "Seek from the current position.\n" + "@end defvar\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" + "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" + "that the current position of a port can be obtained using:\n" + "@lisp\n" + "(seek port 0 SEEK_CUR)\n" + "@end lisp") +#define FUNC_NAME s_scm_seek +{ + int how; + + fd_port = SCM_COERCE_OUTPORT (fd_port); + + how = scm_to_int (whence); + if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END) + SCM_OUT_OF_RANGE (3, whence); + + if (SCM_OPPORTP (fd_port)) + { + scm_t_port *pt = SCM_PORT (fd_port); + scm_t_port_type *ptob = SCM_PORT_TYPE (fd_port); + off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset); + off_t_or_off64_t rv; + + if (ptob->seek && how == SEEK_CUR && off == 0) + { + size_t tmp; + /* If we are just querying the current position, avoid + flushing buffers. We don't even need to require that the + port supports random access. */ + scm_dynwind_begin (0); + scm_dynwind_acquire_port (fd_port); + rv = ptob->seek (fd_port, off, how); + scm_dynwind_end (); + rv -= scm_port_buffer_can_take (pt->read_buf, &tmp); + rv += scm_port_buffer_can_take (pt->write_buf, &tmp); + return scm_from_off_t_or_off64_t (rv); + } + + if (!ptob->seek || !pt->rw_random) + SCM_MISC_ERROR ("port is not seekable", + scm_cons (fd_port, SCM_EOL)); + + scm_end_input (fd_port); + scm_flush (fd_port); + + scm_dynwind_begin (0); + scm_dynwind_acquire_port (fd_port); + rv = ptob->seek (fd_port, off, how); + scm_dynwind_end (); + + /* Set stream-start flags according to new position. */ + pt->at_stream_start_for_bom_read = (rv == 0); + pt->at_stream_start_for_bom_write = (rv == 0); + + scm_i_clear_pending_eof (fd_port); + + return scm_from_off_t_or_off64_t (rv); + } + else /* file descriptor?. */ + { + off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset); + off_t_or_off64_t rv; + rv = lseek_or_lseek64 (scm_to_int (fd_port), off, how); + if (rv == -1) + SCM_SYSERROR; + return scm_from_off_t_or_off64_t (rv); + } +} +#undef FUNC_NAME + +#ifndef O_BINARY +#define O_BINARY 0 +#endif + +/* Mingw has ftruncate(), perhaps implemented above using chsize, but + doesn't have the filename version truncate(), hence this code. */ +#if HAVE_FTRUNCATE && ! HAVE_TRUNCATE +static int +truncate (const char *file, off_t length) +{ + int ret, fdes; + + fdes = open (file, O_BINARY | O_WRONLY); + if (fdes == -1) + return -1; + + ret = ftruncate (fdes, length); + if (ret == -1) + { + int save_errno = errno; + close (fdes); + errno = save_errno; + return -1; + } + + return close (fdes); +} +#endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */ + +SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, + (SCM object, SCM length), + "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" + "which case the file is truncated at the current position (per\n" + "@code{ftell} above).\n" + "\n" + "On most systems a file can be extended by giving a length\n" + "greater than the current size, but this is not mandatory in the\n" + "POSIX standard.") +#define FUNC_NAME s_scm_truncate_file +{ + int rv; + + /* "object" can be a port, fdes or filename. + + Negative "length" makes no sense, but it's left to truncate() or + ftruncate() to give back an error for that (normally EINVAL). + */ + + if (SCM_UNBNDP (length)) + { + /* must supply length if object is a filename. */ + if (scm_is_string (object)) + SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL); + + length = scm_seek (object, SCM_INUM0, scm_from_int (SEEK_CUR)); + } + + object = SCM_COERCE_OUTPORT (object); + if (scm_is_integer (object)) + { + off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length); + SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object), + c_length)); + } + else if (SCM_OPOUTPORTP (object)) + { + off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length); + scm_t_port_type *ptob = SCM_PORT_TYPE (object); + + if (!ptob->truncate) + SCM_MISC_ERROR ("port is not truncatable", SCM_EOL); + + scm_i_clear_pending_eof (object); + + if (SCM_INPUT_PORT_P (object) + && SCM_PORT (object)->rw_random) + scm_end_input (object); + scm_flush (object); + + scm_dynwind_begin (0); + scm_dynwind_acquire_port (object); + ptob->truncate (object, c_length); + scm_dynwind_end (); + rv = 0; + } + else + { + off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length); + char *str = scm_to_locale_string (object); + int eno; + SCM_SYSCALL (rv = truncate_or_truncate64 (str, c_length)); + eno = errno; + free (str); + errno = eno; + } + if (rv == -1) + SCM_SYSERROR; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0, + (SCM port), + "Return the current line number for @var{port}.\n" + "\n" + "The first line of a file is 0. But you might want to add 1\n" + "when printing line numbers, since starting from 1 is\n" + "traditional in error messages, and likely to be more natural to\n" + "non-programmers.") +#define FUNC_NAME s_scm_port_line +{ + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPENPORT (1, port); + return scm_port_position_line (SCM_PORT (port)->position); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0, + (SCM port, SCM line), + "Set the current line number for @var{port} to @var{line}. The\n" + "first line of a file is 0.") +#define FUNC_NAME s_scm_set_port_line_x +{ + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPENPORT (1, port); + scm_to_long (line); + scm_port_position_set_line (SCM_PORT (port)->position, line); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0, + (SCM port), + "Return the current column number of @var{port}.\n" + "If the number is\n" + "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n" + "- i.e. the first character of the first line is line 0, column 0.\n" + "(However, when you display a file position, for example in an error\n" + "message, we recommend you add 1 to get 1-origin integers. This is\n" + "because lines and column numbers traditionally start with 1, and that is\n" + "what non-programmers will find most natural.)") +#define FUNC_NAME s_scm_port_column +{ + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPENPORT (1, port); + return scm_port_position_column (SCM_PORT (port)->position); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0, + (SCM port, SCM column), + "Set the current column of @var{port}. Before reading the first\n" + "character on a line the column should be 0.") +#define FUNC_NAME s_scm_set_port_column_x +{ + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPENPORT (1, port); + scm_to_int (column); + scm_port_position_set_column (SCM_PORT (port)->position, column); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0, + (SCM port), + "Return the filename associated with @var{port}, or @code{#f}\n" + "if no filename is associated with the port.") +#define FUNC_NAME s_scm_port_filename +{ + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPENPORT (1, port); + return SCM_FILENAME (port); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0, + (SCM port, SCM filename), + "Change the filename associated with @var{port}, using the current input\n" + "port if none is specified. Note that this does not change the port's\n" + "source of data, but only the value that is returned by\n" + "@code{port-filename} and reported in diagnostic output.") +#define FUNC_NAME s_scm_set_port_filename_x +{ + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPENPORT (1, port); + /* We allow the user to set the filename to whatever he likes. */ + SCM_SET_FILENAME (port, filename); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + + +/* Implementation helpers for port printing functions. */ + +void +scm_print_port_mode (SCM exp, SCM port) +{ + scm_puts (SCM_CLOSEDP (exp) + ? "closed: " + : (SCM_RDNG & SCM_CELL_WORD_0 (exp) + ? (SCM_WRTNG & SCM_CELL_WORD_0 (exp) + ? "input-output: " + : "input: ") + : (SCM_WRTNG & SCM_CELL_WORD_0 (exp) + ? "output: " + : "bogus: ")), + port); +} + +int +scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) +{ + char *type = SCM_PORT_TYPE (port)->name; + if (!type) + type = "port"; + scm_puts ("#<", port); + scm_print_port_mode (exp, port); + scm_puts (type, port); + scm_putc (' ', port); + scm_uintprint ((scm_t_bits) SCM_PORT (exp), 16, port); + scm_putc ('>', port); + return 1; +} + + + + +/* Iterating over all ports. */ + +struct for_each_data +{ + void (*proc) (void *data, SCM p); + void *data; +}; + +static SCM +for_each_trampoline (void *data, SCM port, SCM result) +{ + struct for_each_data *d = data; + + d->proc (d->data, port); + + return result; +} + +void +scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data) +{ + struct for_each_data d; + + d.proc = proc; + d.data = data; + + scm_c_weak_set_fold (for_each_trampoline, &d, SCM_EOL, + scm_i_port_weak_set); +} + +static void +scm_for_each_trampoline (void *data, SCM port) +{ + scm_call_1 (SCM_PACK_POINTER (data), port); +} + +SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0, + (SCM proc), + "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 @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); + + scm_c_port_for_each (scm_for_each_trampoline, SCM_UNPACK_POINTER (proc)); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +static void +flush_output_port (void *closure, SCM port) +{ + if (SCM_OPOUTPORTP (port)) + scm_flush (port); +} + +SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0, + (), + "Equivalent to calling @code{force-output} on\n" + "all open output ports. The return value is unspecified.") +#define FUNC_NAME s_scm_flush_all_ports +{ + scm_c_port_for_each (&flush_output_port, NULL); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + + +/* Void ports. */ + +scm_t_port_type *scm_void_port_type = 0; + +static size_t +void_port_read (SCM port, SCM dst, size_t start, size_t count) +{ + return 0; +} + +static size_t +void_port_write (SCM port, SCM src, size_t start, size_t count) +{ + return count; +} + +static SCM +scm_i_void_port (long mode_bits) +{ + return scm_c_make_port (scm_void_port_type, mode_bits, 0); +} + +SCM +scm_void_port (char *mode_str) +{ + return scm_i_void_port (scm_mode_bits (mode_str)); +} + +SCM_DEFINE (scm_sys_make_void_port, "%make-void-port", 1, 0, 0, + (SCM mode), + "Create and return a new void port. A void port acts like\n" + "@file{/dev/null}. The @var{mode} argument\n" + "specifies the input/output modes for this port: see the\n" + "documentation for @code{open-file} in @ref{File Ports}.") +#define FUNC_NAME s_scm_sys_make_void_port +{ + return scm_i_void_port (scm_i_mode_bits (mode)); +} +#undef FUNC_NAME + + + + +/* Initialization. */ + +static void +scm_init_ice_9_ports (void) +{ +#include "ports.x" + + scm_c_define ("the-eof-object", SCM_EOF_VAL); + + /* lseek() symbols. */ + scm_c_define ("SEEK_SET", scm_from_int (SEEK_SET)); + scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR)); + scm_c_define ("SEEK_END", scm_from_int (SEEK_END)); + + 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); + scm_c_define ("%current-warning-port-fluid", cur_warnport_fluid); +} + +void +scm_init_ports (void) +{ + sym_UTF_8 = scm_from_latin1_symbol ("UTF-8"); + sym_ISO_8859_1 = scm_from_latin1_symbol ("ISO-8859-1"); + sym_UTF_16 = scm_from_latin1_symbol ("UTF-16"); + sym_UTF_16LE = scm_from_latin1_symbol ("UTF-16LE"); + sym_UTF_16BE = scm_from_latin1_symbol ("UTF-16BE"); + sym_UTF_32 = scm_from_latin1_symbol ("UTF-32"); + sym_UTF_32LE = scm_from_latin1_symbol ("UTF-32LE"); + sym_UTF_32BE = scm_from_latin1_symbol ("UTF-32BE"); + + sym_substitute = scm_from_latin1_symbol ("substitute"); + sym_escape = scm_from_latin1_symbol ("escape"); + sym_error = scm_from_latin1_symbol ("error"); + + trampoline_to_c_read_subr = + scm_c_make_gsubr ("port-read", 4, 0, 0, + (scm_t_subr) trampoline_to_c_read); + trampoline_to_c_write_subr = + scm_c_make_gsubr ("port-write", 4, 0, 0, + (scm_t_subr) trampoline_to_c_write); + + scm_void_port_type = scm_make_port_type ("void", void_port_read, + void_port_write); + + scm_i_port_weak_set = scm_c_make_weak_set (31); + + cur_inport_fluid = scm_make_fluid (); + cur_outport_fluid = scm_make_fluid (); + cur_errport_fluid = scm_make_fluid (); + cur_warnport_fluid = scm_make_fluid (); + cur_loadport_fluid = scm_make_fluid (); + + default_port_encoding_var = + scm_c_define ("%default-port-encoding", + scm_make_fluid_with_default (SCM_BOOL_F)); + default_conversion_strategy_var = + scm_c_define ("%default-port-conversion-strategy", + scm_make_fluid_with_default (sym_substitute)); + /* Use the locale as the default port encoding. */ + scm_i_set_default_port_encoding (locale_charset ()); + + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_ice_9_ports", + (scm_t_extension_init_func) scm_init_ice_9_ports, + NULL); + + /* The following bindings are used early in boot-9.scm. */ + + /* Used by `include'. */ + scm_c_define_gsubr ("set-port-encoding!", 2, 0, 0, + (scm_t_subr) scm_set_port_encoding_x); + scm_c_define_gsubr (s_scm_eof_object_p, 1, 0, 0, + (scm_t_subr) scm_eof_object_p); + + /* Used by a number of error/warning-printing routines. */ + scm_c_define_gsubr (s_scm_force_output, 0, 1, 0, + (scm_t_subr) scm_force_output); + + /* Used by `file-exists?' and related functions if `stat' is + unavailable. */ + scm_c_define_gsubr (s_scm_close_port, 1, 0, 0, + (scm_t_subr) scm_close_port); + + /* Used by error routines. */ + scm_c_define_gsubr (s_scm_current_error_port, 0, 0, 0, + (scm_t_subr) scm_current_error_port); + scm_c_define_gsubr (s_scm_current_warning_port, 0, 0, 0, + (scm_t_subr) scm_current_warning_port); +} |