code:
/* Copyright (C) 2009 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"

/* 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);
}

/* 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

/* 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_BYTEVECTOR_CONTENTS (bv);
  c_len = SCM_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 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

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

/* 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);

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

/* 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_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_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
{
  SCM result;

  SCM_VALIDATE_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_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_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_bytevector ((signed char *) c_bv, c_len);
    }

  return result;
}
#undef FUNC_NAME

/* 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 (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

/* 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;

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

/* 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 port, bv;
  scm_t_bop_buffer *buf, result_buf;

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

  result_buf = *buf;
  bop_buffer_init (buf);

  if (result_buf.len == 0)
    bv = scm_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_c_take_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);
}

/* 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);

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

/* Initialization.  */

void
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 ();
}


code:
#ifndef SCM_R6RS_PORTS_H
#define SCM_R6RS_PORTS_H

/* Copyright (C) 2009 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
 */

#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 void scm_init_r6rs_ports (void);

#endif /* SCM_R6RS_PORTS_H */

license: mit


code:
/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 2009, 2010 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
 */

/* Author: Mikael Djurfeldt <djurfeldt@nada.kth.se> */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include "libguile/_scm.h"

#include <gmp.h>
#include <stdio.h>
#include <math.h>
#include <string.h>
#include "libguile/smob.h"
#include "libguile/numbers.h"
#include "libguile/feature.h"
#include "libguile/strings.h"
#include "libguile/arrays.h"
#include "libguile/srfi-4.h"
#include "libguile/vectors.h"
#include "libguile/generalized-vectors.h"

#include "libguile/validate.h"
#include "libguile/random.h"

/*
 * A plugin interface for RNGs
 *
 * Using this interface, it is possible for the application to tell
 * libguile to use a different RNG.  This is desirable if it is
 * necessary to use the same RNG everywhere in the application in
 * order to prevent interference, if the application uses RNG
 * hardware, or if the application has special demands on the RNG.
 *
 * Look in random.h and how the default generator is "plugged in" in
 * scm_init_random().
 */

scm_t_rng scm_the_rng;

/*
 * The prepackaged RNG
 *
 * This is the MWC (Multiply With Carry) random number generator
 * described by George Marsaglia at the Department of Statistics and
 * Supercomputer Computations Research Institute, The Florida State
 * University (http://stat.fsu.edu/~geo).
 *
 * It uses 64 bits, has a period of 4578426017172946943 (4.6e18), and
 * passes all tests in the DIEHARD test suite
 * (http://stat.fsu.edu/~geo/diehard.html)
 */

typedef struct scm_t_i_rstate {
  scm_t_rstate rstate;
  scm_t_uint32 w;
  scm_t_uint32 c;
} scm_t_i_rstate;

#define A 2131995753UL

#ifndef M_PI
#define M_PI 3.14159265359
#endif

static scm_t_uint32
scm_i_uniform32 (scm_t_rstate *state)
{
  scm_t_i_rstate *istate = (scm_t_i_rstate*) state;
  scm_t_uint64 x = (scm_t_uint64) A * istate->w + istate->c;
  scm_t_uint32 w = x & 0xffffffffUL;
  istate->w = w;
  istate->c = x >> 32L;
  return w;
}

static void
scm_i_init_rstate (scm_t_rstate *state, const char *seed, int n)
{
  scm_t_i_rstate *istate = (scm_t_i_rstate*) state;
  scm_t_uint32 w = 0L;
  scm_t_uint32 c = 0L;
  int i, m;
  for (i = 0; i < n; ++i)
    {
      m = i % 8;
      if (m < 4)
	w += seed[i] << (8 * m);
      else
        c += seed[i] << (8 * (m - 4));
    }
  if ((w == 0 && c == 0) || (w == -1 && c == A - 1))
    ++c;
  istate->w = w;
  istate->c = c;
}

static scm_t_rstate *
scm_i_copy_rstate (scm_t_rstate *state)
{
  scm_t_rstate *new_state;

  new_state = scm_gc_malloc_pointerless (state->rng->rstate_size,
					 "random-state");
  return memcpy (new_state, state, state->rng->rstate_size);
}

SCM_SYMBOL(scm_i_rstate_tag, "multiply-with-carry");

static void
scm_i_rstate_from_datum (scm_t_rstate *state, SCM value)
#define FUNC_NAME "scm_i_rstate_from_datum"
{
  scm_t_i_rstate *istate = (scm_t_i_rstate*) state;
  scm_t_uint32 w, c;
  long length;

  SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, value, length);
  SCM_ASSERT (length == 3, value, SCM_ARG1, FUNC_NAME);
  SCM_ASSERT (scm_is_eq (SCM_CAR (value), scm_i_rstate_tag),
              value, SCM_ARG1, FUNC_NAME);
  SCM_VALIDATE_UINT_COPY (SCM_ARG1, SCM_CADR (value), w);
  SCM_VALIDATE_UINT_COPY (SCM_ARG1, SCM_CADDR (value), c);

  istate->w = w;
  istate->c = c;
}
#undef FUNC_NAME

static SCM
scm_i_rstate_to_datum (scm_t_rstate *state)
{
  scm_t_i_rstate *istate = (scm_t_i_rstate*) state;
  return scm_list_3 (scm_i_rstate_tag,
                     scm_from_uint32 (istate->w),
                     scm_from_uint32 (istate->c));
}

/*
 * Random number library functions
 */

scm_t_rstate *
scm_c_make_rstate (const char *seed, int n)
{
  scm_t_rstate *state;

  state = scm_gc_malloc_pointerless (scm_the_rng.rstate_size,
				     "random-state");
  state->rng = &scm_the_rng;
  state->normal_next = 0.0;
  state->rng->init_rstate (state, seed, n);
  return state;
}

scm_t_rstate *
scm_c_rstate_from_datum (SCM datum)
{
  scm_t_rstate *state;

  state = scm_gc_malloc_pointerless (scm_the_rng.rstate_size,
				     "random-state");
  state->rng = &scm_the_rng;
  state->normal_next = 0.0;
  state->rng->from_datum (state, datum);
  return state;
}

scm_t_rstate *
scm_c_default_rstate ()
#define FUNC_NAME "scm_c_default_rstate"
{
  SCM state = SCM_VARIABLE_REF (scm_var_random_state);
  if (!SCM_RSTATEP (state))
    SCM_MISC_ERROR ("*random-state* contains bogus random state", SCM_EOL);
  return SCM_RSTATE (state);
}
#undef FUNC_NAME

double
scm_c_uniform01 (scm_t_rstate *state)
{
  double x = (double) state->rng->random_bits (state) / (double) 0xffffffffUL;
  return ((x + (double) state->rng->random_bits (state))
	  / (double) 0xffffffffUL);
}

double
scm_c_normal01 (scm_t_rstate *state)
{
  if (state->normal_next != 0.0)
    {
      double ret = state->normal_next;

      state->normal_next = 0.0;

      return ret;
    }
  else
    {
      double r, a, n;

      r = sqrt (-2.0 * log (scm_c_uniform01 (state)));
      a = 2.0 * M_PI * scm_c_uniform01 (state);

      n = r * sin (a);
      state->normal_next = r * cos (a);

      return n;
    }
}

double
scm_c_exp1 (scm_t_rstate *state)
{
  return - log (scm_c_uniform01 (state));
}

unsigned char scm_masktab[256];

static inline scm_t_uint32
scm_i_mask32 (scm_t_uint32 m)
{
  return (m < 0x100
	  ? scm_masktab[m]
	  : (m < 0x10000
	     ? scm_masktab[m >> 8] << 8 | 0xff
	     : (m < 0x1000000
		? scm_masktab[m >> 16] << 16 | 0xffff
		: scm_masktab[m >> 24] << 24 | 0xffffff)));
}

scm_t_uint32
scm_c_random (scm_t_rstate *state, scm_t_uint32 m)
{
  scm_t_uint32 r, mask = scm_i_mask32 (m);
  while ((r = state->rng->random_bits (state) & mask) >= m);
  return r;
}

scm_t_uint64
scm_c_random64 (scm_t_rstate *state, scm_t_uint64 m)
{
  scm_t_uint64 r;
  scm_t_uint32 mask;

  if (m <= SCM_T_UINT32_MAX)
    return scm_c_random (state, (scm_t_uint32) m);

  mask = scm_i_mask32 (m >> 32);
  while ((r = ((scm_t_uint64) (state->rng->random_bits (state) & mask) << 32)
          | state->rng->random_bits (state)) >= m)
    ;
  return r;
}

/*
  SCM scm_c_random_bignum (scm_t_rstate *state, SCM m)

  Takes a random state (source of random bits) and a bignum m.
  Returns a bignum b, 0 <= b < m.

  It does this by allocating a bignum b with as many base 65536 digits
  as m, filling b with random bits (in 32 bit chunks) up to the most
  significant 1 in m, and, finally checking if the resultant b is too
  large (>= m).  If too large, we simply repeat the process again.  (It
  is important to throw away all generated random bits if b >= m,
  otherwise we'll end up with a distorted distribution.)

*/

SCM
scm_c_random_bignum (scm_t_rstate *state, SCM m)
{
  SCM result = scm_i_mkbig ();
  const size_t m_bits = mpz_sizeinbase (SCM_I_BIG_MPZ (m), 2);
  /* how many bits would only partially fill the last scm_t_uint32? */
  const size_t end_bits = m_bits % (sizeof (scm_t_uint32) * SCM_CHAR_BIT);
  scm_t_uint32 *random_chunks = NULL;
  const scm_t_uint32 num_full_chunks =
    m_bits / (sizeof (scm_t_uint32) * SCM_CHAR_BIT);
  const scm_t_uint32 num_chunks = num_full_chunks + ((end_bits) ? 1 : 0);

  /* we know the result will be this big */
  mpz_realloc2 (SCM_I_BIG_MPZ (result), m_bits);

  random_chunks =
    (scm_t_uint32 *) scm_gc_calloc (num_chunks * sizeof (scm_t_uint32),
                                     "random bignum chunks");

  do
    {
      scm_t_uint32 *current_chunk = random_chunks + (num_chunks - 1);
      scm_t_uint32 chunks_left = num_chunks;

      mpz_set_ui (SCM_I_BIG_MPZ (result), 0);

      if (end_bits)
        {
          /* generate a mask with ones in the end_bits position, i.e. if
             end_bits is 3, then we'd have a mask of ...0000000111 */
          const scm_t_uint32 rndbits = state->rng->random_bits (state);
          int rshift = (sizeof (scm_t_uint32) * SCM_CHAR_BIT) - end_bits;
          scm_t_uint32 mask = ((scm_t_uint32)-1) >> rshift;
          scm_t_uint32 highest_bits = rndbits & mask;
          *current_chunk-- = highest_bits;
          chunks_left--;
        }

      while (chunks_left)
        {
          /* now fill in the remaining scm_t_uint32 sized chunks */
          *current_chunk-- = state->rng->random_bits (state);
          chunks_left--;
        }
      mpz_import (SCM_I_BIG_MPZ (result),
                  num_chunks,
                  -1,
                  sizeof (scm_t_uint32),
                  0,
                  0,
                  random_chunks);
      /* if result >= m, regenerate it (it is important to regenerate
	 all bits in order not to get a distorted distribution) */
    } while (mpz_cmp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (m)) >= 0);
  scm_gc_free (random_chunks,
               num_chunks * sizeof (scm_t_uint32),
               "random bignum chunks");
  return scm_i_normbig (result);
}

/*
 * Scheme level representation of random states.
 */

scm_t_bits scm_tc16_rstate;

static SCM
make_rstate (scm_t_rstate *state)
{
  SCM_RETURN_NEWSMOB (scm_tc16_rstate, state);
}

/*
 * Scheme level interface.
 */

SCM_GLOBAL_VARIABLE_INIT (scm_var_random_state, "*random-state*", scm_seed_to_random_state (scm_from_locale_string ("URL:http://stat.fsu.edu/~geo/diehard.html")));

SCM_DEFINE (scm_random, "random", 1, 1, 0,
            (SCM n, SCM state),
            "Return a number in [0, N).\n"
            "\n"
            "Accepts a positive integer or real n and returns a\n"
            "number of the same type between zero (inclusive) and\n"
            "N (exclusive). The values returned have a uniform\n"
            "distribution.\n"
            "\n"
            "The optional argument @var{state} must be of the type produced\n"
	    "by @code{seed->random-state}. It defaults to the value of the\n"
	    "variable @var{*random-state*}. This object is used to maintain\n"
	    "the state of the pseudo-random-number generator and is altered\n"
	    "as a side effect of the random operation.")
#define FUNC_NAME s_scm_random
{
  if (SCM_UNBNDP (state))
    state = SCM_VARIABLE_REF (scm_var_random_state);
  SCM_VALIDATE_RSTATE (2, state);
  if (SCM_I_INUMP (n))
    {
      unsigned long m = (unsigned long) SCM_I_INUM (n);
      SCM_ASSERT_RANGE (1, n, SCM_I_INUM (n) > 0);
#if SCM_SIZEOF_UNSIGNED_LONG <= 4
      return scm_from_uint32 (scm_c_random (SCM_RSTATE (state),
                                            (scm_t_uint32) m));
#elif SCM_SIZEOF_UNSIGNED_LONG <= 8
      return scm_from_uint64 (scm_c_random64 (SCM_RSTATE (state),
                                              (scm_t_uint64) m));
#else
#error "Cannot deal with this platform's unsigned long size"
#endif
    }
  SCM_VALIDATE_NIM (1, n);
  if (SCM_REALP (n))
    return scm_from_double (SCM_REAL_VALUE (n)
			    * scm_c_uniform01 (SCM_RSTATE (state)));

  if (!SCM_BIGP (n))
    SCM_WRONG_TYPE_ARG (1, n);
  return scm_c_random_bignum (SCM_RSTATE (state), n);
}
#undef FUNC_NAME

SCM_DEFINE (scm_copy_random_state, "copy-random-state", 0, 1, 0,
            (SCM state),
            "Return a copy of the random state @var{state}.")
#define FUNC_NAME s_scm_copy_random_state
{
  if (SCM_UNBNDP (state))
    state = SCM_VARIABLE_REF (scm_var_random_state);
  SCM_VALIDATE_RSTATE (1, state);
  return make_rstate (SCM_RSTATE (state)->rng->copy_rstate (SCM_RSTATE (state)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_seed_to_random_state, "seed->random-state", 1, 0, 0,
            (SCM seed),
            "Return a new random state using @var{seed}.")
#define FUNC_NAME s_scm_seed_to_random_state
{
  SCM res;
  if (SCM_NUMBERP (seed))
    seed = scm_number_to_string (seed, SCM_UNDEFINED);
  SCM_VALIDATE_STRING (1, seed);
  res = make_rstate (scm_c_make_rstate (scm_i_string_chars (seed),
					scm_i_string_length (seed)));
  scm_remember_upto_here_1 (seed);
  return res;

}
#undef FUNC_NAME

SCM_DEFINE (scm_datum_to_random_state, "datum->random-state", 1, 0, 0,
            (SCM datum),
            "Return a new random state using @var{datum}, which should have\n"
            "been obtailed from @code{random-state->datum}.")
#define FUNC_NAME s_scm_datum_to_random_state
{
  return make_rstate (scm_c_rstate_from_datum (datum));
}
#undef FUNC_NAME

SCM_DEFINE (scm_random_state_to_datum, "random-state->datum", 1, 0, 0,
            (SCM state),
            "Return a datum representation of @var{state} that may be\n"
            "written out and read back with the Scheme reader.")
#define FUNC_NAME s_scm_random_state_to_datum
{
  SCM_VALIDATE_RSTATE (1, state);
  return SCM_RSTATE (state)->rng->to_datum (SCM_RSTATE (state));
}
#undef FUNC_NAME

SCM_DEFINE (scm_random_uniform, "random:uniform", 0, 1, 0,
            (SCM state),
	    "Return a uniformly distributed inexact real random number in\n"
	    "[0,1).")
#define FUNC_NAME s_scm_random_uniform
{
  if (SCM_UNBNDP (state))
    state = SCM_VARIABLE_REF (scm_var_random_state);
  SCM_VALIDATE_RSTATE (1, state);
  return scm_from_double (scm_c_uniform01 (SCM_RSTATE (state)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_random_normal, "random:normal", 0, 1, 0,
            (SCM state),
	    "Return an inexact real in a normal distribution.  The\n"
	    "distribution used has mean 0 and standard deviation 1.  For a\n"
	    "normal distribution with mean m and standard deviation d use\n"
	    "@code{(+ m (* d (random:normal)))}.")
#define FUNC_NAME s_scm_random_normal
{
  if (SCM_UNBNDP (state))
    state = SCM_VARIABLE_REF (scm_var_random_state);
  SCM_VALIDATE_RSTATE (1, state);
  return scm_from_double (scm_c_normal01 (SCM_RSTATE (state)));
}
#undef FUNC_NAME

static void
vector_scale_x (SCM v, double c)
{
  size_t n;
  if (scm_is_simple_vector (v))
    {
      n = SCM_SIMPLE_VECTOR_LENGTH (v);
      while (n-- > 0)
	SCM_REAL_VALUE (SCM_SIMPLE_VECTOR_REF (v, n)) *= c;
    }
  else
    {
      /* must be a f64vector. */
      scm_t_array_handle handle;
      size_t i, len;
      ssize_t inc;
      double *elts;

      elts = scm_f64vector_writable_elements (v, &handle, &len, &inc);

      for (i = 0; i < len; i++, elts += inc)
	*elts *= c;

      scm_array_handle_release (&handle);
    }
}

static double
vector_sum_squares (SCM v)
{
  double x, sum = 0.0;
  size_t n;
  if (scm_is_simple_vector (v))
    {
      n = SCM_SIMPLE_VECTOR_LENGTH (v);
      while (n-- > 0)
	{
	  x = SCM_REAL_VALUE (SCM_SIMPLE_VECTOR_REF (v, n));
	  sum += x * x;
	}
    }
  else
    {
      /* must be a f64vector. */
      scm_t_array_handle handle;
      size_t i, len;
      ssize_t inc;
      const double *elts;

      elts = scm_f64vector_elements (v, &handle, &len, &inc);

      for (i = 0; i < len; i++, elts += inc)
	{
	  x = *elts;
	  sum += x * x;
	}

      scm_array_handle_release (&handle);
    }
  return sum;
}

/* For the uniform distribution on the solid sphere, note that in
 * this distribution the length r of the vector has cumulative
 * distribution r^n; i.e., u=r^n is uniform [0,1], so r can be
 * generated as r=u^(1/n).
 */
SCM_DEFINE (scm_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0,
            (SCM v, SCM state),
	    "Fills @var{vect} with inexact real random numbers the sum of\n"
	    "whose squares is less than 1.0.  Thinking of @var{vect} as\n"
	    "coordinates in space of dimension @var{n} @math{=}\n"
	    "@code{(vector-length @var{vect})}, the coordinates are\n"
	    "uniformly distributed within the unit @var{n}-sphere.")
#define FUNC_NAME s_scm_random_solid_sphere_x
{
  if (SCM_UNBNDP (state))
    state = SCM_VARIABLE_REF (scm_var_random_state);
  SCM_VALIDATE_RSTATE (2, state);
  scm_random_normal_vector_x (v, state);
  vector_scale_x (v,
		  pow (scm_c_uniform01 (SCM_RSTATE (state)),
		       1.0 / scm_c_generalized_vector_length (v))
		  / sqrt (vector_sum_squares (v)));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_random_hollow_sphere_x, "random:hollow-sphere!", 1, 1, 0,
            (SCM v, SCM state),
            "Fills vect with inexact real random numbers\n"
            "the sum of whose squares is equal to 1.0.\n"
            "Thinking of vect as coordinates in space of\n"
            "dimension n = (vector-length vect), the coordinates\n"
            "are uniformly distributed over the surface of the\n"
            "unit n-sphere.")
#define FUNC_NAME s_scm_random_hollow_sphere_x
{
  if (SCM_UNBNDP (state))
    state = SCM_VARIABLE_REF (scm_var_random_state);
  SCM_VALIDATE_RSTATE (2, state);
  scm_random_normal_vector_x (v, state);
  vector_scale_x (v, 1 / sqrt (vector_sum_squares (v)));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0,
            (SCM v, SCM state),
            "Fills vect with inexact real random numbers that are\n"
            "independent and standard normally distributed\n"
            "(i.e., with mean 0 and variance 1).")
#define FUNC_NAME s_scm_random_normal_vector_x
{
  long i;
  scm_t_array_handle handle;
  scm_t_array_dim *dim;

  if (SCM_UNBNDP (state))
    state = SCM_VARIABLE_REF (scm_var_random_state);
  SCM_VALIDATE_RSTATE (2, state);

  scm_generalized_vector_get_handle (v, &handle);
  dim = scm_array_handle_dims (&handle);

  if (scm_is_vector (v))
    {
      SCM *elts = scm_array_handle_writable_elements (&handle);
      for (i = dim->lbnd; i <= dim->ubnd; i++, elts += dim->inc)
	*elts = scm_from_double (scm_c_normal01 (SCM_RSTATE (state)));
    }
  else
    {
      /* must be a f64vector. */
      double *elts = scm_array_handle_f64_writable_elements (&handle);
      for (i = dim->lbnd; i <= dim->ubnd; i++, elts += dim->inc)
	*elts = scm_c_normal01 (SCM_RSTATE (state));
    }

  scm_array_handle_release (&handle);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_random_exp, "random:exp", 0, 1, 0,
            (SCM state),
	    "Return an inexact real in an exponential distribution with mean\n"
	    "1.  For an exponential distribution with mean u use (* u\n"
	    "(random:exp)).")
#define FUNC_NAME s_scm_random_exp
{
  if (SCM_UNBNDP (state))
    state = SCM_VARIABLE_REF (scm_var_random_state);
  SCM_VALIDATE_RSTATE (1, state);
  return scm_from_double (scm_c_exp1 (SCM_RSTATE (state)));
}
#undef FUNC_NAME

void
scm_init_random ()
{
  int i, m;
  /* plug in default RNG */
  scm_t_rng rng =
  {
    sizeof (scm_t_i_rstate),
    scm_i_uniform32,
    scm_i_init_rstate,
    scm_i_copy_rstate,
    scm_i_rstate_from_datum,
    scm_i_rstate_to_datum
  };
  scm_the_rng = rng;

  scm_tc16_rstate = scm_make_smob_type ("random-state", 0);

  for (m = 1; m <= 0x100; m <<= 1)
    for (i = m >> 1; i < m; ++i)
      scm_masktab[i] = m - 1;

#include "libguile/random.x"

  scm_add_feature ("random");
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_RANDOM_H
#define SCM_RANDOM_H

/* Copyright (C) 1999,2000,2001, 2006, 2008, 2010 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
 */

#include "libguile/__scm.h"

/*
 * A plugin interface for RNGs
 *
 * Using this interface, it is possible for the application to tell
 * libguile to use a different RNG.  This is desirable if it is
 * necessary to use the same RNG everywhere in the application in
 * order to prevent interference, if the application uses RNG
 * hardware, or if the application has special demands on the RNG.
 *
 * Look how the default generator is "plugged in" in scm_init_random().
 */

typedef struct scm_t_rstate {
  struct scm_t_rng *rng;
  double normal_next; /* For scm_c_normal01 */
  /* Custom fields follow here */
} scm_t_rstate;

typedef struct scm_t_rng {
  size_t rstate_size;				    /* size of random state */
  scm_t_uint32 (*random_bits) (scm_t_rstate *state); /* gives 32 random bits */
  void (*init_rstate) (scm_t_rstate *state, const char *seed, int n);
  scm_t_rstate *(*copy_rstate) (scm_t_rstate *state);
  void (*from_datum) (scm_t_rstate *state, SCM datum);
  SCM (*to_datum) (scm_t_rstate *state);
} scm_t_rng;

SCM_API scm_t_rng scm_the_rng;

/*
 * Random number library functions
 */
SCM_API scm_t_rstate *scm_c_make_rstate (const char *, int);
SCM_API scm_t_rstate *scm_c_rstate_from_datum (SCM datum);
SCM_API scm_t_rstate *scm_c_default_rstate (void);
#define scm_c_uniform32(RSTATE) ((RSTATE)->rng->random_bits (RSTATE))
SCM_API double scm_c_uniform01 (scm_t_rstate *);
SCM_API double scm_c_normal01 (scm_t_rstate *);
SCM_API double scm_c_exp1 (scm_t_rstate *);
SCM_API scm_t_uint32 scm_c_random (scm_t_rstate *, scm_t_uint32 m);
SCM_API scm_t_uint64 scm_c_random64 (scm_t_rstate *state, scm_t_uint64 m);
SCM_API SCM scm_c_random_bignum (scm_t_rstate *, SCM m);

/*
 * Scheme level interface
 */
SCM_API scm_t_bits scm_tc16_rstate;
#define SCM_RSTATEP(obj) SCM_SMOB_PREDICATE (scm_tc16_rstate, obj)
#define SCM_RSTATE(obj)  ((scm_t_rstate *) SCM_SMOB_DATA (obj))

SCM_API unsigned char scm_masktab[256];

SCM_API SCM scm_var_random_state;
SCM_API SCM scm_random (SCM n, SCM state);
SCM_API SCM scm_copy_random_state (SCM state);
SCM_API SCM scm_seed_to_random_state (SCM seed);
SCM_API SCM scm_datum_to_random_state (SCM datum);
SCM_API SCM scm_random_state_to_datum (SCM state);
SCM_API SCM scm_random_uniform (SCM state);
SCM_API SCM scm_random_solid_sphere_x (SCM v, SCM state);
SCM_API SCM scm_random_hollow_sphere_x (SCM v, SCM state);
SCM_API SCM scm_random_normal (SCM state);
SCM_API SCM scm_random_normal_vector_x (SCM v, SCM state);
SCM_API SCM scm_random_exp (SCM state);
SCM_INTERNAL void scm_init_random (void);

#endif  /* SCM_RANDOM_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006 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

#include "libguile/_scm.h"

#include <stdio.h>

#ifdef HAVE_STRING_H
#include <string.h>
#endif

#include "libguile/chars.h"
#include "libguile/modules.h"
#include "libguile/ports.h"
#include "libguile/rdelim.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/strports.h"
#include "libguile/validate.h"

SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0,
            (SCM delims, SCM str, SCM gobble, SCM port, SCM start, SCM end),
	    "Read characters from @var{port} into @var{str} until one of the\n"
	    "characters in the @var{delims} string is encountered.  If\n"
	    "@var{gobble} is true, discard the delimiter character;\n"
	    "otherwise, leave it in the input stream for the next read.  If\n"
	    "@var{port} is not specified, use the value of\n"
	    "@code{(current-input-port)}.  If @var{start} or @var{end} are\n"
	    "specified, store data only into the substring of @var{str}\n"
	    "bounded by @var{start} and @var{end} (which default to the\n"
	    "beginning and end of the string, respectively).\n"
	    "\n"
	    " Return a pair consisting of the delimiter that terminated the\n"
	    "string and the number of characters read.  If reading stopped\n"
	    "at the end of file, the delimiter returned is the\n"
	    "@var{eof-object}; if the string was filled without encountering\n"
	    "a delimiter, this value is @code{#f}.")
#define FUNC_NAME s_scm_read_delimited_x
{
  size_t j;
  size_t cstart;
  size_t cend;
  scm_t_wchar c;
  size_t num_delims;

  SCM_VALIDATE_STRING (1, delims);
  num_delims = scm_i_string_length (delims);

  SCM_VALIDATE_STRING (2, str);
  scm_i_get_substring_spec (scm_i_string_length (str),
			    start, &cstart, end, &cend);

  if (SCM_UNBNDP (port))
    port = scm_current_input_port ();
  else
    SCM_VALIDATE_OPINPORT (4, port);

  for (j = cstart; j < cend; j++)
    {
      size_t k;

      c = scm_getc (port);
      for (k = 0; k < num_delims; k++)
	{
	  if (scm_i_string_ref (delims, k) == c)
	    {
	      if (scm_is_false (gobble))
		scm_ungetc (c, port);

	      return scm_cons (SCM_MAKE_CHAR (c),
			       scm_from_size_t (j - cstart));
	    }
	}
      if (c == EOF)
	return scm_cons (SCM_EOF_VAL,
			 scm_from_size_t (j - cstart));

      scm_c_string_set_x (str, j, SCM_MAKE_CHAR (c));
    }
  return scm_cons (SCM_BOOL_F, scm_from_size_t (j - cstart));
}
#undef FUNC_NAME

static unsigned char *
scm_do_read_line (SCM port, size_t *len_p)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  unsigned char *end;

  /* I thought reading lines was simple.  Mercy me.  */

  /* The common case: the buffer contains a complete line.
     This needs to be fast.  */
  if ((end = memchr (pt->read_pos, '\n', (pt->read_end - pt->read_pos)))
	   != 0)
    {
      size_t buf_len = (end + 1) - pt->read_pos;
      /* Allocate a buffer of the perfect size.  */
      unsigned char *buf = scm_malloc (buf_len + 1);

      memcpy (buf, pt->read_pos, buf_len);
      pt->read_pos += buf_len;

      buf[buf_len] = '\0';

      *len_p = buf_len;
      return buf;
    }

  /* The buffer contains no newlines.  */
  {
    /* When live, len is always the number of characters in the
       current buffer that are part of the current line.  */
    size_t len = (pt->read_end - pt->read_pos);
    size_t buf_size = (len < 50) ? 60 : len * 2;
    /* Invariant: buf always has buf_size + 1 characters allocated;
       the `+ 1' is for the final '\0'.  */
    unsigned char *buf = scm_malloc (buf_size + 1);
    size_t buf_len = 0;

    for (;;)
      {
	if (buf_len + len > buf_size)
	  {
	    size_t new_size = (buf_len + len) * 2;
	    buf = scm_realloc (buf, new_size + 1);
	    buf_size = new_size;
	  }

	/* Copy what we've got out of the port, into our buffer.  */
	memcpy (buf + buf_len, pt->read_pos, len);
	buf_len += len;
	pt->read_pos += len;

	/* If we had seen a newline, we're done now.  */
	if (end)
	  break;

	/* Get more characters.  */
	if (scm_fill_input (port) == EOF)
	  {
	    /* If we're missing a final newline in the file, return
	       what we did get, sans newline.  */
	    if (buf_len > 0)
	      break;

	    free (buf);
	    return 0;
	  }

	/* Search the buffer for newlines.  */
	if ((end = memchr (pt->read_pos, '\n',
			   (len = (pt->read_end - pt->read_pos))))
	    != 0)
	  len = (end - pt->read_pos) + 1;
      }

    /* I wonder how expensive this realloc is.  */
    buf = scm_realloc (buf, buf_len + 1);
    buf[buf_len] = '\0';
    *len_p = buf_len;
    return buf;
  }
}

/*
 * %read-line
 * truncates any terminating newline from its input, and returns
 * a cons of the string read and its terminating character.  Doing
 * so makes it easy to implement the hairy `read-line' options
 * efficiently in Scheme.
 */

SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0,
            (SCM port),
	    "Read a newline-terminated line from @var{port}, allocating storage as\n"
	    "necessary.  The newline terminator (if any) is removed from the string,\n"
	    "and a pair consisting of the line and its delimiter is returned.  The\n"
	    "delimiter may be either a newline or the @var{eof-object}; if\n"
	    "@code{%read-line} is called at the end of file, it returns the pair\n"
	    "@code{(#<eof> . #<eof>)}.")
#define FUNC_NAME s_scm_read_line
{
  scm_t_port *pt;
  char *s;
  size_t slen = 0;
  SCM line, term;
  const char *enc;
  scm_t_string_failed_conversion_handler hndl;

  if (SCM_UNBNDP (port))
    port = scm_current_input_port ();
  SCM_VALIDATE_OPINPORT (1,port);

  pt = SCM_PTAB_ENTRY (port);
  enc = pt->encoding;
  hndl = pt->ilseq_handler;
  if (pt->rw_active == SCM_PORT_WRITE)
    scm_ptobs[SCM_PTOBNUM (port)].flush (port);

  s = (char *) scm_do_read_line (port, &slen);

  if (s == NULL)
    term = line = SCM_EOF_VAL;
  else
    {
      if (s[slen - 1] == '\n')
	{
	  term = SCM_MAKE_CHAR ('\n');
	  s[slen - 1] = '\0';

	  line = scm_from_stringn (s, slen - 1, enc, hndl);
	  free (s);
	  SCM_INCLINE (port);
	}
      else
	{
	  /* Fix: we should check for eof on the port before assuming this. */
	  term = SCM_EOF_VAL;
	  line = scm_from_stringn (s, slen, enc, hndl);
	  free (s);
	  SCM_COL (port) += scm_i_string_length (line);
	}
    }

  if (pt->rw_random)
    pt->rw_active = SCM_PORT_READ;

  return scm_cons (line, term);
}
#undef FUNC_NAME

SCM_DEFINE (scm_write_line, "write-line", 1, 1, 0,
            (SCM obj, SCM port),
	    "Display @var{obj} and a newline character to @var{port}.  If\n"
	    "@var{port} is not specified, @code{(current-output-port)} is\n"
	    "used.  This function is equivalent to:\n"
	    "@lisp\n"
	    "(display obj [port])\n"
	    "(newline [port])\n"
	    "@end lisp")
#define FUNC_NAME s_scm_write_line
{
  scm_display (obj, port);
  return scm_newline (port);
}
#undef FUNC_NAME

SCM
scm_init_rdelim_builtins (void)
{
#include "libguile/rdelim.x"

  return SCM_UNSPECIFIED;
}

void
scm_init_rdelim (void)
{
  scm_c_define_gsubr ("%init-rdelim-builtins", 0, 0, 0,
		      scm_init_rdelim_builtins);
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_RDELIM_H
#define SCM_RDELIM_H

/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2006, 2008 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
 */

#include "libguile/__scm.h"

SCM_API SCM scm_read_delimited_x (SCM delims, SCM buf, SCM gobble, SCM port,
				  SCM offset, SCM length);
SCM_API SCM scm_read_line (SCM port);
SCM_API SCM scm_write_line (SCM obj, SCM port);
SCM_API SCM scm_init_rdelim_builtins (void);

SCM_INTERNAL void scm_init_rdelim (void);

#endif  /* SCM_RDELIM_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/