* [PATCH 1/3] Split r6rs-ports.c according to module boundaries
2012-12-09 12:47 Fix reader options for R6RS `get-datum' Andreas Rottmann
@ 2012-12-09 12:47 ` Andreas Rottmann
2012-12-15 5:35 ` Mark H Weaver
2012-12-15 5:38 ` Mark H Weaver
2012-12-09 12:47 ` [PATCH 2/3] Add internal API to specify reader options at reader invocation Andreas Rottmann
` (2 subsequent siblings)
3 siblings, 2 replies; 15+ messages in thread
From: Andreas Rottmann @ 2012-12-09 12:47 UTC (permalink / raw)
To: guile-devel
Currently, r6rs-ports.c provides procedures exported from `(ice-9
binary-ports)'. However, in addition, it also provides
`%make-transcoder', which is used by `(rnrs io ports)' via a "private
import".
This change splits r6rs-ports.c into two parts, one specific to `(ice-9
binary-ports)' and the other specific to `(rnrs io ports)'. This
provides a place to put internal C-implemented helpers needed only in
`(rnrs io ports)', thus allowing to eliminate the private import of
`%make-transcoder'.
* libguile/binary-port.c: New file, contains the most part of what has
been in libguile/r6rs-ports.c for now.
* libguile/binary-ports.h: Ditto for the header part.
* libguile/r6rs-ports.c: Now contains just transcoded ports, as this API
is not part of the `(ice-9 binary-ports)' module.
* libguile/r6rs-ports.h: Now includes "libguile/binary-ports.h", and
defines the extension registration and initialization functions.
* libguile/Makefile.am: Add new files.
---
libguile/Makefile.am | 2 +
libguile/binary-ports.c | 1152 +++++++++++++++++++++++++++++++++++++++++
libguile/binary-ports.h | 46 ++
libguile/r6rs-ports.c | 1111 +--------------------------------------
libguile/r6rs-ports.h | 21 +-
module/ice-9/binary-ports.scm | 7 +-
module/rnrs/io/ports.scm | 9 +-
7 files changed, 1211 insertions(+), 1137 deletions(-)
create mode 100644 libguile/binary-ports.c
create mode 100644 libguile/binary-ports.h
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index e216435..3c0fc8e 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -125,6 +125,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \
async.c \
backtrace.c \
boolean.c \
+ binary-ports.c \
bitvectors.c \
bytevectors.c \
chars.c \
@@ -230,6 +231,7 @@ DOT_X_FILES = \
async.x \
backtrace.x \
boolean.x \
+ binary-ports.x \
bitvectors.x \
bytevectors.x \
chars.x \
diff --git a/libguile/binary-ports.c b/libguile/binary-ports.c
new file mode 100644
index 0000000..b58578b
--- /dev/null
+++ b/libguile/binary-ports.c
@@ -0,0 +1,1152 @@
+/* Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library 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 this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+# include <unistd.h>
+#endif
+
+#include <string.h>
+#include <stdio.h>
+#include <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/bytevectors.h"
+#include "libguile/chars.h"
+#include "libguile/eval.h"
+#include "libguile/r6rs-ports.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/values.h"
+#include "libguile/vectors.h"
+
+
+\f
+/* Unimplemented features. */
+
+
+/* Transoders are currently not implemented since Guile 1.8 is not
+ Unicode-capable. Thus, most of the code here assumes the use of the
+ binary transcoder. */
+static inline void
+transcoders_not_implemented (void)
+{
+ fprintf (stderr, "%s: warning: transcoders not implemented\n",
+ PACKAGE_NAME);
+}
+
+\f
+/* End-of-file object. */
+
+SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0,
+ (void),
+ "Return the end-of-file object.")
+#define FUNC_NAME s_scm_eof_object
+{
+ return (SCM_EOF_VAL);
+}
+#undef FUNC_NAME
+
+\f
+/* Input ports. */
+
+#ifndef MIN
+# define MIN(a,b) ((a) < (b) ? (a) : (b))
+#endif
+
+/* Bytevector input ports or "bip" for short. */
+static scm_t_bits bytevector_input_port_type = 0;
+
+static inline SCM
+make_bip (SCM bv)
+{
+ SCM port;
+ char *c_bv;
+ unsigned c_len;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+
+ port = scm_new_port_table_entry (bytevector_input_port_type);
+ c_port = SCM_PTAB_ENTRY (port);
+
+ /* Match the expectation of `binary-port?'. */
+ c_port->encoding = NULL;
+
+ /* Prevent BV from being GC'd. */
+ SCM_SETSTREAM (port, SCM_UNPACK (bv));
+
+ /* Have the port directly access the bytevector. */
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
+ c_port->read_end = (unsigned char *) c_bv + c_len;
+ c_port->read_buf_size = c_len;
+
+ /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
+ SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits);
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ return port;
+}
+
+static int
+bip_fill_input (SCM port)
+{
+ int result;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ if (c_port->read_pos >= c_port->read_end)
+ result = EOF;
+ else
+ result = (int) *c_port->read_pos;
+
+ return result;
+}
+
+static scm_t_off
+bip_seek (SCM port, scm_t_off offset, int whence)
+#define FUNC_NAME "bip_seek"
+{
+ scm_t_off c_result = 0;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ switch (whence)
+ {
+ case SEEK_CUR:
+ offset += c_port->read_pos - c_port->read_buf;
+ /* Fall through. */
+
+ case SEEK_SET:
+ if (c_port->read_buf + offset <= c_port->read_end)
+ {
+ c_port->read_pos = c_port->read_buf + offset;
+ c_result = offset;
+ }
+ else
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ break;
+
+ case SEEK_END:
+ if (c_port->read_end - offset >= c_port->read_buf)
+ {
+ c_port->read_pos = c_port->read_end - offset;
+ c_result = c_port->read_pos - c_port->read_buf;
+ }
+ else
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ break;
+
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "invalid `seek' parameter");
+ }
+
+ return c_result;
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the bytevector input port type. */
+static inline void
+initialize_bytevector_input_ports (void)
+{
+ bytevector_input_port_type =
+ scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input,
+ NULL);
+
+ scm_set_port_seek (bytevector_input_port_type, bip_seek);
+}
+
+
+SCM_DEFINE (scm_open_bytevector_input_port,
+ "open-bytevector-input-port", 1, 1, 0,
+ (SCM bv, SCM transcoder),
+ "Return an input port whose contents are drawn from "
+ "bytevector @var{bv}.")
+#define FUNC_NAME s_scm_open_bytevector_input_port
+{
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+ if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
+ transcoders_not_implemented ();
+
+ return (make_bip (bv));
+}
+#undef FUNC_NAME
+
+\f
+/* Custom binary ports. The following routines are shared by input and
+ output custom binary ports. */
+
+#define SCM_CBP_GET_POSITION_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
+#define SCM_CBP_SET_POSITION_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
+#define SCM_CBP_CLOSE_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
+
+static scm_t_off
+cbp_seek (SCM port, scm_t_off offset, int whence)
+#define FUNC_NAME "cbp_seek"
+{
+ SCM result;
+ scm_t_off c_result = 0;
+
+ switch (whence)
+ {
+ case SEEK_CUR:
+ {
+ SCM get_position_proc;
+
+ get_position_proc = SCM_CBP_GET_POSITION_PROC (port);
+ if (SCM_LIKELY (scm_is_true (get_position_proc)))
+ result = scm_call_0 (get_position_proc);
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary port does not "
+ "support `port-position'");
+
+ offset += scm_to_int (result);
+ /* Fall through. */
+ }
+
+ case SEEK_SET:
+ {
+ SCM set_position_proc;
+
+ set_position_proc = SCM_CBP_SET_POSITION_PROC (port);
+ if (SCM_LIKELY (scm_is_true (set_position_proc)))
+ result = scm_call_1 (set_position_proc, scm_from_int (offset));
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary port does not "
+ "support `set-port-position!'");
+
+ /* Assuming setting the position succeeded. */
+ c_result = offset;
+ break;
+ }
+
+ default:
+ /* `SEEK_END' cannot be supported. */
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary ports do not "
+ "support `SEEK_END'");
+ }
+
+ return c_result;
+}
+#undef FUNC_NAME
+
+static int
+cbp_close (SCM port)
+{
+ SCM close_proc;
+
+ close_proc = SCM_CBP_CLOSE_PROC (port);
+ if (scm_is_true (close_proc))
+ /* Invoke the `close' thunk. */
+ scm_call_0 (close_proc);
+
+ return 1;
+}
+
+\f
+/* Custom binary input port ("cbip" for short). */
+
+static scm_t_bits custom_binary_input_port_type = 0;
+
+/* Size of the buffer embedded in custom binary input ports. */
+#define CBIP_BUFFER_SIZE 4096
+
+/* Return the bytevector associated with PORT. */
+#define SCM_CBIP_BYTEVECTOR(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
+
+/* Return the various procedures of PORT. */
+#define SCM_CBIP_READ_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
+
+
+static inline SCM
+make_cbip (SCM read_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc)
+{
+ SCM port, bv, method_vector;
+ char *c_bv;
+ unsigned c_len;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
+
+ /* Use a bytevector as the underlying buffer. */
+ c_len = CBIP_BUFFER_SIZE;
+ bv = scm_c_make_bytevector (c_len);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ /* Store the various methods and bytevector in a vector. */
+ method_vector = scm_c_make_vector (5, SCM_BOOL_F);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 4, bv);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 0, read_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+
+ port = scm_new_port_table_entry (custom_binary_input_port_type);
+ c_port = SCM_PTAB_ENTRY (port);
+
+ /* Match the expectation of `binary-port?'. */
+ c_port->encoding = NULL;
+
+ /* Attach it the method vector. */
+ SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
+
+ /* Have the port directly access the buffer (bytevector). */
+ c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
+ c_port->read_end = (unsigned char *) c_bv;
+ c_port->read_buf_size = c_len;
+
+ /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
+ SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ return port;
+}
+
+static int
+cbip_fill_input (SCM port)
+#define FUNC_NAME "cbip_fill_input"
+{
+ int result;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ again:
+ if (c_port->read_pos >= c_port->read_end)
+ {
+ /* Invoke the user's `read!' procedure. */
+ unsigned c_octets;
+ SCM bv, read_proc, octets;
+
+ /* Use the bytevector associated with PORT as the buffer passed to the
+ `read!' procedure, thereby avoiding additional allocations. */
+ bv = SCM_CBIP_BYTEVECTOR (port);
+ read_proc = SCM_CBIP_READ_PROC (port);
+
+ /* The assumption here is that C_PORT's internal buffer wasn't changed
+ behind our back. */
+ assert (c_port->read_buf ==
+ (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv));
+ assert ((unsigned) c_port->read_buf_size
+ == SCM_BYTEVECTOR_LENGTH (bv));
+
+ octets = scm_call_3 (read_proc, bv, SCM_INUM0,
+ SCM_I_MAKINUM (CBIP_BUFFER_SIZE));
+ c_octets = scm_to_uint (octets);
+
+ c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_port->read_end = (unsigned char *) c_port->read_pos + c_octets;
+
+ if (c_octets > 0)
+ goto again;
+ else
+ result = EOF;
+ }
+ else
+ result = (int) *c_port->read_pos;
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_custom_binary_input_port,
+ "make-custom-binary-input-port", 5, 0, 0,
+ (SCM id, SCM read_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc),
+ "Return a new custom binary input port whose input is drained "
+ "by invoking @var{read_proc} and passing it a bytevector, an "
+ "index where octets should be written, and an octet count.")
+#define FUNC_NAME s_scm_make_custom_binary_input_port
+{
+ SCM_VALIDATE_STRING (1, id);
+ SCM_VALIDATE_PROC (2, read_proc);
+
+ if (!scm_is_false (get_position_proc))
+ SCM_VALIDATE_PROC (3, get_position_proc);
+
+ if (!scm_is_false (set_position_proc))
+ SCM_VALIDATE_PROC (4, set_position_proc);
+
+ if (!scm_is_false (close_proc))
+ SCM_VALIDATE_PROC (5, close_proc);
+
+ return (make_cbip (read_proc, get_position_proc, set_position_proc,
+ close_proc));
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the custom binary input port type. */
+static inline void
+initialize_custom_binary_input_ports (void)
+{
+ custom_binary_input_port_type =
+ scm_make_port_type ("r6rs-custom-binary-input-port",
+ cbip_fill_input, NULL);
+
+ scm_set_port_seek (custom_binary_input_port_type, cbp_seek);
+ scm_set_port_close (custom_binary_input_port_type, cbp_close);
+}
+
+
+\f
+/* Binary input. */
+
+/* We currently don't support specific binary input ports. */
+#define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
+
+SCM_DEFINE (scm_get_u8, "get-u8", 1, 0, 0,
+ (SCM port),
+ "Read an octet from @var{port}, a binary input port, "
+ "blocking as necessary.")
+#define FUNC_NAME s_scm_get_u8
+{
+ SCM result;
+ int c_result;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_result = scm_get_byte_or_eof (port);
+ if (c_result == EOF)
+ result = SCM_EOF_VAL;
+ else
+ result = SCM_I_MAKINUM ((unsigned char) c_result);
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_lookahead_u8, "lookahead-u8", 1, 0, 0,
+ (SCM port),
+ "Like @code{get-u8} but does not update @var{port} to "
+ "point past the octet.")
+#define FUNC_NAME s_scm_lookahead_u8
+{
+ int u8;
+ SCM result;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ u8 = scm_peek_byte_or_eof (port);
+ if (u8 == EOF)
+ result = SCM_EOF_VAL;
+ else
+ result = SCM_I_MAKINUM ((scm_t_uint8) u8);
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0,
+ (SCM port, SCM count),
+ "Read @var{count} octets from @var{port}, blocking as "
+ "necessary and return a bytevector containing the octets "
+ "read. If fewer bytes are available, a bytevector smaller "
+ "than @var{count} is returned.")
+#define FUNC_NAME s_scm_get_bytevector_n
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_count;
+ size_t c_read;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+ c_count = scm_to_uint (count);
+
+ result = scm_c_make_bytevector (c_count);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (result);
+
+ if (SCM_LIKELY (c_count > 0))
+ /* XXX: `scm_c_read ()' does not update the port position. */
+ c_read = scm_c_read (port, c_bv, c_count);
+ else
+ /* Don't invoke `scm_c_read ()' since it may block. */
+ c_read = 0;
+
+ if ((c_read == 0) && (c_count > 0))
+ {
+ if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
+ result = SCM_EOF_VAL;
+ else
+ result = scm_null_bytevector;
+ }
+ else
+ {
+ if (c_read < c_count)
+ result = scm_c_shrink_bytevector (result, c_read);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0,
+ (SCM port, SCM bv, SCM start, SCM count),
+ "Read @var{count} bytes from @var{port} and store them "
+ "in @var{bv} starting at index @var{start}. Return either "
+ "the number of bytes actually read or the end-of-file "
+ "object.")
+#define FUNC_NAME s_scm_get_bytevector_n_x
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_start, c_count, c_len;
+ size_t c_read;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+ SCM_VALIDATE_BYTEVECTOR (2, bv);
+ c_start = scm_to_uint (start);
+ c_count = scm_to_uint (count);
+
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ if (SCM_UNLIKELY (c_start + c_count > c_len))
+ scm_out_of_range (FUNC_NAME, count);
+
+ if (SCM_LIKELY (c_count > 0))
+ c_read = scm_c_read (port, c_bv + c_start, c_count);
+ else
+ /* Don't invoke `scm_c_read ()' since it may block. */
+ c_read = 0;
+
+ if ((c_read == 0) && (c_count > 0))
+ {
+ if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
+ result = SCM_EOF_VAL;
+ else
+ result = SCM_I_MAKINUM (0);
+ }
+ else
+ result = scm_from_size_t (c_read);
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
+ (SCM port),
+ "Read from @var{port}, blocking as necessary, until data "
+ "are available or and end-of-file is reached. Return either "
+ "a new bytevector containing the data read or the "
+ "end-of-file object.")
+#define FUNC_NAME s_scm_get_bytevector_some
+{
+ /* Read at least one byte, unless the end-of-file is already reached, and
+ read while characters are available (buffered). */
+
+ SCM result;
+ char *c_bv;
+ unsigned c_len;
+ size_t c_total;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_len = 4096;
+ c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR);
+ c_total = 0;
+
+ do
+ {
+ int c_chr;
+
+ if (c_total + 1 > c_len)
+ {
+ /* Grow the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
+ SCM_GC_BYTEVECTOR);
+ c_len *= 2;
+ }
+
+ /* We can't use `scm_c_read ()' since it blocks. */
+ c_chr = scm_getc (port);
+ if (c_chr != EOF)
+ {
+ c_bv[c_total] = (char) c_chr;
+ c_total++;
+ }
+ }
+ while ((scm_is_true (scm_char_ready_p (port)))
+ && (!SCM_EOF_OBJECT_P (scm_peek_char (port))));
+
+ if (c_total == 0)
+ {
+ result = SCM_EOF_VAL;
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ {
+ if (c_len > c_total)
+ {
+ /* Shrink the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
+ SCM_GC_BYTEVECTOR);
+ c_len = (unsigned) c_total;
+ }
+
+ result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
+ (SCM port),
+ "Read from @var{port}, blocking as necessary, until "
+ "the end-of-file is reached. Return either "
+ "a new bytevector containing the data read or the "
+ "end-of-file object (if no data were available).")
+#define FUNC_NAME s_scm_get_bytevector_all
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_len, c_count;
+ size_t c_read, c_total;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_len = c_count = 4096;
+ c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR);
+ c_total = c_read = 0;
+
+ do
+ {
+ if (c_total + c_read > c_len)
+ {
+ /* Grow the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
+ SCM_GC_BYTEVECTOR);
+ c_count = c_len;
+ c_len *= 2;
+ }
+
+ /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
+ reached. */
+ c_read = scm_c_read (port, c_bv + c_total, c_count);
+ c_total += c_read, c_count -= c_read;
+ }
+ while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
+
+ if (c_total == 0)
+ {
+ result = SCM_EOF_VAL;
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ {
+ if (c_len > c_total)
+ {
+ /* Shrink the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
+ SCM_GC_BYTEVECTOR);
+ c_len = (unsigned) c_total;
+ }
+
+ result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+\f
+/* Binary output. */
+
+/* We currently don't support specific binary input ports. */
+#define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
+
+
+SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0,
+ (SCM port, SCM octet),
+ "Write @var{octet} to binary port @var{port}.")
+#define FUNC_NAME s_scm_put_u8
+{
+ scm_t_uint8 c_octet;
+
+ SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
+ c_octet = scm_to_uint8 (octet);
+
+ scm_putc ((char) c_octet, port);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
+ (SCM port, SCM bv, SCM start, SCM count),
+ "Write the contents of @var{bv} to @var{port}, optionally "
+ "starting at index @var{start} and limiting to @var{count} "
+ "octets.")
+#define FUNC_NAME s_scm_put_bytevector
+{
+ char *c_bv;
+ unsigned c_start, c_count, c_len;
+
+ SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
+ SCM_VALIDATE_BYTEVECTOR (2, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ if (!scm_is_eq (start, SCM_UNDEFINED))
+ {
+ c_start = scm_to_uint (start);
+
+ if (!scm_is_eq (count, SCM_UNDEFINED))
+ {
+ c_count = scm_to_uint (count);
+ if (SCM_UNLIKELY (c_start + c_count > c_len))
+ scm_out_of_range (FUNC_NAME, count);
+ }
+ else
+ {
+ if (SCM_UNLIKELY (c_start >= c_len))
+ scm_out_of_range (FUNC_NAME, start);
+ else
+ c_count = c_len - c_start;
+ }
+ }
+ else
+ c_start = 0, c_count = c_len;
+
+ scm_c_write (port, c_bv + c_start, c_count);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+\f
+/* Bytevector output port ("bop" for short). */
+
+/* Implementation of "bops".
+
+ Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
+ it. The procedure returned along with the output port is actually an
+ applicable SMOB. The SMOB holds a reference to the port. When applied,
+ the SMOB swallows the port's internal buffer, turning it into a
+ bytevector, and resets it.
+
+ XXX: Access to a bop's internal buffer is not thread-safe. */
+
+static scm_t_bits bytevector_output_port_type = 0;
+
+SCM_SMOB (bytevector_output_port_procedure,
+ "r6rs-bytevector-output-port-procedure",
+ 0);
+
+#define SCM_GC_BOP "r6rs-bytevector-output-port"
+#define SCM_BOP_BUFFER_INITIAL_SIZE 4096
+
+/* Representation of a bop's internal buffer. */
+typedef struct
+{
+ size_t total_len;
+ size_t len;
+ size_t pos;
+ char *buffer;
+} scm_t_bop_buffer;
+
+
+/* Accessing a bop's buffer. */
+#define SCM_BOP_BUFFER(_port) \
+ ((scm_t_bop_buffer *) SCM_STREAM (_port))
+#define SCM_SET_BOP_BUFFER(_port, _buf) \
+ (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
+
+
+static inline void
+bop_buffer_init (scm_t_bop_buffer *buf)
+{
+ buf->total_len = buf->len = buf->pos = 0;
+ buf->buffer = NULL;
+}
+
+static inline void
+bop_buffer_grow (scm_t_bop_buffer *buf, size_t min_size)
+{
+ char *new_buf;
+ size_t new_size;
+
+ for (new_size = buf->total_len
+ ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE;
+ new_size < min_size;
+ new_size *= 2);
+
+ if (buf->buffer)
+ new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len,
+ new_size, SCM_GC_BOP);
+ else
+ new_buf = scm_gc_malloc_pointerless (new_size, SCM_GC_BOP);
+
+ buf->buffer = new_buf;
+ buf->total_len = new_size;
+}
+
+static inline SCM
+make_bop (void)
+{
+ SCM port, bop_proc;
+ scm_t_port *c_port;
+ scm_t_bop_buffer *buf;
+ const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
+
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+
+ port = scm_new_port_table_entry (bytevector_output_port_type);
+ c_port = SCM_PTAB_ENTRY (port);
+
+ /* Match the expectation of `binary-port?'. */
+ c_port->encoding = NULL;
+
+ buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
+ bop_buffer_init (buf);
+
+ c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+ c_port->write_buf_size = 0;
+
+ SCM_SET_BOP_BUFFER (port, buf);
+
+ /* Mark PORT as open and writable. */
+ SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ /* Make the bop procedure. */
+ SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, buf);
+
+ return (scm_values (scm_list_2 (port, bop_proc)));
+}
+
+/* Write SIZE octets from DATA to PORT. */
+static void
+bop_write (SCM port, const void *data, size_t size)
+{
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+
+ if (buf->pos + size > buf->total_len)
+ bop_buffer_grow (buf, buf->pos + size);
+
+ memcpy (buf->buffer + buf->pos, data, size);
+ buf->pos += size;
+ buf->len = (buf->len > buf->pos) ? buf->len : buf->pos;
+}
+
+static scm_t_off
+bop_seek (SCM port, scm_t_off offset, int whence)
+#define FUNC_NAME "bop_seek"
+{
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+ switch (whence)
+ {
+ case SEEK_CUR:
+ offset += (scm_t_off) buf->pos;
+ /* Fall through. */
+
+ case SEEK_SET:
+ if (offset < 0 || (unsigned) offset > buf->len)
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ else
+ buf->pos = offset;
+ break;
+
+ case SEEK_END:
+ if (offset < 0 || (unsigned) offset >= buf->len)
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ else
+ buf->pos = buf->len - (offset + 1);
+ break;
+
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "invalid `seek' parameter");
+ }
+
+ return buf->pos;
+}
+#undef FUNC_NAME
+
+/* Fetch data from a bop. */
+SCM_SMOB_APPLY (bytevector_output_port_procedure,
+ bop_proc_apply, 0, 0, 0, (SCM bop_proc))
+{
+ SCM bv;
+ scm_t_bop_buffer *buf, result_buf;
+
+ buf = (scm_t_bop_buffer *) SCM_SMOB_DATA (bop_proc);
+
+ result_buf = *buf;
+ bop_buffer_init (buf);
+
+ if (result_buf.len == 0)
+ bv = scm_c_take_gc_bytevector (NULL, 0);
+ else
+ {
+ if (result_buf.total_len > result_buf.len)
+ /* Shrink the buffer. */
+ result_buf.buffer = scm_gc_realloc ((void *) result_buf.buffer,
+ result_buf.total_len,
+ result_buf.len,
+ SCM_GC_BOP);
+
+ bv = scm_c_take_gc_bytevector ((signed char *) result_buf.buffer,
+ result_buf.len);
+ }
+
+ return bv;
+}
+
+SCM_DEFINE (scm_open_bytevector_output_port,
+ "open-bytevector-output-port", 0, 1, 0,
+ (SCM transcoder),
+ "Return two values: an output port and a procedure. The latter "
+ "should be called with zero arguments to obtain a bytevector "
+ "containing the data accumulated by the port.")
+#define FUNC_NAME s_scm_open_bytevector_output_port
+{
+ if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
+ transcoders_not_implemented ();
+
+ return (make_bop ());
+}
+#undef FUNC_NAME
+
+static inline void
+initialize_bytevector_output_ports (void)
+{
+ bytevector_output_port_type =
+ scm_make_port_type ("r6rs-bytevector-output-port",
+ NULL, bop_write);
+
+ scm_set_port_seek (bytevector_output_port_type, bop_seek);
+}
+
+\f
+/* Custom binary output port ("cbop" for short). */
+
+static scm_t_bits custom_binary_output_port_type;
+
+/* Return the various procedures of PORT. */
+#define SCM_CBOP_WRITE_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
+
+
+static inline SCM
+make_cbop (SCM write_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc)
+{
+ SCM port, method_vector;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
+
+ /* Store the various methods and bytevector in a vector. */
+ method_vector = scm_c_make_vector (4, SCM_BOOL_F);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 0, write_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+
+ port = scm_new_port_table_entry (custom_binary_output_port_type);
+ c_port = SCM_PTAB_ENTRY (port);
+
+ /* Match the expectation of `binary-port?'. */
+ c_port->encoding = NULL;
+
+ /* Attach it the method vector. */
+ SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
+
+ /* Have the port directly access the buffer (bytevector). */
+ c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+ c_port->write_buf_size = c_port->read_buf_size = 0;
+
+ /* Mark PORT as open, writable and unbuffered. */
+ SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits);
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ return port;
+}
+
+/* Write SIZE octets from DATA to PORT. */
+static void
+cbop_write (SCM port, const void *data, size_t size)
+#define FUNC_NAME "cbop_write"
+{
+ long int c_result;
+ size_t c_written;
+ SCM bv, write_proc, result;
+
+ /* XXX: Allocating a new bytevector at each `write' call is inefficient,
+ but necessary since (1) we don't control the lifetime of the buffer
+ pointed to by DATA, and (2) the `write!' procedure could capture the
+ bytevector it is passed. */
+ bv = scm_c_make_bytevector (size);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size);
+
+ write_proc = SCM_CBOP_WRITE_PROC (port);
+
+ /* Since the `write' procedure of Guile's ports has type `void', it must
+ try hard to write exactly SIZE bytes, regardless of how many bytes the
+ sink can handle. */
+ for (c_written = 0;
+ c_written < size;
+ c_written += c_result)
+ {
+ result = scm_call_3 (write_proc, bv,
+ scm_from_size_t (c_written),
+ scm_from_size_t (size - c_written));
+
+ c_result = scm_to_long (result);
+ if (SCM_UNLIKELY (c_result < 0
+ || (size_t) c_result > (size - c_written)))
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, result,
+ "R6RS custom binary output port `write!' "
+ "returned a incorrect integer");
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_custom_binary_output_port,
+ "make-custom-binary-output-port", 5, 0, 0,
+ (SCM id, SCM write_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc),
+ "Return a new custom binary output port whose output is drained "
+ "by invoking @var{write_proc} and passing it a bytevector, an "
+ "index where octets should be written, and an octet count.")
+#define FUNC_NAME s_scm_make_custom_binary_output_port
+{
+ SCM_VALIDATE_STRING (1, id);
+ SCM_VALIDATE_PROC (2, write_proc);
+
+ if (!scm_is_false (get_position_proc))
+ SCM_VALIDATE_PROC (3, get_position_proc);
+
+ if (!scm_is_false (set_position_proc))
+ SCM_VALIDATE_PROC (4, set_position_proc);
+
+ if (!scm_is_false (close_proc))
+ SCM_VALIDATE_PROC (5, close_proc);
+
+ return (make_cbop (write_proc, get_position_proc, set_position_proc,
+ close_proc));
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the custom binary output port type. */
+static inline void
+initialize_custom_binary_output_ports (void)
+{
+ custom_binary_output_port_type =
+ scm_make_port_type ("r6rs-custom-binary-output-port",
+ NULL, cbop_write);
+
+ scm_set_port_seek (custom_binary_output_port_type, cbp_seek);
+ scm_set_port_close (custom_binary_output_port_type, cbp_close);
+}
+
+\f
+/* Textual I/O */
+
+SCM_DEFINE (scm_get_string_n_x,
+ "get-string-n!", 4, 0, 0,
+ (SCM port, SCM str, SCM start, SCM count),
+ "Read up to @var{count} characters from @var{port} into "
+ "@var{str}, starting at @var{start}. If no characters "
+ "can be read before the end of file is encountered, the end "
+ "of file object is returned. Otherwise, the number of "
+ "characters read is returned.")
+#define FUNC_NAME s_scm_get_string_n_x
+{
+ size_t c_start, c_count, c_len, c_end, j;
+ scm_t_wchar c;
+
+ SCM_VALIDATE_OPINPORT (1, port);
+ SCM_VALIDATE_STRING (2, str);
+ c_len = scm_c_string_length (str);
+ c_start = scm_to_size_t (start);
+ c_count = scm_to_size_t (count);
+ c_end = c_start + c_count;
+
+ if (SCM_UNLIKELY (c_end > c_len))
+ scm_out_of_range (FUNC_NAME, count);
+
+ for (j = c_start; j < c_end; j++)
+ {
+ c = scm_getc (port);
+ if (c == EOF)
+ {
+ size_t chars_read = j - c_start;
+ return chars_read == 0 ? SCM_EOF_VAL : scm_from_size_t (chars_read);
+ }
+ scm_c_string_set_x (str, j, SCM_MAKE_CHAR (c));
+ }
+ return count;
+}
+#undef FUNC_NAME
+
+\f
+/* Initialization. */
+
+void
+scm_register_binary_ports (void)
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_binary_ports",
+ (scm_t_extension_init_func) scm_init_binary_ports,
+ NULL);
+}
+
+void
+scm_init_binary_ports (void)
+{
+#include "libguile/binary-ports.x"
+
+ initialize_bytevector_input_ports ();
+ initialize_custom_binary_input_ports ();
+ initialize_bytevector_output_ports ();
+ initialize_custom_binary_output_ports ();
+}
diff --git a/libguile/binary-ports.h b/libguile/binary-ports.h
new file mode 100644
index 0000000..efd7ed9
--- /dev/null
+++ b/libguile/binary-ports.h
@@ -0,0 +1,46 @@
+#ifndef SCM_BINARY_PORTS_H
+#define SCM_BINARY_PORTS_H
+
+/* Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library 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 this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+/* Binary I/O Ports. */
+
+SCM_API SCM scm_eof_object (void);
+SCM_API SCM scm_open_bytevector_input_port (SCM, SCM);
+SCM_API SCM scm_make_custom_binary_input_port (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_get_u8 (SCM);
+SCM_API SCM scm_lookahead_u8 (SCM);
+SCM_API SCM scm_get_bytevector_n (SCM, SCM);
+SCM_API SCM scm_get_bytevector_n_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_get_bytevector_some (SCM);
+SCM_API SCM scm_get_bytevector_all (SCM);
+SCM_API SCM scm_put_u8 (SCM, SCM);
+SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_open_bytevector_output_port (SCM);
+SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_get_string_n_x (SCM, SCM, SCM, SCM);
+
+SCM_API void scm_init_binary_ports (void);
+SCM_INTERNAL void scm_register_binary_ports (void);
+
+#endif /* SCM_BINARY_PORTS_H */
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index e867429..19dea8d 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -20,1073 +20,8 @@
# include <config.h>
#endif
-#ifdef HAVE_UNISTD_H
-# include <unistd.h>
-#endif
-
-#include <string.h>
-#include <stdio.h>
-#include <assert.h>
-
#include "libguile/_scm.h"
-#include "libguile/bytevectors.h"
-#include "libguile/chars.h"
-#include "libguile/eval.h"
#include "libguile/r6rs-ports.h"
-#include "libguile/strings.h"
-#include "libguile/validate.h"
-#include "libguile/values.h"
-#include "libguile/vectors.h"
-
-
-\f
-/* Unimplemented features. */
-
-
-/* Transoders are currently not implemented since Guile 1.8 is not
- Unicode-capable. Thus, most of the code here assumes the use of the
- binary transcoder. */
-static inline void
-transcoders_not_implemented (void)
-{
- fprintf (stderr, "%s: warning: transcoders not implemented\n",
- PACKAGE_NAME);
-}
-
-\f
-/* End-of-file object. */
-
-SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0,
- (void),
- "Return the end-of-file object.")
-#define FUNC_NAME s_scm_eof_object
-{
- return (SCM_EOF_VAL);
-}
-#undef FUNC_NAME
-
-\f
-/* Input ports. */
-
-#ifndef MIN
-# define MIN(a,b) ((a) < (b) ? (a) : (b))
-#endif
-
-/* Bytevector input ports or "bip" for short. */
-static scm_t_bits bytevector_input_port_type = 0;
-
-static inline SCM
-make_bip (SCM bv)
-{
- SCM port;
- char *c_bv;
- unsigned c_len;
- scm_t_port *c_port;
- const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
-
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
-
- port = scm_new_port_table_entry (bytevector_input_port_type);
- c_port = SCM_PTAB_ENTRY (port);
-
- /* Match the expectation of `binary-port?'. */
- c_port->encoding = NULL;
-
- /* Prevent BV from being GC'd. */
- SCM_SETSTREAM (port, SCM_UNPACK (bv));
-
- /* Have the port directly access the bytevector. */
- c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
- c_len = SCM_BYTEVECTOR_LENGTH (bv);
-
- c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
- c_port->read_end = (unsigned char *) c_bv + c_len;
- c_port->read_buf_size = c_len;
-
- /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
- SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits);
-
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
- return port;
-}
-
-static int
-bip_fill_input (SCM port)
-{
- int result;
- scm_t_port *c_port = SCM_PTAB_ENTRY (port);
-
- if (c_port->read_pos >= c_port->read_end)
- result = EOF;
- else
- result = (int) *c_port->read_pos;
-
- return result;
-}
-
-static scm_t_off
-bip_seek (SCM port, scm_t_off offset, int whence)
-#define FUNC_NAME "bip_seek"
-{
- scm_t_off c_result = 0;
- scm_t_port *c_port = SCM_PTAB_ENTRY (port);
-
- switch (whence)
- {
- case SEEK_CUR:
- offset += c_port->read_pos - c_port->read_buf;
- /* Fall through. */
-
- case SEEK_SET:
- if (c_port->read_buf + offset <= c_port->read_end)
- {
- c_port->read_pos = c_port->read_buf + offset;
- c_result = offset;
- }
- else
- scm_out_of_range (FUNC_NAME, scm_from_int (offset));
- break;
-
- case SEEK_END:
- if (c_port->read_end - offset >= c_port->read_buf)
- {
- c_port->read_pos = c_port->read_end - offset;
- c_result = c_port->read_pos - c_port->read_buf;
- }
- else
- scm_out_of_range (FUNC_NAME, scm_from_int (offset));
- break;
-
- default:
- scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
- "invalid `seek' parameter");
- }
-
- return c_result;
-}
-#undef FUNC_NAME
-
-
-/* Instantiate the bytevector input port type. */
-static inline void
-initialize_bytevector_input_ports (void)
-{
- bytevector_input_port_type =
- scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input,
- NULL);
-
- scm_set_port_seek (bytevector_input_port_type, bip_seek);
-}
-
-
-SCM_DEFINE (scm_open_bytevector_input_port,
- "open-bytevector-input-port", 1, 1, 0,
- (SCM bv, SCM transcoder),
- "Return an input port whose contents are drawn from "
- "bytevector @var{bv}.")
-#define FUNC_NAME s_scm_open_bytevector_input_port
-{
- SCM_VALIDATE_BYTEVECTOR (1, bv);
- if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
- transcoders_not_implemented ();
-
- return (make_bip (bv));
-}
-#undef FUNC_NAME
-
-\f
-/* Custom binary ports. The following routines are shared by input and
- output custom binary ports. */
-
-#define SCM_CBP_GET_POSITION_PROC(_port) \
- SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
-#define SCM_CBP_SET_POSITION_PROC(_port) \
- SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
-#define SCM_CBP_CLOSE_PROC(_port) \
- SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
-
-static scm_t_off
-cbp_seek (SCM port, scm_t_off offset, int whence)
-#define FUNC_NAME "cbp_seek"
-{
- SCM result;
- scm_t_off c_result = 0;
-
- switch (whence)
- {
- case SEEK_CUR:
- {
- SCM get_position_proc;
-
- get_position_proc = SCM_CBP_GET_POSITION_PROC (port);
- if (SCM_LIKELY (scm_is_true (get_position_proc)))
- result = scm_call_0 (get_position_proc);
- else
- scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
- "R6RS custom binary port does not "
- "support `port-position'");
-
- offset += scm_to_int (result);
- /* Fall through. */
- }
-
- case SEEK_SET:
- {
- SCM set_position_proc;
-
- set_position_proc = SCM_CBP_SET_POSITION_PROC (port);
- if (SCM_LIKELY (scm_is_true (set_position_proc)))
- result = scm_call_1 (set_position_proc, scm_from_int (offset));
- else
- scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
- "R6RS custom binary port does not "
- "support `set-port-position!'");
-
- /* Assuming setting the position succeeded. */
- c_result = offset;
- break;
- }
-
- default:
- /* `SEEK_END' cannot be supported. */
- scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
- "R6RS custom binary ports do not "
- "support `SEEK_END'");
- }
-
- return c_result;
-}
-#undef FUNC_NAME
-
-static int
-cbp_close (SCM port)
-{
- SCM close_proc;
-
- close_proc = SCM_CBP_CLOSE_PROC (port);
- if (scm_is_true (close_proc))
- /* Invoke the `close' thunk. */
- scm_call_0 (close_proc);
-
- return 1;
-}
-
-\f
-/* Custom binary input port ("cbip" for short). */
-
-static scm_t_bits custom_binary_input_port_type = 0;
-
-/* Size of the buffer embedded in custom binary input ports. */
-#define CBIP_BUFFER_SIZE 4096
-
-/* Return the bytevector associated with PORT. */
-#define SCM_CBIP_BYTEVECTOR(_port) \
- SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
-
-/* Return the various procedures of PORT. */
-#define SCM_CBIP_READ_PROC(_port) \
- SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
-
-
-static inline SCM
-make_cbip (SCM read_proc, SCM get_position_proc,
- SCM set_position_proc, SCM close_proc)
-{
- SCM port, bv, method_vector;
- char *c_bv;
- unsigned c_len;
- scm_t_port *c_port;
- const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
-
- /* Use a bytevector as the underlying buffer. */
- c_len = CBIP_BUFFER_SIZE;
- bv = scm_c_make_bytevector (c_len);
- c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
-
- /* Store the various methods and bytevector in a vector. */
- method_vector = scm_c_make_vector (5, SCM_BOOL_F);
- SCM_SIMPLE_VECTOR_SET (method_vector, 4, bv);
- SCM_SIMPLE_VECTOR_SET (method_vector, 0, read_proc);
- SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
- SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
- SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
-
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
-
- port = scm_new_port_table_entry (custom_binary_input_port_type);
- c_port = SCM_PTAB_ENTRY (port);
-
- /* Match the expectation of `binary-port?'. */
- c_port->encoding = NULL;
-
- /* Attach it the method vector. */
- SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
-
- /* Have the port directly access the buffer (bytevector). */
- c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
- c_port->read_end = (unsigned char *) c_bv;
- c_port->read_buf_size = c_len;
-
- /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
- SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
-
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
- return port;
-}
-
-static int
-cbip_fill_input (SCM port)
-#define FUNC_NAME "cbip_fill_input"
-{
- int result;
- scm_t_port *c_port = SCM_PTAB_ENTRY (port);
-
- again:
- if (c_port->read_pos >= c_port->read_end)
- {
- /* Invoke the user's `read!' procedure. */
- unsigned c_octets;
- SCM bv, read_proc, octets;
-
- /* Use the bytevector associated with PORT as the buffer passed to the
- `read!' procedure, thereby avoiding additional allocations. */
- bv = SCM_CBIP_BYTEVECTOR (port);
- read_proc = SCM_CBIP_READ_PROC (port);
-
- /* The assumption here is that C_PORT's internal buffer wasn't changed
- behind our back. */
- assert (c_port->read_buf ==
- (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv));
- assert ((unsigned) c_port->read_buf_size
- == SCM_BYTEVECTOR_LENGTH (bv));
-
- octets = scm_call_3 (read_proc, bv, SCM_INUM0,
- SCM_I_MAKINUM (CBIP_BUFFER_SIZE));
- c_octets = scm_to_uint (octets);
-
- c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
- c_port->read_end = (unsigned char *) c_port->read_pos + c_octets;
-
- if (c_octets > 0)
- goto again;
- else
- result = EOF;
- }
- else
- result = (int) *c_port->read_pos;
-
- return result;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_make_custom_binary_input_port,
- "make-custom-binary-input-port", 5, 0, 0,
- (SCM id, SCM read_proc, SCM get_position_proc,
- SCM set_position_proc, SCM close_proc),
- "Return a new custom binary input port whose input is drained "
- "by invoking @var{read_proc} and passing it a bytevector, an "
- "index where octets should be written, and an octet count.")
-#define FUNC_NAME s_scm_make_custom_binary_input_port
-{
- SCM_VALIDATE_STRING (1, id);
- SCM_VALIDATE_PROC (2, read_proc);
-
- if (!scm_is_false (get_position_proc))
- SCM_VALIDATE_PROC (3, get_position_proc);
-
- if (!scm_is_false (set_position_proc))
- SCM_VALIDATE_PROC (4, set_position_proc);
-
- if (!scm_is_false (close_proc))
- SCM_VALIDATE_PROC (5, close_proc);
-
- return (make_cbip (read_proc, get_position_proc, set_position_proc,
- close_proc));
-}
-#undef FUNC_NAME
-
-
-/* Instantiate the custom binary input port type. */
-static inline void
-initialize_custom_binary_input_ports (void)
-{
- custom_binary_input_port_type =
- scm_make_port_type ("r6rs-custom-binary-input-port",
- cbip_fill_input, NULL);
-
- scm_set_port_seek (custom_binary_input_port_type, cbp_seek);
- scm_set_port_close (custom_binary_input_port_type, cbp_close);
-}
-
-
-\f
-/* Binary input. */
-
-/* We currently don't support specific binary input ports. */
-#define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
-
-SCM_DEFINE (scm_get_u8, "get-u8", 1, 0, 0,
- (SCM port),
- "Read an octet from @var{port}, a binary input port, "
- "blocking as necessary.")
-#define FUNC_NAME s_scm_get_u8
-{
- SCM result;
- int c_result;
-
- SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
-
- c_result = scm_get_byte_or_eof (port);
- if (c_result == EOF)
- result = SCM_EOF_VAL;
- else
- result = SCM_I_MAKINUM ((unsigned char) c_result);
-
- return result;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_lookahead_u8, "lookahead-u8", 1, 0, 0,
- (SCM port),
- "Like @code{get-u8} but does not update @var{port} to "
- "point past the octet.")
-#define FUNC_NAME s_scm_lookahead_u8
-{
- int u8;
- SCM result;
-
- SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
-
- u8 = scm_peek_byte_or_eof (port);
- if (u8 == EOF)
- result = SCM_EOF_VAL;
- else
- result = SCM_I_MAKINUM ((scm_t_uint8) u8);
-
- return result;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0,
- (SCM port, SCM count),
- "Read @var{count} octets from @var{port}, blocking as "
- "necessary and return a bytevector containing the octets "
- "read. If fewer bytes are available, a bytevector smaller "
- "than @var{count} is returned.")
-#define FUNC_NAME s_scm_get_bytevector_n
-{
- SCM result;
- char *c_bv;
- unsigned c_count;
- size_t c_read;
-
- SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
- c_count = scm_to_uint (count);
-
- result = scm_c_make_bytevector (c_count);
- c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (result);
-
- if (SCM_LIKELY (c_count > 0))
- /* XXX: `scm_c_read ()' does not update the port position. */
- c_read = scm_c_read (port, c_bv, c_count);
- else
- /* Don't invoke `scm_c_read ()' since it may block. */
- c_read = 0;
-
- if ((c_read == 0) && (c_count > 0))
- {
- if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
- result = SCM_EOF_VAL;
- else
- result = scm_null_bytevector;
- }
- else
- {
- if (c_read < c_count)
- result = scm_c_shrink_bytevector (result, c_read);
- }
-
- return result;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0,
- (SCM port, SCM bv, SCM start, SCM count),
- "Read @var{count} bytes from @var{port} and store them "
- "in @var{bv} starting at index @var{start}. Return either "
- "the number of bytes actually read or the end-of-file "
- "object.")
-#define FUNC_NAME s_scm_get_bytevector_n_x
-{
- SCM result;
- char *c_bv;
- unsigned c_start, c_count, c_len;
- size_t c_read;
-
- SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
- SCM_VALIDATE_BYTEVECTOR (2, bv);
- c_start = scm_to_uint (start);
- c_count = scm_to_uint (count);
-
- c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
- c_len = SCM_BYTEVECTOR_LENGTH (bv);
-
- if (SCM_UNLIKELY (c_start + c_count > c_len))
- scm_out_of_range (FUNC_NAME, count);
-
- if (SCM_LIKELY (c_count > 0))
- c_read = scm_c_read (port, c_bv + c_start, c_count);
- else
- /* Don't invoke `scm_c_read ()' since it may block. */
- c_read = 0;
-
- if ((c_read == 0) && (c_count > 0))
- {
- if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
- result = SCM_EOF_VAL;
- else
- result = SCM_I_MAKINUM (0);
- }
- else
- result = scm_from_size_t (c_read);
-
- return result;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
- (SCM port),
- "Read from @var{port}, blocking as necessary, until data "
- "are available or and end-of-file is reached. Return either "
- "a new bytevector containing the data read or the "
- "end-of-file object.")
-#define FUNC_NAME s_scm_get_bytevector_some
-{
- /* Read at least one byte, unless the end-of-file is already reached, and
- read while characters are available (buffered). */
-
- SCM result;
- char *c_bv;
- unsigned c_len;
- size_t c_total;
-
- SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
-
- c_len = 4096;
- c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR);
- c_total = 0;
-
- do
- {
- int c_chr;
-
- if (c_total + 1 > c_len)
- {
- /* Grow the bytevector. */
- c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
- SCM_GC_BYTEVECTOR);
- c_len *= 2;
- }
-
- /* We can't use `scm_c_read ()' since it blocks. */
- c_chr = scm_getc (port);
- if (c_chr != EOF)
- {
- c_bv[c_total] = (char) c_chr;
- c_total++;
- }
- }
- while ((scm_is_true (scm_char_ready_p (port)))
- && (!SCM_EOF_OBJECT_P (scm_peek_char (port))));
-
- if (c_total == 0)
- {
- result = SCM_EOF_VAL;
- scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
- }
- else
- {
- if (c_len > c_total)
- {
- /* Shrink the bytevector. */
- c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
- SCM_GC_BYTEVECTOR);
- c_len = (unsigned) c_total;
- }
-
- result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len);
- }
-
- return result;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
- (SCM port),
- "Read from @var{port}, blocking as necessary, until "
- "the end-of-file is reached. Return either "
- "a new bytevector containing the data read or the "
- "end-of-file object (if no data were available).")
-#define FUNC_NAME s_scm_get_bytevector_all
-{
- SCM result;
- char *c_bv;
- unsigned c_len, c_count;
- size_t c_read, c_total;
-
- SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
-
- c_len = c_count = 4096;
- c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR);
- c_total = c_read = 0;
-
- do
- {
- if (c_total + c_read > c_len)
- {
- /* Grow the bytevector. */
- c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
- SCM_GC_BYTEVECTOR);
- c_count = c_len;
- c_len *= 2;
- }
-
- /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
- reached. */
- c_read = scm_c_read (port, c_bv + c_total, c_count);
- c_total += c_read, c_count -= c_read;
- }
- while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
-
- if (c_total == 0)
- {
- result = SCM_EOF_VAL;
- scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
- }
- else
- {
- if (c_len > c_total)
- {
- /* Shrink the bytevector. */
- c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
- SCM_GC_BYTEVECTOR);
- c_len = (unsigned) c_total;
- }
-
- result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len);
- }
-
- return result;
-}
-#undef FUNC_NAME
-
-
-\f
-/* Binary output. */
-
-/* We currently don't support specific binary input ports. */
-#define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
-
-
-SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0,
- (SCM port, SCM octet),
- "Write @var{octet} to binary port @var{port}.")
-#define FUNC_NAME s_scm_put_u8
-{
- scm_t_uint8 c_octet;
-
- SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
- c_octet = scm_to_uint8 (octet);
-
- scm_putc ((char) c_octet, port);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
- (SCM port, SCM bv, SCM start, SCM count),
- "Write the contents of @var{bv} to @var{port}, optionally "
- "starting at index @var{start} and limiting to @var{count} "
- "octets.")
-#define FUNC_NAME s_scm_put_bytevector
-{
- char *c_bv;
- unsigned c_start, c_count, c_len;
-
- SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
- SCM_VALIDATE_BYTEVECTOR (2, bv);
-
- c_len = SCM_BYTEVECTOR_LENGTH (bv);
- c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
-
- if (!scm_is_eq (start, SCM_UNDEFINED))
- {
- c_start = scm_to_uint (start);
-
- if (!scm_is_eq (count, SCM_UNDEFINED))
- {
- c_count = scm_to_uint (count);
- if (SCM_UNLIKELY (c_start + c_count > c_len))
- scm_out_of_range (FUNC_NAME, count);
- }
- else
- {
- if (SCM_UNLIKELY (c_start >= c_len))
- scm_out_of_range (FUNC_NAME, start);
- else
- c_count = c_len - c_start;
- }
- }
- else
- c_start = 0, c_count = c_len;
-
- scm_c_write (port, c_bv + c_start, c_count);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-\f
-/* Bytevector output port ("bop" for short). */
-
-/* Implementation of "bops".
-
- Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
- it. The procedure returned along with the output port is actually an
- applicable SMOB. The SMOB holds a reference to the port. When applied,
- the SMOB swallows the port's internal buffer, turning it into a
- bytevector, and resets it.
-
- XXX: Access to a bop's internal buffer is not thread-safe. */
-
-static scm_t_bits bytevector_output_port_type = 0;
-
-SCM_SMOB (bytevector_output_port_procedure,
- "r6rs-bytevector-output-port-procedure",
- 0);
-
-#define SCM_GC_BOP "r6rs-bytevector-output-port"
-#define SCM_BOP_BUFFER_INITIAL_SIZE 4096
-
-/* Representation of a bop's internal buffer. */
-typedef struct
-{
- size_t total_len;
- size_t len;
- size_t pos;
- char *buffer;
-} scm_t_bop_buffer;
-
-
-/* Accessing a bop's buffer. */
-#define SCM_BOP_BUFFER(_port) \
- ((scm_t_bop_buffer *) SCM_STREAM (_port))
-#define SCM_SET_BOP_BUFFER(_port, _buf) \
- (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
-
-
-static inline void
-bop_buffer_init (scm_t_bop_buffer *buf)
-{
- buf->total_len = buf->len = buf->pos = 0;
- buf->buffer = NULL;
-}
-
-static inline void
-bop_buffer_grow (scm_t_bop_buffer *buf, size_t min_size)
-{
- char *new_buf;
- size_t new_size;
-
- for (new_size = buf->total_len
- ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE;
- new_size < min_size;
- new_size *= 2);
-
- if (buf->buffer)
- new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len,
- new_size, SCM_GC_BOP);
- else
- new_buf = scm_gc_malloc_pointerless (new_size, SCM_GC_BOP);
-
- buf->buffer = new_buf;
- buf->total_len = new_size;
-}
-
-static inline SCM
-make_bop (void)
-{
- SCM port, bop_proc;
- scm_t_port *c_port;
- scm_t_bop_buffer *buf;
- const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
-
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
-
- port = scm_new_port_table_entry (bytevector_output_port_type);
- c_port = SCM_PTAB_ENTRY (port);
-
- /* Match the expectation of `binary-port?'. */
- c_port->encoding = NULL;
-
- buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
- bop_buffer_init (buf);
-
- c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
- c_port->write_buf_size = 0;
-
- SCM_SET_BOP_BUFFER (port, buf);
-
- /* Mark PORT as open and writable. */
- SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
-
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
- /* Make the bop procedure. */
- SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, buf);
-
- return (scm_values (scm_list_2 (port, bop_proc)));
-}
-
-/* Write SIZE octets from DATA to PORT. */
-static void
-bop_write (SCM port, const void *data, size_t size)
-{
- scm_t_bop_buffer *buf;
-
- buf = SCM_BOP_BUFFER (port);
-
- if (buf->pos + size > buf->total_len)
- bop_buffer_grow (buf, buf->pos + size);
-
- memcpy (buf->buffer + buf->pos, data, size);
- buf->pos += size;
- buf->len = (buf->len > buf->pos) ? buf->len : buf->pos;
-}
-
-static scm_t_off
-bop_seek (SCM port, scm_t_off offset, int whence)
-#define FUNC_NAME "bop_seek"
-{
- scm_t_bop_buffer *buf;
-
- buf = SCM_BOP_BUFFER (port);
- switch (whence)
- {
- case SEEK_CUR:
- offset += (scm_t_off) buf->pos;
- /* Fall through. */
-
- case SEEK_SET:
- if (offset < 0 || (unsigned) offset > buf->len)
- scm_out_of_range (FUNC_NAME, scm_from_int (offset));
- else
- buf->pos = offset;
- break;
-
- case SEEK_END:
- if (offset < 0 || (unsigned) offset >= buf->len)
- scm_out_of_range (FUNC_NAME, scm_from_int (offset));
- else
- buf->pos = buf->len - (offset + 1);
- break;
-
- default:
- scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
- "invalid `seek' parameter");
- }
-
- return buf->pos;
-}
-#undef FUNC_NAME
-
-/* Fetch data from a bop. */
-SCM_SMOB_APPLY (bytevector_output_port_procedure,
- bop_proc_apply, 0, 0, 0, (SCM bop_proc))
-{
- SCM bv;
- scm_t_bop_buffer *buf, result_buf;
-
- buf = (scm_t_bop_buffer *) SCM_SMOB_DATA (bop_proc);
-
- result_buf = *buf;
- bop_buffer_init (buf);
-
- if (result_buf.len == 0)
- bv = scm_c_take_gc_bytevector (NULL, 0);
- else
- {
- if (result_buf.total_len > result_buf.len)
- /* Shrink the buffer. */
- result_buf.buffer = scm_gc_realloc ((void *) result_buf.buffer,
- result_buf.total_len,
- result_buf.len,
- SCM_GC_BOP);
-
- bv = scm_c_take_gc_bytevector ((signed char *) result_buf.buffer,
- result_buf.len);
- }
-
- return bv;
-}
-
-SCM_DEFINE (scm_open_bytevector_output_port,
- "open-bytevector-output-port", 0, 1, 0,
- (SCM transcoder),
- "Return two values: an output port and a procedure. The latter "
- "should be called with zero arguments to obtain a bytevector "
- "containing the data accumulated by the port.")
-#define FUNC_NAME s_scm_open_bytevector_output_port
-{
- if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
- transcoders_not_implemented ();
-
- return (make_bop ());
-}
-#undef FUNC_NAME
-
-static inline void
-initialize_bytevector_output_ports (void)
-{
- bytevector_output_port_type =
- scm_make_port_type ("r6rs-bytevector-output-port",
- NULL, bop_write);
-
- scm_set_port_seek (bytevector_output_port_type, bop_seek);
-}
-
-\f
-/* Custom binary output port ("cbop" for short). */
-
-static scm_t_bits custom_binary_output_port_type;
-
-/* Return the various procedures of PORT. */
-#define SCM_CBOP_WRITE_PROC(_port) \
- SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
-
-
-static inline SCM
-make_cbop (SCM write_proc, SCM get_position_proc,
- SCM set_position_proc, SCM close_proc)
-{
- SCM port, method_vector;
- scm_t_port *c_port;
- const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
-
- /* Store the various methods and bytevector in a vector. */
- method_vector = scm_c_make_vector (4, SCM_BOOL_F);
- SCM_SIMPLE_VECTOR_SET (method_vector, 0, write_proc);
- SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
- SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
- SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
-
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
-
- port = scm_new_port_table_entry (custom_binary_output_port_type);
- c_port = SCM_PTAB_ENTRY (port);
-
- /* Match the expectation of `binary-port?'. */
- c_port->encoding = NULL;
-
- /* Attach it the method vector. */
- SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
-
- /* Have the port directly access the buffer (bytevector). */
- c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
- c_port->write_buf_size = c_port->read_buf_size = 0;
-
- /* Mark PORT as open, writable and unbuffered. */
- SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits);
-
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
- return port;
-}
-
-/* Write SIZE octets from DATA to PORT. */
-static void
-cbop_write (SCM port, const void *data, size_t size)
-#define FUNC_NAME "cbop_write"
-{
- long int c_result;
- size_t c_written;
- SCM bv, write_proc, result;
-
- /* XXX: Allocating a new bytevector at each `write' call is inefficient,
- but necessary since (1) we don't control the lifetime of the buffer
- pointed to by DATA, and (2) the `write!' procedure could capture the
- bytevector it is passed. */
- bv = scm_c_make_bytevector (size);
- memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size);
-
- write_proc = SCM_CBOP_WRITE_PROC (port);
-
- /* Since the `write' procedure of Guile's ports has type `void', it must
- try hard to write exactly SIZE bytes, regardless of how many bytes the
- sink can handle. */
- for (c_written = 0;
- c_written < size;
- c_written += c_result)
- {
- result = scm_call_3 (write_proc, bv,
- scm_from_size_t (c_written),
- scm_from_size_t (size - c_written));
-
- c_result = scm_to_long (result);
- if (SCM_UNLIKELY (c_result < 0
- || (size_t) c_result > (size - c_written)))
- scm_wrong_type_arg_msg (FUNC_NAME, 0, result,
- "R6RS custom binary output port `write!' "
- "returned a incorrect integer");
- }
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_make_custom_binary_output_port,
- "make-custom-binary-output-port", 5, 0, 0,
- (SCM id, SCM write_proc, SCM get_position_proc,
- SCM set_position_proc, SCM close_proc),
- "Return a new custom binary output port whose output is drained "
- "by invoking @var{write_proc} and passing it a bytevector, an "
- "index where octets should be written, and an octet count.")
-#define FUNC_NAME s_scm_make_custom_binary_output_port
-{
- SCM_VALIDATE_STRING (1, id);
- SCM_VALIDATE_PROC (2, write_proc);
-
- if (!scm_is_false (get_position_proc))
- SCM_VALIDATE_PROC (3, get_position_proc);
-
- if (!scm_is_false (set_position_proc))
- SCM_VALIDATE_PROC (4, set_position_proc);
-
- if (!scm_is_false (close_proc))
- SCM_VALIDATE_PROC (5, close_proc);
-
- return (make_cbop (write_proc, get_position_proc, set_position_proc,
- close_proc));
-}
-#undef FUNC_NAME
-
-
-/* Instantiate the custom binary output port type. */
-static inline void
-initialize_custom_binary_output_ports (void)
-{
- custom_binary_output_port_type =
- scm_make_port_type ("r6rs-custom-binary-output-port",
- NULL, cbop_write);
-
- scm_set_port_seek (custom_binary_output_port_type, cbp_seek);
- scm_set_port_close (custom_binary_output_port_type, cbp_close);
-}
\f
/* Transcoded ports ("tp" for short). */
@@ -1240,46 +175,6 @@ SCM_DEFINE (scm_i_make_transcoded_port,
#undef FUNC_NAME
\f
-/* Textual I/O */
-
-SCM_DEFINE (scm_get_string_n_x,
- "get-string-n!", 4, 0, 0,
- (SCM port, SCM str, SCM start, SCM count),
- "Read up to @var{count} characters from @var{port} into "
- "@var{str}, starting at @var{start}. If no characters "
- "can be read before the end of file is encountered, the end "
- "of file object is returned. Otherwise, the number of "
- "characters read is returned.")
-#define FUNC_NAME s_scm_get_string_n_x
-{
- size_t c_start, c_count, c_len, c_end, j;
- scm_t_wchar c;
-
- SCM_VALIDATE_OPINPORT (1, port);
- SCM_VALIDATE_STRING (2, str);
- c_len = scm_c_string_length (str);
- c_start = scm_to_size_t (start);
- c_count = scm_to_size_t (count);
- c_end = c_start + c_count;
-
- if (SCM_UNLIKELY (c_end > c_len))
- scm_out_of_range (FUNC_NAME, count);
-
- for (j = c_start; j < c_end; j++)
- {
- c = scm_getc (port);
- if (c == EOF)
- {
- size_t chars_read = j - c_start;
- return chars_read == 0 ? SCM_EOF_VAL : scm_from_size_t (chars_read);
- }
- scm_c_string_set_x (str, j, SCM_MAKE_CHAR (c));
- }
- return count;
-}
-#undef FUNC_NAME
-
-\f
/* Initialization. */
void
@@ -1296,9 +191,5 @@ scm_init_r6rs_ports (void)
{
#include "libguile/r6rs-ports.x"
- initialize_bytevector_input_ports ();
- initialize_custom_binary_input_ports ();
- initialize_bytevector_output_ports ();
- initialize_custom_binary_output_ports ();
initialize_transcoded_ports ();
}
diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h
index 2ae3e76..682abcf 100644
--- a/libguile/r6rs-ports.h
+++ b/libguile/r6rs-ports.h
@@ -1,7 +1,7 @@
#ifndef SCM_R6RS_PORTS_H
#define SCM_R6RS_PORTS_H
-/* Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -21,24 +21,7 @@
\f
-#include "libguile/__scm.h"
-
-/* R6RS I/O Ports. */
-
-SCM_API SCM scm_eof_object (void);
-SCM_API SCM scm_open_bytevector_input_port (SCM, SCM);
-SCM_API SCM scm_make_custom_binary_input_port (SCM, SCM, SCM, SCM, SCM);
-SCM_API SCM scm_get_u8 (SCM);
-SCM_API SCM scm_lookahead_u8 (SCM);
-SCM_API SCM scm_get_bytevector_n (SCM, SCM);
-SCM_API SCM scm_get_bytevector_n_x (SCM, SCM, SCM, SCM);
-SCM_API SCM scm_get_bytevector_some (SCM);
-SCM_API SCM scm_get_bytevector_all (SCM);
-SCM_API SCM scm_put_u8 (SCM, SCM);
-SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM);
-SCM_API SCM scm_open_bytevector_output_port (SCM);
-SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM);
-SCM_API SCM scm_get_string_n_x (SCM, SCM, SCM, SCM);
+#include "libguile/binary-ports.h"
SCM_API void scm_init_r6rs_ports (void);
SCM_INTERNAL void scm_register_r6rs_ports (void);
diff --git a/module/ice-9/binary-ports.scm b/module/ice-9/binary-ports.scm
index c07900b..59450ac 100644
--- a/module/ice-9/binary-ports.scm
+++ b/module/ice-9/binary-ports.scm
@@ -1,6 +1,6 @@
;;;; binary-ports.scm --- Binary IO on ports
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -43,8 +43,5 @@
open-bytevector-output-port
make-custom-binary-output-port))
-;; Note that this extension also defines %make-transcoded-port, which is
-;; not exported but is used by (rnrs io ports).
-
(load-extension (string-append "libguile-" (effective-version))
- "scm_init_r6rs_ports")
+ "scm_init_binary_ports")
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 7c17b0c..ee8c05a 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -1,6 +1,6 @@
;;;; ports.scm --- R6RS port API -*- coding: utf-8 -*-
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -118,6 +118,10 @@
guile:))
+(eval-when (load eval compile)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_r6rs_ports"))
+
\f
;;;
;;; Auxiliary types
@@ -253,8 +257,7 @@ Guile."
"Return a new textual port based on @var{port}, using
@var{transcoder} to encode and decode data written to or
read from its underlying binary port @var{port}."
- ;; Hackily get at %make-transcoded-port.
- (let ((result ((@@ (ice-9 binary-ports) %make-transcoded-port) port)))
+ (let ((result (%make-transcoded-port port)))
(set-port-encoding! result (transcoder-codec transcoder))
(case (transcoder-error-handling-mode transcoder)
((raise)
--
1.7.10.4
^ permalink raw reply related [flat|nested] 15+ messages in thread