[guile-r6rs-libs.git] / src / ports.c

/* Guile-R6RS-Libs --- Implementation of R6RS standard libraries.
   Copyright (C) 2007, 2008, 2009  Ludovic Courtès <ludo@gnu.org>

   Guile-R6RS-Libs 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 2.1 of the License, or (at your option) any later version.

   Guile-R6RS-Libs 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-R6RS-Libs; 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

#include "compat.h"

#include <libguile.h>
#include <string.h>
#include <stdio.h>
#include <assert.h>

#include "ports.h"
#include "bytevector.h"
#include "utils.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_r6rs_eof_object, "eof-object", 0, 0, 0,
            (void),
            "Return the end-of-file object.")
#define FUNC_NAME s_scm_r6rs_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;

  port = scm_new_port_table_entry (bytevector_input_port_type);

  /* Prevent BV from being GC'd.  */
  SCM_SETSTREAM (port, SCM_UNPACK (bv));

  /* Have the port directly access the bytevector.  */
  c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
  c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);

  c_port = SCM_PTAB_ENTRY (port);
  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);

  return port;
}

static SCM
bip_mark (SCM port)
{
  /* Mark the underlying bytevector.  */
  return (SCM_PACK (SCM_STREAM (port)));
}

#ifndef HAVE_SCM_SET_PORT_READ

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;
}

#else /* HAVE_SCM_SET_PORT_READ */

static size_t
bip_read (SCM port, void *buffer, size_t size)
{
  size_t remaining, count;
  scm_t_port *c_port = SCM_PTAB_ENTRY (port);

  remaining = c_port->read_end - c_port->read_pos;
  count = MIN (remaining, size);

  memcpy (buffer, c_port->read_pos, count);
  c_port->read_pos += count;

  return count;
}

#endif /* HAVE_SCM_SET_PORT_READ */

static off_t
bip_seek (SCM port, off_t offset, int whence)
#define FUNC_NAME "bip_seek"
{
  off_t 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",
                        PORT_FILL_INPUT_METHOD (bip_fill_input),
                        NULL);

  scm_set_port_read (bytevector_input_port_type, bip_read);
  scm_set_port_mark (bytevector_input_port_type, bip_mark);
  scm_set_port_seek (bytevector_input_port_type, bip_seek);
}


SCM_DEFINE (scm_r6rs_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_r6rs_open_bytevector_input_port
{
  SCM_VALIDATE_R6RS_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_R6RS_CBP_GET_POSITION_PROC(_port)                   \
  SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
#define SCM_R6RS_CBP_SET_POSITION_PROC(_port)                   \
  SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
#define SCM_R6RS_CBP_CLOSE_PROC(_port)                          \
  SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)

static SCM
cbp_mark (SCM port)
{
  /* Mark the underlying method and object vector.  */
  return (SCM_PACK (SCM_STREAM (port)));
}

static off_t
cbp_seek (SCM port, off_t offset, int whence)
#define FUNC_NAME "cbp_seek"
{
  SCM result;
  off_t c_result = 0;

  switch (whence)
    {
    case SEEK_CUR:
      {
        SCM get_position_proc;

        get_position_proc = SCM_R6RS_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_R6RS_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_R6RS_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_R6RS_CBIP_BYTEVECTOR(_port)                         \
  SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)

/* Return the various procedures of PORT.  */
#define SCM_R6RS_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_r6rs_c_make_bytevector (c_len);
  c_bv = (char *) SCM_R6RS_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);

  port = scm_new_port_table_entry (custom_binary_input_port_type);

  /* Attach it the method vector.  */
  SCM_SETSTREAM (port, SCM_UNPACK (method_vector));

  /* Have the port directly access the buffer (bytevector).  */
  c_port = SCM_PTAB_ENTRY (port);
  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);

  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_R6RS_CBIP_BYTEVECTOR (port);
      read_proc = SCM_R6RS_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_R6RS_BYTEVECTOR_CONTENTS (bv));
      assert ((unsigned) c_port->read_buf_size
              == SCM_R6RS_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_R6RS_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_r6rs_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_r6rs_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_mark (custom_binary_input_port_type, cbp_mark);
  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_R6RS_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT

SCM_DEFINE (scm_r6rs_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_r6rs_get_u8
{
  SCM result;
  int c_result;

  SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);

  c_result = scm_getc (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_r6rs_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_r6rs_lookahead_u8
{
  SCM result;

  SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);

  result = scm_peek_char (port);
  if (SCM_CHARP (result))
    result = SCM_I_MAKINUM ((signed char) SCM_CHAR (result));
  else
    result = SCM_EOF_VAL;

  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_r6rs_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_r6rs_get_bytevector_n
{
  SCM result;
  char *c_bv;
  unsigned c_count;
  size_t c_read;

  SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
  c_count = scm_to_uint (count);

  result = scm_r6rs_c_make_bytevector (c_count);
  c_bv = (char *) SCM_R6RS_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_r6rs_null_bytevector;
    }
  else
    {
      if (c_read < c_count)
        result = scm_r6rs_c_shrink_bytevector (result, c_read);
    }

  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_r6rs_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_r6rs_get_bytevector_n_x
{
  SCM result;
  char *c_bv;
  unsigned c_start, c_count, c_len;
  size_t c_read;

  SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);
  SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv);
  c_start = scm_to_uint (start);
  c_count = scm_to_uint (count);

  c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);
  c_len = SCM_R6RS_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_r6rs_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_r6rs_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_R6RS_BINARY_INPUT_PORT (1, port);

  c_len = 4096;
  c_bv = (char *) scm_gc_malloc (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_r6rs_c_take_bytevector ((signed char *) c_bv, c_len);
    }

  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_r6rs_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_r6rs_get_bytevector_all
{
  SCM result;
  char *c_bv;
  unsigned c_len, c_count;
  size_t c_read, c_total;

  SCM_VALIDATE_R6RS_BINARY_INPUT_PORT (1, port);

  c_len = c_count = 4096;
  c_bv = (char *) scm_gc_malloc (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_r6rs_c_take_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_R6RS_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT


SCM_DEFINE (scm_r6rs_put_u8, "put-u8", 2, 0, 0,
            (SCM port, SCM octet),
            "Write @var{octet} to binary port @var{port}.")
#define FUNC_NAME s_scm_r6rs_put_u8
{
  scm_t_uint8 c_octet;

  SCM_VALIDATE_R6RS_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_r6rs_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_r6rs_put_bytevector
{
  char *c_bv;
  unsigned c_start, c_count, c_len;

  SCM_VALIDATE_R6RS_BINARY_OUTPUT_PORT (1, port);
  SCM_VALIDATE_R6RS_BYTEVECTOR (2, bv);

  c_len = SCM_R6RS_BYTEVECTOR_LENGTH (bv);
  c_bv = (char *) SCM_R6RS_BYTEVECTOR_CONTENTS (bv);

  if (start != SCM_UNDEFINED)
    {
      c_start = scm_to_uint (start);

      if (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_R6RS_BOP_BUFFER(_port)              \
  ((scm_t_bop_buffer *) SCM_STREAM (_port))
#define SCM_R6RS_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 (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;

  port = scm_new_port_table_entry (bytevector_output_port_type);

  buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
  bop_buffer_init (buf);

  c_port = SCM_PTAB_ENTRY (port);
  c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
  c_port->write_buf_size = 0;

  SCM_R6RS_SET_BOP_BUFFER (port, buf);

  /* Mark PORT as open and writable.  */
  SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);

  /* Make the bop procedure.  */
  SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure,
               SCM_PACK (port));

  return (scm_values (scm_list_2 (port, bop_proc)));
}

static size_t
bop_free (SCM port)
{
  /* The port itself is necessarily freed _after_ the bop proc, since the bop
     proc holds a reference to it.  Thus we can safely free the internal
     buffer when the bop becomes unreferenced.  */
  scm_t_bop_buffer *buf;

  buf = SCM_R6RS_BOP_BUFFER (port);
  if (buf->buffer)
    scm_gc_free (buf->buffer, buf->total_len, SCM_GC_BOP);

  scm_gc_free (buf, sizeof (* buf), SCM_GC_BOP);

  return 0;
}

/* 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_R6RS_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 off_t
bop_seek (SCM port, off_t offset, int whence)
#define FUNC_NAME "bop_seek"
{
  scm_t_bop_buffer *buf;

  buf = SCM_R6RS_BOP_BUFFER (port);
  switch (whence)
    {
    case SEEK_CUR:
      offset += (off_t) 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 port, bv;
  scm_t_bop_buffer *buf, result_buf;

  port = SCM_PACK (SCM_SMOB_DATA (bop_proc));
  buf = SCM_R6RS_BOP_BUFFER (port);

  result_buf = *buf;
  bop_buffer_init (buf);

  if (result_buf.len == 0)
    bv = scm_r6rs_c_take_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_r6rs_c_take_bytevector ((signed char *) result_buf.buffer,
                                       result_buf.len);
    }

  return bv;
}

SCM_SMOB_MARK (bytevector_output_port_procedure, bop_proc_mark,
               bop_proc)
{
  /* Mark the port associated with BOP_PROC.  */
  return (SCM_PACK (SCM_SMOB_DATA (bop_proc)));
}


SCM_DEFINE (scm_r6rs_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 scm_r6rs_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);
  scm_set_port_free (bytevector_output_port_type, bop_free);
}

\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_R6RS_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);

  port = scm_new_port_table_entry (custom_binary_output_port_type);

  /* Attach it the method vector.  */
  SCM_SETSTREAM (port, SCM_UNPACK (method_vector));

  /* Have the port directly access the buffer (bytevector).  */
  c_port = SCM_PTAB_ENTRY (port);
  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);

  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_r6rs_c_make_bytevector (size);
  memcpy (SCM_R6RS_BYTEVECTOR_CONTENTS (bv), data, size);

  write_proc = SCM_R6RS_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_r6rs_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_r6rs_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_mark (custom_binary_output_port_type, cbp_mark);
  scm_set_port_seek (custom_binary_output_port_type, cbp_seek);
  scm_set_port_close (custom_binary_output_port_type, cbp_close);
}

\f
/* Initialization.  */

void
scm_init_r6rs_ports (void)
{
#include "ports.x"

  initialize_bytevector_input_ports ();
  initialize_custom_binary_input_ports ();
  initialize_bytevector_output_ports ();
  initialize_custom_binary_output_ports ();
}