code:
/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 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 2.1 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/unif.h"
#include "libguile/srfi-4.h"
#include "libguile/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)
 */

#define A 2131995753UL

#ifndef M_PI
#define M_PI 3.14159265359
#endif

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

void
scm_i_init_rstate (scm_t_i_rstate *state, const char *seed, int n)
{
  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;
  state->w = w;
  state->c = c;
}

scm_t_i_rstate *
scm_i_copy_rstate (scm_t_i_rstate *state)
{
  scm_t_rstate *new_state = scm_malloc (scm_the_rng.rstate_size);
  return memcpy (new_state, state, scm_the_rng.rstate_size);
}

/*
 * Random number library functions
 */

scm_t_rstate *
scm_c_make_rstate (const char *seed, int n)
{
  scm_t_rstate *state = scm_malloc (scm_the_rng.rstate_size);
  state->reserved0 = 0;
  scm_the_rng.init_rstate (state, seed, n);
  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

inline double
scm_c_uniform01 (scm_t_rstate *state)
{
  double x = (double) scm_the_rng.random_bits (state) / (double) 0xffffffffUL;
  return ((x + (double) scm_the_rng.random_bits (state))
	  / (double) 0xffffffffUL);
}

double
scm_c_normal01 (scm_t_rstate *state)
{
  if (state->reserved0)
    {
      state->reserved0 = 0;
      return state->reserved1;
    }
  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->reserved1 = r * cos (a);
      state->reserved0 = 1;

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

static scm_t_uint32
scm_c_random32 (scm_t_rstate *state, scm_t_uint32 m)
{
  scm_t_uint32 r, mask = scm_i_mask32 (m);
  while ((r = scm_the_rng.random_bits (state) & mask) >= m);
  return r;
}

/* Returns 32 random bits. */
unsigned long
scm_c_random (scm_t_rstate *state, unsigned long m)
{
  return scm_c_random32 (state, (scm_t_uint32)m);
}

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_random32 (state, (scm_t_uint32) m);

  mask = scm_i_mask32 (m >> 32);
  while ((r = ((scm_t_uint64) (scm_the_rng.random_bits (state) & mask) << 32)
          | scm_the_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 u32? */
  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 unsigned long rndbits = scm_the_rng.random_bits (state);
          int rshift = (sizeof (scm_t_uint32) * SCM_CHAR_BIT) - end_bits;
          scm_t_uint32 mask = 0xffffffff >> rshift;
          scm_t_uint32 highest_bits = ((scm_t_uint32) rndbits) & mask;
          *current_chunk-- = highest_bits;
          chunks_left--;
        }

      while (chunks_left)
        {
          /* now fill in the remaining scm_t_uint32 sized chunks */
          *current_chunk-- = scm_the_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);
}

static size_t
rstate_free (SCM rstate)
{
  free (SCM_RSTATE (rstate));
  return 0;
}

/*
 * 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_the_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_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),
    (unsigned long (*)()) scm_i_uniform32,
    (void (*)())          scm_i_init_rstate,
    (scm_t_rstate *(*)())    scm_i_copy_rstate
  };
  scm_the_rng = rng;

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

  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, 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 2.1 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 {
  int reserved0;
  double reserved1;
  /* Custom fields follow here */
} scm_t_rstate;

typedef struct scm_t_rng {
  size_t rstate_size;				    /* size of random state */
  /* Though this returns an unsigned long, it's only 32 bits of randomness. */
  unsigned long (*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);
} scm_t_rng;

SCM_API scm_t_rng scm_the_rng;

/*
 * Default RNG
 */
typedef struct scm_t_i_rstate {
  scm_t_rstate rstate;
  unsigned long w;
  unsigned long c;
} scm_t_i_rstate;

/* Though this returns an unsigned long, it's only 32 bits of randomness. */
SCM_API unsigned long scm_i_uniform32 (scm_t_i_rstate *);
SCM_API void scm_i_init_rstate (scm_t_i_rstate *, const char *seed, int n);
SCM_API scm_t_i_rstate *scm_i_copy_rstate (scm_t_i_rstate *);

/*
 * Random number library functions
 */
SCM_API scm_t_rstate *scm_c_make_rstate (const char *, int);
SCM_API scm_t_rstate *scm_c_default_rstate (void);
#define scm_c_uniform32(RSTATE) scm_the_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 *);
/* Though this returns an unsigned long, it's only 32 bits of randomness. */
SCM_API unsigned long scm_c_random (scm_t_rstate *, unsigned long m);
/* This one returns 64 bits of randomness. */
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_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_API void scm_init_random (void);

#endif  /* SCM_RANDOM_H */

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

license: unknown


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 2.1 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;
  int c;
  const char *cdelims;
  size_t num_delims;

  SCM_VALIDATE_STRING (1, delims);
  cdelims = scm_i_string_chars (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 (cdelims[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;

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

  pt = SCM_PTAB_ENTRY (port);
  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_take_locale_stringn (s, slen-1);
	  SCM_INCLINE (port);
	}
      else
	{
	  /* Fix: we should check for eof on the port before assuming this. */
	  term = SCM_EOF_VAL;
	  line = scm_take_locale_stringn (s, slen);
	  SCM_COL (port) += slen;
	}
    }

  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 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 2.1 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_API void scm_init_rdelim (void);

#endif  /* SCM_RDELIM_H */

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


code:
/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 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 2.1 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 <stdio.h>
#include <ctype.h>
#include <string.h>
#ifdef HAVE_STRINGS_H
# include <strings.h>
#endif

#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/eval.h"
#include "libguile/unif.h"
#include "libguile/keywords.h"
#include "libguile/alist.h"
#include "libguile/srcprop.h"
#include "libguile/hashtab.h"
#include "libguile/hash.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/strports.h"
#include "libguile/vectors.h"
#include "libguile/validate.h"
#include "libguile/srfi-4.h"
#include "libguile/srfi-13.h"

#include "libguile/read.h"

SCM_GLOBAL_SYMBOL (scm_sym_dot, ".");
SCM_SYMBOL (scm_keyword_prefix, "prefix");
SCM_SYMBOL (scm_keyword_postfix, "postfix");

scm_t_option scm_read_opts[] = {
  { SCM_OPTION_BOOLEAN, "copy", 0,
    "Copy source code expressions." },
  { SCM_OPTION_BOOLEAN, "positions", 0,
    "Record positions of source code expressions." },
  { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
    "Convert symbols to lower case."},
  { SCM_OPTION_SCM, "keywords", SCM_UNPACK (SCM_BOOL_F),
    "Style of keyword recognition: #f, 'prefix or 'postfix."}
#if SCM_ENABLE_ELISP
  ,
  { SCM_OPTION_BOOLEAN, "elisp-vectors", 0,
    "Support Elisp vector syntax, namely `[...]'."},
  { SCM_OPTION_BOOLEAN, "elisp-strings", 0,
    "Support `\\(' and `\\)' in strings."}
#endif
};

/*
  Give meaningful error messages for errors

  We use the format

  FILE:LINE:COL: MESSAGE
  This happened in ....

  This is not standard GNU format, but the test-suite likes the real
  message to be in front.

 */

void
scm_i_input_error (char const *function,
		   SCM port, const char *message, SCM arg)
{
  SCM fn = (scm_is_string (SCM_FILENAME(port))
	    ? SCM_FILENAME(port)
	    : scm_from_locale_string ("#<unknown port>"));

  SCM string_port = scm_open_output_string ();
  SCM string = SCM_EOL;
  scm_simple_format (string_port,
		     scm_from_locale_string ("~A:~S:~S: ~A"),
		     scm_list_4 (fn,
				 scm_from_long (SCM_LINUM (port) + 1),
				 scm_from_int (SCM_COL (port) + 1),
				 scm_from_locale_string (message)));

  string = scm_get_output_string (string_port);
  scm_close_output_port (string_port);
  scm_error_scm (scm_from_locale_symbol ("read-error"),
		 function? scm_from_locale_string (function) : SCM_BOOL_F,
		 string,
		 arg,
		 SCM_BOOL_F);
}

SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0,
            (SCM setting),
	    "Option interface for the read options. Instead of using\n"
	    "this procedure directly, use the procedures @code{read-enable},\n"
	    "@code{read-disable}, @code{read-set!} and @code{read-options}.")
#define FUNC_NAME s_scm_read_options
{
  SCM ans = scm_options (setting,
			 scm_read_opts,
			 SCM_N_READ_OPTIONS,
			 FUNC_NAME);
  if (SCM_COPY_SOURCE_P)
    SCM_RECORD_POSITIONS_P = 1;
  return ans;
}
#undef FUNC_NAME

/* An association list mapping extra hash characters to procedures.  */
static SCM *scm_read_hash_procedures;

/* Token readers.  */

/* Size of the C buffer used to read symbols and numbers.  */
#define READER_BUFFER_SIZE            128

/* Size of the C buffer used to read strings.  */
#define READER_STRING_BUFFER_SIZE     512

/* The maximum size of Scheme character names.  */
#define READER_CHAR_NAME_MAX_SIZE      50

/* `isblank' is only in C99.  */
#define CHAR_IS_BLANK_(_chr)					\
  (((_chr) == ' ') || ((_chr) == '\t') || ((_chr) == '\n')	\
   || ((_chr) == '\f') || ((_chr) == '\r'))

#ifdef MSDOS
# define CHAR_IS_BLANK(_chr)			\
  ((CHAR_IS_BLANK_ (chr)) || ((_chr) == 26))
#else
# define CHAR_IS_BLANK CHAR_IS_BLANK_
#endif

/* R5RS one-character delimiters (see section 7.1.1, ``Lexical
   structure'').  */
#define CHAR_IS_R5RS_DELIMITER(c)				\
  (CHAR_IS_BLANK (c)						\
   || (c == ')') || (c == '(') || (c == ';') || (c == '"'))

#define CHAR_IS_DELIMITER  CHAR_IS_R5RS_DELIMITER

/* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical
   Structure''.  */
#define CHAR_IS_EXPONENT_MARKER(_chr)				\
  (((_chr) == 'e') || ((_chr) == 's') || ((_chr) == 'f')	\
   || ((_chr) == 'd') || ((_chr) == 'l'))

/* An inlinable version of `scm_c_downcase ()'.  */
#define CHAR_DOWNCASE(_chr)				\
  (((_chr) <= UCHAR_MAX) ? tolower (_chr) : (_chr))

#ifndef HAVE_DECL_STRNCASECMP
extern int strncasecmp (char const *s1, char const *s2, size_t n);
#endif

#ifndef HAVE_STRNCASECMP
/* XXX: Use Gnulib's `strncasecmp ()'.  */

static int
strncasecmp (const char *s1, const char *s2, size_t len2)
{
  while (*s1 && *s2 && len2 > 0)
    {
      int c1 = *s1, c2 = *s2;

      if (CHAR_DOWNCASE (c1) != CHAR_DOWNCASE (c2))
	return 0;
      else
	{
	  ++s1;
	  ++s2;
	  --len2;
	}
    }
  return !(*s1 || *s2 || len2 > 0);
}
#endif

/* Read an SCSH block comment.  */
static inline SCM scm_read_scsh_block_comment (int chr, SCM port);

/* Read from PORT until a delimiter (e.g., a whitespace) is read.  Return
   zero if the whole token fits in BUF, non-zero otherwise.  */
static inline int
read_token (SCM port, char *buf, size_t buf_size, size_t *read)
{
  *read = 0;

  while (*read < buf_size)
    {
      int chr;

      chr = scm_getc (port);
      chr = (SCM_CASE_INSENSITIVE_P ? CHAR_DOWNCASE (chr) : chr);

      if (chr == EOF)
	return 0;
      else if (CHAR_IS_DELIMITER (chr))
	{
	  scm_ungetc (chr, port);
	  return 0;
	}
      else
	{
	  *buf = (char) chr;
	  buf++, (*read)++;
	}
    }

  return 1;
}

/* Skip whitespace from PORT and return the first non-whitespace character
   read.  Raise an error on end-of-file.  */
static int
flush_ws (SCM port, const char *eoferr)
{
  register int c;
  while (1)
    switch (c = scm_getc (port))
      {
      case EOF:
      goteof:
	if (eoferr)
	  {
	    scm_i_input_error (eoferr,
			       port,
			       "end of file",
			       SCM_EOL);
	  }
	return c;

      case ';':
      lp:
	switch (c = scm_getc (port))
	  {
	  case EOF:
	    goto goteof;
	  default:
	    goto lp;
	  case SCM_LINE_INCREMENTORS:
	    break;
	  }
	break;

      case '#':
	switch (c = scm_getc (port))
	  {
	  case EOF:
	    eoferr = "read_sharp";
	    goto goteof;
	  case '!':
	    scm_read_scsh_block_comment (c, port);
	    break;
	  default:
	    scm_ungetc (c, port);
	    return '#';
	  }
	break;

      case SCM_LINE_INCREMENTORS:
      case SCM_SINGLE_SPACES:
      case '\t':
	break;

      default:
	return c;
      }

  return 0;
}

/* Token readers.  */

static SCM scm_read_expression (SCM port);
static SCM scm_read_sharp (int chr, SCM port);
static SCM scm_get_hash_procedure (int c);
static SCM recsexpr (SCM obj, long line, int column, SCM filename);

static SCM
scm_read_sexp (int chr, SCM port)
#define FUNC_NAME "scm_i_lreadparen"
{
  register int c;
  register SCM tmp;
  register SCM tl, ans = SCM_EOL;
  SCM tl2 = SCM_EOL, ans2 = SCM_EOL, copy = SCM_BOOL_F;
  static const int terminating_char = ')';

  /* Need to capture line and column numbers here. */
  long line = SCM_LINUM (port);
  int column = SCM_COL (port) - 1;

  c = flush_ws (port, FUNC_NAME);
  if (terminating_char == c)
    return SCM_EOL;

  scm_ungetc (c, port);
  if (scm_is_eq (scm_sym_dot,
		 (tmp = scm_read_expression (port))))
    {
      ans = scm_read_expression (port);
      if (terminating_char != (c = flush_ws (port, FUNC_NAME)))
	scm_i_input_error (FUNC_NAME, port, "missing close paren",
			   SCM_EOL);
      return ans;
    }

  /* Build the head of the list structure. */
  ans = tl = scm_cons (tmp, SCM_EOL);

  if (SCM_COPY_SOURCE_P)
    ans2 = tl2 = scm_cons (scm_is_pair (tmp)
			   ? copy
			   : tmp,
			   SCM_EOL);

  while (terminating_char != (c = flush_ws (port, FUNC_NAME)))
    {
      SCM new_tail;

      scm_ungetc (c, port);
      if (scm_is_eq (scm_sym_dot,
		     (tmp = scm_read_expression (port))))
	{
	  SCM_SETCDR (tl, tmp = scm_read_expression (port));

	  if (SCM_COPY_SOURCE_P)
	    SCM_SETCDR (tl2, scm_cons (scm_is_pair (tmp) ? copy : tmp,
				       SCM_EOL));

	  c = flush_ws (port, FUNC_NAME);
	  if (terminating_char != c)
	    scm_i_input_error (FUNC_NAME, port,
			       "in pair: missing close paren", SCM_EOL);
	  goto exit;
	}

      new_tail = scm_cons (tmp, SCM_EOL);
      SCM_SETCDR (tl, new_tail);
      tl = new_tail;

      if (SCM_COPY_SOURCE_P)
	{
	  SCM new_tail2 = scm_cons (scm_is_pair (tmp)
				    ? copy
				    : tmp, SCM_EOL);
	  SCM_SETCDR (tl2, new_tail2);
	  tl2 = new_tail2;
	}
    }

 exit:
  if (SCM_RECORD_POSITIONS_P)
    scm_whash_insert (scm_source_whash,
		      ans,
		      scm_make_srcprops (line, column,
					 SCM_FILENAME (port),
					 SCM_COPY_SOURCE_P
					 ? ans2
					 : SCM_UNDEFINED,
					 SCM_EOL));
  return ans;
}
#undef FUNC_NAME

static SCM
scm_read_string (int chr, SCM port)
#define FUNC_NAME "scm_lreadr"
{
  /* For strings smaller than C_STR, this function creates only one Scheme
     object (the string returned).  */

  SCM str = SCM_BOOL_F;
  char c_str[READER_STRING_BUFFER_SIZE];
  unsigned c_str_len = 0;
  int c;

  while ('"' != (c = scm_getc (port)))
    {
      if (c == EOF)
	str_eof: scm_i_input_error (FUNC_NAME, port,
				    "end of file in string constant",
				    SCM_EOL);

      if (c_str_len + 1 >= sizeof (c_str))
	{
	  /* Flush the C buffer onto a Scheme string.  */
	  SCM addy;

	  if (str == SCM_BOOL_F)
	    str = scm_c_make_string (0, SCM_MAKE_CHAR ('X'));

	  addy = scm_from_locale_stringn (c_str, c_str_len);
	  str = scm_string_append_shared (scm_list_2 (str, addy));

	  c_str_len = 0;
	}

      if (c == '\\')
	switch (c = scm_getc (port))
	  {
	  case EOF:
	    goto str_eof;
	  case '"':
	  case '\\':
	    break;
#if SCM_ENABLE_ELISP
	  case '(':
	  case ')':
	    if (SCM_ESCAPED_PARENS_P)
	      break;
	    goto bad_escaped;
#endif
	  case '\n':
	    continue;
	  case '0':
	    c = '\0';
	    break;
	  case 'f':
	    c = '\f';
	    break;
	  case 'n':
	    c = '\n';
	    break;
	  case 'r':
	    c = '\r';
	    break;
	  case 't':
	    c = '\t';
	    break;
	  case 'a':
	    c = '\007';
	    break;
	  case 'v':
	    c = '\v';
	    break;
	  case 'x':
	    {
	      int a, b;
	      a = scm_getc (port);
	      if (a == EOF) goto str_eof;
	      b = scm_getc (port);
	      if (b == EOF) goto str_eof;
	      if      ('0' <= a && a <= '9') a -= '0';
	      else if ('A' <= a && a <= 'F') a = a - 'A' + 10;
	      else if ('a' <= a && a <= 'f') a = a - 'a' + 10;
	      else goto bad_escaped;
	      if      ('0' <= b && b <= '9') b -= '0';
	      else if ('A' <= b && b <= 'F') b = b - 'A' + 10;
	      else if ('a' <= b && b <= 'f') b = b - 'a' + 10;
	      else goto bad_escaped;
	      c = a * 16 + b;
	      break;
	    }
	  default:
	  bad_escaped:
	    scm_i_input_error (FUNC_NAME, port,
			       "illegal character in escape sequence: ~S",
			       scm_list_1 (SCM_MAKE_CHAR (c)));
	  }
      c_str[c_str_len++] = c;
    }

  if (c_str_len > 0)
    {
      SCM addy;

      addy = scm_from_locale_stringn (c_str, c_str_len);
      if (str == SCM_BOOL_F)
	str = addy;
      else
	str = scm_string_append_shared (scm_list_2 (str, addy));
    }
  else
    str = (str == SCM_BOOL_F) ? scm_nullstr : str;

  return str;
}
#undef FUNC_NAME

static SCM
scm_read_number (int chr, SCM port)
{
  SCM result, str = SCM_EOL;
  char buffer[READER_BUFFER_SIZE];
  size_t read;
  int overflow = 0;

  scm_ungetc (chr, port);
  do
    {
      overflow = read_token (port, buffer, sizeof (buffer), &read);

      if ((overflow) || (scm_is_pair (str)))
	str = scm_cons (scm_from_locale_stringn (buffer, read), str);
    }
  while (overflow);

  if (scm_is_pair (str))
    {
      /* The slow path.  */

      str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
      result = scm_string_to_number (str, SCM_UNDEFINED);
      if (!scm_is_true (result))
	/* Return a symbol instead of a number.  */
	result = scm_string_to_symbol (str);
    }
  else
    {
      result = scm_c_locale_stringn_to_number (buffer, read, 10);
      if (!scm_is_true (result))
	/* Return a symbol instead of a number.  */
	result = scm_from_locale_symboln (buffer, read);
    }

  return result;
}

static SCM
scm_read_mixed_case_symbol (int chr, SCM port)
{
  SCM result, str = SCM_EOL;
  int overflow = 0, ends_with_colon = 0;
  char buffer[READER_BUFFER_SIZE];
  size_t read = 0;
  int postfix = scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_postfix);

  scm_ungetc (chr, port);
  do
    {
      overflow = read_token (port, buffer, sizeof (buffer), &read);

      if (read > 0)
	ends_with_colon = (buffer[read - 1] == ':');

      if ((overflow) || (scm_is_pair (str)))
	str = scm_cons (scm_from_locale_stringn (buffer, read), str);
    }
  while (overflow);

  if (scm_is_pair (str))
    {
      size_t len;

      str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
      len = scm_c_string_length (str);

      /* Per SRFI-88, `:' alone is an identifier, not a keyword.  */
      if (postfix && ends_with_colon && (len > 1))
	{
	  /* Strip off colon.  */
	  str = scm_c_substring (str, 0, len-1);
	  result = scm_string_to_symbol (str);
	  result = scm_symbol_to_keyword (result);
	}
      else
	result = scm_string_to_symbol (str);
    }
  else
    {
      /* For symbols smaller than `sizeof (buffer)', we don't need to recur
	 to Scheme strings.  Therefore, we only create one Scheme object (a
	 symbol) per symbol read.  */
      if (postfix && ends_with_colon && (read > 1))
	result = scm_from_locale_keywordn (buffer, read - 1);
      else
	result = scm_from_locale_symboln (buffer, read);
    }

  return result;
}

static SCM
scm_read_number_and_radix (int chr, SCM port)
#define FUNC_NAME "scm_lreadr"
{
  SCM result, str = SCM_EOL;
  size_t read;
  char buffer[READER_BUFFER_SIZE];
  unsigned int radix;
  int overflow = 0;

  switch (chr)
    {
    case 'B':
    case 'b':
      radix = 2;
      break;

    case 'o':
    case 'O':
      radix = 8;
      break;

    case 'd':
    case 'D':
      radix = 10;
      break;

    case 'x':
    case 'X':
      radix = 16;
      break;

    default:
      scm_ungetc (chr, port);
      scm_ungetc ('#', port);
      radix = 10;
    }

  do
    {
      overflow = read_token (port, buffer, sizeof (buffer), &read);

      if ((overflow) || (scm_is_pair (str)))
	str = scm_cons (scm_from_locale_stringn (buffer, read), str);
    }
  while (overflow);

  if (scm_is_pair (str))
    {
      str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
      result = scm_string_to_number (str, scm_from_uint (radix));
    }
  else
    result = scm_c_locale_stringn_to_number (buffer, read, radix);

  if (scm_is_true (result))
    return result;

  scm_i_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL);

  return SCM_BOOL_F;
}
#undef FUNC_NAME

static SCM
scm_read_quote (int chr, SCM port)
{
  SCM p;
  long line = SCM_LINUM (port);
  int column = SCM_COL (port) - 1;

  switch (chr)
    {
    case '`':
      p = scm_sym_quasiquote;
      break;

    case '\'':
      p = scm_sym_quote;
      break;

    case ',':
      {
	int c;

	c = scm_getc (port);
	if ('@' == c)
	  p = scm_sym_uq_splicing;
	else
	  {
	    scm_ungetc (c, port);
	    p = scm_sym_unquote;
	  }
	break;
      }

    default:
      fprintf (stderr, "%s: unhandled quote character (%i)\n",
	       "scm_read_quote", chr);
      abort ();
    }

  p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
  if (SCM_RECORD_POSITIONS_P)
    scm_whash_insert (scm_source_whash, p,
		      scm_make_srcprops (line, column,
					 SCM_FILENAME (port),
					 SCM_COPY_SOURCE_P
					 ? (scm_cons2 (SCM_CAR (p),
						       SCM_CAR (SCM_CDR (p)),
						       SCM_EOL))
					 : SCM_UNDEFINED,
					 SCM_EOL));

  return p;
}

static inline SCM
scm_read_semicolon_comment (int chr, SCM port)
{
  int c;

  for (c = scm_getc (port);
       (c != EOF) && (c != '\n');
       c = scm_getc (port));

  return SCM_UNSPECIFIED;
}

/* Sharp readers, i.e. readers called after a `#' sign has been read.  */

static SCM
scm_read_boolean (int chr, SCM port)
{
  switch (chr)
    {
    case 't':
    case 'T':
      return SCM_BOOL_T;

    case 'f':
    case 'F':
      return SCM_BOOL_F;
    }

  return SCM_UNSPECIFIED;
}

static SCM
scm_read_character (int chr, SCM port)
#define FUNC_NAME "scm_lreadr"
{
  unsigned c;
  char charname[READER_CHAR_NAME_MAX_SIZE];
  size_t charname_len;

  if (read_token (port, charname, sizeof (charname), &charname_len))
    goto char_error;

  if (charname_len == 0)
    {
      chr = scm_getc (port);
      if (chr == EOF)
	scm_i_input_error (FUNC_NAME, port, "unexpected end of file "
			   "while reading character", SCM_EOL);

      /* CHR must be a token delimiter, like a whitespace.  */
      return (SCM_MAKE_CHAR (chr));
    }

  if (charname_len == 1)
    return SCM_MAKE_CHAR (charname[0]);

  if (*charname >= '0' && *charname < '8')
    {
      /* Dirk:FIXME::  This type of character syntax is not R5RS
       * compliant.  Further, it should be verified that the constant
       * does only consist of octal digits.  Finally, it should be
       * checked whether the resulting fixnum is in the range of
       * characters.  */
      SCM p = scm_c_locale_stringn_to_number (charname, charname_len, 8);
      if (SCM_I_INUMP (p))
	return SCM_MAKE_CHAR (SCM_I_INUM (p));
    }

  for (c = 0; c < scm_n_charnames; c++)
    if (scm_charnames[c]
	&& (!strncasecmp (scm_charnames[c], charname, charname_len)))
      return SCM_MAKE_CHAR (scm_charnums[c]);

 char_error:
  scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",
		     scm_list_1 (scm_from_locale_stringn (charname,
							  charname_len)));

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

static inline SCM
scm_read_keyword (int chr, SCM port)
{
  SCM symbol;

  /* Read the symbol that comprises the keyword.  Doing this instead of
     invoking a specific symbol reader function allows `scm_read_keyword ()'
     to adapt to the delimiters currently valid of symbols.

     XXX: This implementation allows sloppy syntaxes like `#:  key'.  */
  symbol = scm_read_expression (port);
  if (!scm_is_symbol (symbol))
    scm_i_input_error ("scm_read_keyword", port,
		       "keyword prefix `~a' not followed by a symbol: ~s",
		       scm_list_2 (SCM_MAKE_CHAR (chr), symbol));

  return (scm_symbol_to_keyword (symbol));
}

static inline SCM
scm_read_vector (int chr, SCM port)
{
  /* Note: We call `scm_read_sexp ()' rather than READER here in order to
     guarantee that it's going to do what we want.  After all, this is an
     implementation detail of `scm_read_vector ()', not a desirable
     property.  */
  return (scm_vector (scm_read_sexp (chr, port)));
}

static inline SCM
scm_read_srfi4_vector (int chr, SCM port)
{
  return scm_i_read_array (port, chr);
}

static SCM
scm_read_guile_bit_vector (int chr, SCM port)
{
  /* Read the `#*10101'-style read syntax for bit vectors in Guile.  This is
     terribly inefficient but who cares?  */
  SCM s_bits = SCM_EOL;

  for (chr = scm_getc (port);
       (chr != EOF) && ((chr == '0') || (chr == '1'));
       chr = scm_getc (port))
    {
      s_bits = scm_cons ((chr == '0') ? SCM_BOOL_F : SCM_BOOL_T, s_bits);
    }

  if (chr != EOF)
    scm_ungetc (chr, port);

  return scm_bitvector (scm_reverse_x (s_bits, SCM_EOL));
}

static inline SCM
scm_read_scsh_block_comment (int chr, SCM port)
{
  int bang_seen = 0;

  for (;;)
    {
      int c = scm_getc (port);

      if (c == EOF)
	scm_i_input_error ("skip_block_comment", port,
			   "unterminated `#! ... !#' comment", SCM_EOL);

      if (c == '!')
	bang_seen = 1;
      else if (c == '#' && bang_seen)
	break;
      else
	bang_seen = 0;
    }

  return SCM_UNSPECIFIED;
}

static SCM
scm_read_extended_symbol (int chr, SCM port)
{
  /* Guile's extended symbol read syntax looks like this:

       #{This is all a symbol name}#

     So here, CHR is expected to be `{'.  */
  SCM result;
  int saw_brace = 0, finished = 0;
  size_t len = 0;
  char buf[1024];

  result = scm_c_make_string (0, SCM_MAKE_CHAR ('X'));

  while ((chr = scm_getc (port)) != EOF)
    {
      if (saw_brace)
	{
	  if (chr == '#')
	    {
	      finished = 1;
	      break;
	    }
	  else
	    {
	      saw_brace = 0;
	      buf[len++] = '}';
	      buf[len++] = chr;
	    }
	}
      else if (chr == '}')
	saw_brace = 1;
      else
	buf[len++] = chr;

      if (len >= sizeof (buf) - 2)
	{
	  scm_string_append (scm_list_2 (result,
					 scm_from_locale_stringn (buf, len)));
	  len = 0;
	}

      if (finished)
	break;
    }

  if (len)
    result = scm_string_append (scm_list_2
				(result,
				 scm_from_locale_stringn (buf, len)));

  return (scm_string_to_symbol (result));
}

/* Top-level token readers, i.e., dispatchers.  */

static SCM
scm_read_sharp_extension (int chr, SCM port)
{
  SCM proc;

  proc = scm_get_hash_procedure (chr);
  if (scm_is_true (scm_procedure_p (proc)))
    {
      long line = SCM_LINUM (port);
      int column = SCM_COL (port) - 2;
      SCM got;

      got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
      if (!scm_is_eq (got, SCM_UNSPECIFIED))
	{
	  if (SCM_RECORD_POSITIONS_P)
	    return (recsexpr (got, line, column,
			      SCM_FILENAME (port)));
	  else
	    return got;
	}
    }

  return SCM_UNSPECIFIED;
}

/* The reader for the sharp `#' character.  It basically dispatches reads
   among the above token readers.   */
static SCM
scm_read_sharp (int chr, SCM port)
#define FUNC_NAME "scm_lreadr"
{
  SCM result;

  chr = scm_getc (port);

  result = scm_read_sharp_extension (chr, port);
  if (!scm_is_eq (result, SCM_UNSPECIFIED))
    return result;

  switch (chr)
    {
    case '\\':
      return (scm_read_character (chr, port));
    case '(':
      return (scm_read_vector (chr, port));
    case 's':
    case 'u':
    case 'f':
      /* This one may return either a boolean or an SRFI-4 vector.  */
      return (scm_read_srfi4_vector (chr, port));
    case '*':
      return (scm_read_guile_bit_vector (chr, port));
    case 't':
    case 'T':
    case 'F':
      /* This one may return either a boolean or an SRFI-4 vector.  */
      return (scm_read_boolean (chr, port));
    case ':':
      return (scm_read_keyword (chr, port));
    case '0': case '1': case '2': case '3': case '4':
    case '5': case '6': case '7': case '8': case '9':
    case '@':
#if SCM_ENABLE_DEPRECATED
      /* See below for 'i' and 'e'. */
    case 'a':
    case 'c':
    case 'y':
    case 'h':
    case 'l':
#endif
      return (scm_i_read_array (port, chr));

    case 'i':
    case 'e':
#if SCM_ENABLE_DEPRECATED
      {
	/* When next char is '(', it really is an old-style
	   uniform array. */
	int next_c = scm_getc (port);
	if (next_c != EOF)
	  scm_ungetc (next_c, port);
	if (next_c == '(')
	  return scm_i_read_array (port, chr);
	/* Fall through. */
      }
#endif
    case 'b':
    case 'B':
    case 'o':
    case 'O':
    case 'd':
    case 'D':
    case 'x':
    case 'X':
    case 'I':
    case 'E':
      return (scm_read_number_and_radix (chr, port));
    case '{':
      return (scm_read_extended_symbol (chr, port));
    case '!':
      return (scm_read_scsh_block_comment (chr, port));
    default:
      result = scm_read_sharp_extension (chr, port);
      if (scm_is_eq (result, SCM_UNSPECIFIED))
	scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S",
			   scm_list_1 (SCM_MAKE_CHAR (chr)));
      else
	return result;
    }

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

static SCM
scm_read_expression (SCM port)
#define FUNC_NAME "scm_read_expression"
{
  while (1)
    {
      register int chr;

      chr = scm_getc (port);

      switch (chr)
	{
	case SCM_WHITE_SPACES:
	case SCM_LINE_INCREMENTORS:
	  break;
	case ';':
	  (void) scm_read_semicolon_comment (chr, port);
	  break;
	case '(':
	  return (scm_read_sexp (chr, port));
	case '"':
	  return (scm_read_string (chr, port));
	case '\'':
	case '`':
	case ',':
	  return (scm_read_quote (chr, port));
	case '#':
	  {
	    SCM result;
	    result = scm_read_sharp (chr, port);
	    if (scm_is_eq (result, SCM_UNSPECIFIED))
	      /* We read a comment or some such.  */
	      break;
	    else
	      return result;
	  }
	case ')':
	  scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL);
	  break;
	case EOF:
	  return SCM_EOF_VAL;
	case ':':
	  if (scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix))
	    return scm_symbol_to_keyword (scm_read_expression (port));
	  /* Fall through.  */

	default:
	  {
	    if (((chr >= '0') && (chr <= '9'))
		|| (strchr ("+-.", chr)))
	      return (scm_read_number (chr, port));
	    else
	      return (scm_read_mixed_case_symbol (chr, port));
	  }
	}
    }
}
#undef FUNC_NAME

/* Actual reader.  */

SCM_DEFINE (scm_read, "read", 0, 1, 0,
            (SCM port),
	    "Read an s-expression from the input port @var{port}, or from\n"
	    "the current input port if @var{port} is not specified.\n"
	    "Any whitespace before the next token is discarded.")
#define FUNC_NAME s_scm_read
{
  int c;

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

  c = flush_ws (port, (char *) NULL);
  if (EOF == c)
    return SCM_EOF_VAL;
  scm_ungetc (c, port);

  return (scm_read_expression (port));
}
#undef FUNC_NAME

/* Used when recording expressions constructed by `scm_read_sharp ()'.  */
static SCM
recsexpr (SCM obj, long line, int column, SCM filename)
{
  if (!scm_is_pair(obj)) {
    return obj;
  } else {
    SCM tmp = obj, copy;
    /* If this sexpr is visible in the read:sharp source, we want to
       keep that information, so only record non-constant cons cells
       which haven't previously been read by the reader. */
    if (scm_is_false (scm_whash_lookup (scm_source_whash, obj)))
      {
	if (SCM_COPY_SOURCE_P)
	  {
	    copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
			     SCM_UNDEFINED);
	    while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
	      {
		SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
						      line,
						      column,
						      filename),
					    SCM_UNDEFINED));
		copy = SCM_CDR (copy);
	      }
	    SCM_SETCDR (copy, tmp);
	  }
	else
	  {
	    recsexpr (SCM_CAR (obj), line, column, filename);
	    while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
	      recsexpr (SCM_CAR (tmp), line, column, filename);
	    copy = SCM_UNDEFINED;
	  }
	scm_whash_insert (scm_source_whash,
			  obj,
			  scm_make_srcprops (line,
					     column,
					     filename,
					     copy,
					     SCM_EOL));
      }
    return obj;
  }
}

/* Manipulate the read-hash-procedures alist.  This could be written in
   Scheme, but maybe it will also be used by C code during initialisation.  */
SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,
            (SCM chr, SCM proc),
	    "Install the procedure @var{proc} for reading expressions\n"
	    "starting with the character sequence @code{#} and @var{chr}.\n"
	    "@var{proc} will be called with two arguments:  the character\n"
	    "@var{chr} and the port to read further data from. The object\n"
	    "returned will be the return value of @code{read}.")
#define FUNC_NAME s_scm_read_hash_extend
{
  SCM this;
  SCM prev;

  SCM_VALIDATE_CHAR (1, chr);
  SCM_ASSERT (scm_is_false (proc)
	      || scm_is_eq (scm_procedure_p (proc), SCM_BOOL_T),
	      proc, SCM_ARG2, FUNC_NAME);

  /* Check if chr is already in the alist.  */
  this = *scm_read_hash_procedures;
  prev = SCM_BOOL_F;
  while (1)
    {
      if (scm_is_null (this))
	{
	  /* not found, so add it to the beginning.  */
	  if (scm_is_true (proc))
	    {
	      *scm_read_hash_procedures =
		scm_cons (scm_cons (chr, proc), *scm_read_hash_procedures);
	    }
	  break;
	}
      if (scm_is_eq (chr, SCM_CAAR (this)))
	{
	  /* already in the alist.  */
	  if (scm_is_false (proc))
	    {
	      /* remove it.  */
	      if (scm_is_false (prev))
		{
		  *scm_read_hash_procedures =
		    SCM_CDR (*scm_read_hash_procedures);
		}
	      else
		scm_set_cdr_x (prev, SCM_CDR (this));
	    }
	  else
	    {
	      /* replace it.  */
	      scm_set_cdr_x (SCM_CAR (this), proc);
	    }
	  break;
	}
      prev = this;
      this = SCM_CDR (this);
    }

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* Recover the read-hash procedure corresponding to char c.  */
static SCM
scm_get_hash_procedure (int c)
{
  SCM rest = *scm_read_hash_procedures;

  while (1)
    {
      if (scm_is_null (rest))
	return SCM_BOOL_F;

      if (SCM_CHAR (SCM_CAAR (rest)) == c)
	return SCM_CDAR (rest);

      rest = SCM_CDR (rest);
    }
}

void
scm_init_read ()
{
  scm_read_hash_procedures =
    SCM_VARIABLE_LOC (scm_c_define ("read-hash-procedures", SCM_EOL));

  scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS);
#include "libguile/read.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_READ_H
#define SCM_READ_H

/* Copyright (C) 1995,1996,2000, 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 2.1 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"

#include "libguile/options.h"

/* SCM_LINE_INCREMENTORS are the characters which cause the line count to
 * be incremented for the purposes of error reporting.  This feature
 * is only used for scheme code loaded from files.
 *
 * SCM_WHITE_SPACES are other characters which should be treated like spaces
 * in programs.
 */

#define SCM_LINE_INCREMENTORS  '\n'

#ifdef MSDOS
# define SCM_SINGLE_SPACES  ' ':case '\r':case '\f': case 26
#else
# define SCM_SINGLE_SPACES  ' ':case '\r':case '\f'
#endif

#define SCM_WHITE_SPACES  SCM_SINGLE_SPACES: case '\t'

SCM_API scm_t_option scm_read_opts[];

#define SCM_COPY_SOURCE_P      scm_read_opts[0].val
#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val
#define SCM_CASE_INSENSITIVE_P scm_read_opts[2].val
#define SCM_KEYWORD_STYLE      scm_read_opts[3].val
#if SCM_ENABLE_ELISP
#define SCM_ELISP_VECTORS_P    scm_read_opts[4].val
#define SCM_ESCAPED_PARENS_P   scm_read_opts[5].val
#define SCM_N_READ_OPTIONS 6
#else
#define SCM_N_READ_OPTIONS 4
#endif

SCM_API SCM scm_sym_dot;

SCM_API SCM scm_read_options (SCM setting);
SCM_API SCM scm_read (SCM port);
SCM_API size_t scm_read_token (int ic, SCM * tok_buf, SCM port, int weird);
SCM_API SCM scm_read_hash_extend (SCM chr, SCM proc);

SCM_API void scm_i_input_error (const char *func, SCM port,
				const char *message, SCM arg)
  SCM_NORETURN;

SCM_API void scm_init_read (void);

#endif  /* SCM_READ_H */

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


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

/* regex-posix.c -- POSIX regular expression support.

   This code was written against Henry Spencer's famous regex package.
   The principal reference for POSIX behavior was the man page for this
   library, not the 1003.2 document itself.  Ergo, other `POSIX'
   libraries which do not agree with the Spencer implementation may
   produce varying behavior.  Sigh. */

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

#include <sys/types.h>

#include "libguile/_scm.h"

/* Supposedly, this file is never compiled unless we know we have
   POSIX regular expressions.  But we still put this in an #ifdef so
   the file is CPP'able (for dependency scanning) even on systems that
   don't have a <regex.h> header.  */
#ifdef HAVE_REGCOMP
#ifdef HAVE_REGEX_H
#include <regex.h>
#else
#ifdef HAVE_RXPOSIX_H
#include <rxposix.h>		/* GNU Rx library */
#else
#ifdef HAVE_RX_RXPOSIX_H
#include <rx/rxposix.h>		/* GNU Rx library on Linux */
#endif
#endif
#endif
#endif

#include "libguile/async.h"
#include "libguile/smob.h"
#include "libguile/symbols.h"
#include "libguile/vectors.h"
#include "libguile/strports.h"
#include "libguile/ports.h"
#include "libguile/feature.h"
#include "libguile/strings.h"

#include "libguile/validate.h"
#include "libguile/regex-posix.h"

/* This is defined by some regex libraries and omitted by others. */
#ifndef REG_BASIC
#define REG_BASIC 0
#endif

scm_t_bits scm_tc16_regex;

static size_t
regex_free (SCM obj)
{
  regfree (SCM_RGX (obj));
  scm_gc_free (SCM_RGX (obj), sizeof(regex_t), "regex");
  return 0;
}

SCM_SYMBOL (scm_regexp_error_key, "regular-expression-syntax");

static SCM
scm_regexp_error_msg (int regerrno, regex_t *rx)
{
  char *errmsg;
  int l;

  errmsg = scm_malloc (80);
  l = regerror (regerrno, rx, errmsg, 80);
  if (l > 80)
    {
      free (errmsg);
      errmsg = scm_malloc (l);
      regerror (regerrno, rx, errmsg, l);
    }
  return scm_take_locale_string (errmsg);
}

SCM_DEFINE (scm_regexp_p, "regexp?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a compiled regular expression,\n"
	    "or @code{#f} otherwise.")
#define FUNC_NAME s_scm_regexp_p
{
  return scm_from_bool(SCM_RGXP (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1,
            (SCM pat, SCM flags),
	    "Compile the regular expression described by @var{pat}, and\n"
	    "return the compiled regexp structure.  If @var{pat} does not\n"
	    "describe a legal regular expression, @code{make-regexp} throws\n"
	    "a @code{regular-expression-syntax} error.\n"
	    "\n"
	    "The @var{flags} arguments change the behavior of the compiled\n"
	    "regular expression.  The following flags may be supplied:\n"
	    "\n"
	    "@table @code\n"
	    "@item regexp/icase\n"
	    "Consider uppercase and lowercase letters to be the same when\n"
	    "matching.\n"
	    "@item regexp/newline\n"
	    "If a newline appears in the target string, then permit the\n"
	    "@samp{^} and @samp{$} operators to match immediately after or\n"
	    "immediately before the newline, respectively.  Also, the\n"
	    "@samp{.} and @samp{[^...]} operators will never match a newline\n"
	    "character.  The intent of this flag is to treat the target\n"
	    "string as a buffer containing many lines of text, and the\n"
	    "regular expression as a pattern that may match a single one of\n"
	    "those lines.\n"
	    "@item regexp/basic\n"
	    "Compile a basic (``obsolete'') regexp instead of the extended\n"
	    "(``modern'') regexps that are the default.  Basic regexps do\n"
	    "not consider @samp{|}, @samp{+} or @samp{?} to be special\n"
	    "characters, and require the @samp{@{...@}} and @samp{(...)}\n"
	    "metacharacters to be backslash-escaped (@pxref{Backslash\n"
	    "Escapes}).  There are several other differences between basic\n"
	    "and extended regular expressions, but these are the most\n"
	    "significant.\n"
	    "@item regexp/extended\n"
	    "Compile an extended regular expression rather than a basic\n"
	    "regexp.  This is the default behavior; this flag will not\n"
	    "usually be needed.  If a call to @code{make-regexp} includes\n"
	    "both @code{regexp/basic} and @code{regexp/extended} flags, the\n"
	    "one which comes last will override the earlier one.\n"
	    "@end table")
#define FUNC_NAME s_scm_make_regexp
{
  SCM flag;
  regex_t *rx;
  int status, cflags;
  char *c_pat;

  SCM_VALIDATE_STRING (1, pat);
  SCM_VALIDATE_REST_ARGUMENT (flags);

  /* Examine list of regexp flags.  If REG_BASIC is supplied, then
     turn off REG_EXTENDED flag (on by default). */
  cflags = REG_EXTENDED;
  flag = flags;
  while (!scm_is_null (flag))
    {
      if (scm_to_int (SCM_CAR (flag)) == REG_BASIC)
	cflags &= ~REG_EXTENDED;
      else
	cflags |= scm_to_int (SCM_CAR (flag));
      flag = SCM_CDR (flag);
    }

  rx = scm_gc_malloc (sizeof(regex_t), "regex");
  c_pat = scm_to_locale_string (pat);
  status = regcomp (rx, c_pat,
		    /* Make sure they're not passing REG_NOSUB;
                       regexp-exec assumes we're getting match data.  */
		    cflags & ~REG_NOSUB);
  free (c_pat);
  if (status != 0)
    {
      SCM errmsg = scm_regexp_error_msg (status, rx);
      scm_gc_free (rx, sizeof(regex_t), "regex");
      scm_error_scm (scm_regexp_error_key,
		     scm_from_locale_string (FUNC_NAME),
		     errmsg,
		     SCM_BOOL_F,
		     scm_list_1 (pat));

      /* never returns */
    }
  SCM_RETURN_NEWSMOB (scm_tc16_regex, rx);
}
#undef FUNC_NAME

SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0,
            (SCM rx, SCM str, SCM start, SCM flags),
	    "Match the compiled regular expression @var{rx} against\n"
	    "@code{str}.  If the optional integer @var{start} argument is\n"
	    "provided, begin matching from that position in the string.\n"
	    "Return a match structure describing the results of the match,\n"
	    "or @code{#f} if no match could be found.\n"
            "\n"
            "The @var{flags} arguments change the matching behavior.\n"
            "The following flags may be supplied:\n"
	    "\n"
	    "@table @code\n"
	    "@item regexp/notbol\n"
            "Operator @samp{^} always fails (unless @code{regexp/newline}\n"
            "is used).  Use this when the beginning of the string should\n"
            "not be considered the beginning of a line.\n"
	    "@item regexp/noteol\n"
            "Operator @samp{$} always fails (unless @code{regexp/newline}\n"
            "is used).  Use this when the end of the string should not be\n"
            "considered the end of a line.\n"
            "@end table")
#define FUNC_NAME s_scm_regexp_exec
{
  /* We used to have an SCM_DEFER_INTS, and then later an
     SCM_CRITICAL_SECTION_START, around the regexec() call.  Can't quite
     remember what defer ints was for, but a critical section would only be
     wanted now if we think regexec() is not thread-safe.  The posix spec

     http://www.opengroup.org/onlinepubs/009695399/functions/regcomp.html

     reads like regexec is meant to be both thread safe and reentrant
     (mentioning simultaneous use in threads, and in signal handlers).  So
     for now believe no protection needed.  */

  int status, nmatches, offset;
  regmatch_t *matches;
  char *c_str;
  SCM mvec = SCM_BOOL_F;
  SCM substr;

  SCM_VALIDATE_RGXP (1, rx);
  SCM_VALIDATE_STRING (2, str);

  if (SCM_UNBNDP (start))
    {
      substr = str;
      offset = 0;
    }
  else
    {
      substr = scm_substring (str, start, SCM_UNDEFINED);
      offset = scm_to_int (start);
    }

  if (SCM_UNBNDP (flags))
    flags = SCM_INUM0;

  /* re_nsub doesn't account for the `subexpression' representing the
     whole regexp, so add 1 to nmatches. */

  nmatches = SCM_RGX(rx)->re_nsub + 1;
  matches = scm_malloc (sizeof (regmatch_t) * nmatches);
  c_str = scm_to_locale_string (substr);
  status = regexec (SCM_RGX (rx), c_str, nmatches, matches,
		    scm_to_int (flags));
  free (c_str);

  if (!status)
    {
      int i;
      /* The match vector must include a cell for the string that was matched,
	 so add 1. */
      mvec = scm_c_make_vector (nmatches + 1, SCM_UNSPECIFIED);
      SCM_SIMPLE_VECTOR_SET(mvec,0, str);
      for (i = 0; i < nmatches; ++i)
	if (matches[i].rm_so == -1)
	  SCM_SIMPLE_VECTOR_SET(mvec, i+1,
			 scm_cons (scm_from_int (-1), scm_from_int (-1)));
	else
	  SCM_SIMPLE_VECTOR_SET(mvec, i+1,
			 scm_cons (scm_from_long (matches[i].rm_so + offset),
				   scm_from_long (matches[i].rm_eo + offset)));
    }
  free (matches);

  if (status != 0 && status != REG_NOMATCH)
    scm_error_scm (scm_regexp_error_key,
		   scm_from_locale_string (FUNC_NAME),
		   scm_regexp_error_msg (status, SCM_RGX (rx)),
		   SCM_BOOL_F, SCM_BOOL_F);
  return mvec;
}
#undef FUNC_NAME

void
scm_init_regex_posix ()
{
  scm_tc16_regex = scm_make_smob_type ("regexp", sizeof (regex_t));
  scm_set_smob_free (scm_tc16_regex, regex_free);

  /* Compilation flags.  */
  scm_c_define ("regexp/basic",    scm_from_int (REG_BASIC));
  scm_c_define ("regexp/extended", scm_from_int (REG_EXTENDED));
  scm_c_define ("regexp/icase",    scm_from_int (REG_ICASE));
  scm_c_define ("regexp/newline",  scm_from_int (REG_NEWLINE));

  /* Execution flags.  */
  scm_c_define ("regexp/notbol", scm_from_int (REG_NOTBOL));
  scm_c_define ("regexp/noteol", scm_from_int (REG_NOTEOL));

#include "libguile/regex-posix.x"

  scm_add_feature ("regex");
}

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


code:
/* classes: h_files */

#ifndef SCM_REGEX_POSIX_H
#define SCM_REGEX_POSIX_H

/* Copyright (C) 1997,1998,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 2.1 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_t_bits scm_tc16_regex;
#define SCM_RGX(X)	((regex_t *) SCM_SMOB_DATA (X))
#define SCM_RGXP(X)	(SCM_SMOB_PREDICATE (scm_tc16_regex, (X)))

SCM_API SCM scm_make_regexp (SCM pat, SCM flags);
SCM_API SCM scm_regexp_p (SCM x);
SCM_API SCM scm_regexp_exec (SCM rx, SCM str, SCM start, SCM flags);
SCM_API void scm_init_regex_posix (void);

#endif  /* SCM_REGEX_POSIX_H */

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


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 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 2.1 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 <string.h>
#include <stdio.h>

#include "libguile/_scm.h"
#include "libguile/stackchk.h"
#include "libguile/dynwind.h"
#include "libguile/eval.h"
#include "libguile/smob.h"
#include "libguile/pairs.h"
#include "libguile/throw.h"
#include "libguile/fluids.h"
#include "libguile/ports.h"

#include "libguile/root.h"

SCM scm_sys_protects[SCM_NUM_PROTECTS];

/* {call-with-dynamic-root}
 *
 * Suspending the current thread to evaluate a thunk on the
 * same C stack but under a new root.
 *
 * Calls to call-with-dynamic-root return exactly once (unless
 * the process is somehow exitted).  */

/* cwdr fills out both of these structures, and then passes a pointer
   to them through scm_internal_catch to the cwdr_body and
   cwdr_handler functions, to tell them how to behave and to get
   information back from them.

   A cwdr is a lot like a catch, except there is no tag (all
   exceptions are caught), and the body procedure takes the arguments
   passed to cwdr as A1 and ARGS.  The handler is also special since
   it is not directly run from scm_internal_catch.  It is executed
   outside the new dynamic root. */

struct cwdr_body_data {
  /* Arguments to pass to the cwdr body function.  */
  SCM a1, args;

  /* Scheme procedure to use as body of cwdr.  */
  SCM body_proc;
};

struct cwdr_handler_data {
  /* Do we need to run the handler? */
  int run_handler;

  /* The tag and args to pass it. */
  SCM tag, args;
};

/* Invoke the body of a cwdr, assuming that the throw handler has
   already been set up.  DATA points to a struct set up by cwdr that
   says what proc to call, and what args to apply it to.

   With a little thought, we could replace this with scm_body_thunk,
   but I don't want to mess with that at the moment.  */
static SCM
cwdr_body (void *data)
{
  struct cwdr_body_data *c = (struct cwdr_body_data *) data;

  return scm_apply (c->body_proc, c->a1, c->args);
}

/* Record the fact that the body of the cwdr has thrown.  Record
   enough information to invoke the handler later when the dynamic
   root has been deestablished.  */

static SCM
cwdr_handler (void *data, SCM tag, SCM args)
{
  struct cwdr_handler_data *c = (struct cwdr_handler_data *) data;

  c->run_handler = 1;
  c->tag = tag;
  c->args = args;
  return SCM_UNSPECIFIED;
}

SCM
scm_internal_cwdr (scm_t_catch_body body, void *body_data,
		   scm_t_catch_handler handler, void *handler_data,
		   SCM_STACKITEM *stack_start)
{
  struct cwdr_handler_data my_handler_data;
  SCM answer, old_winds;

  /* Exit caller's dynamic state.
   */
  old_winds = scm_i_dynwinds ();
  scm_dowinds (SCM_EOL, scm_ilength (old_winds));

  scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
  scm_dynwind_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED));

  my_handler_data.run_handler = 0;
  answer = scm_i_with_continuation_barrier (body, body_data,
					    cwdr_handler, &my_handler_data,
					    NULL, NULL);

  scm_dynwind_end ();

  /* Enter caller's dynamic state.
   */
  scm_dowinds (old_winds, - scm_ilength (old_winds));

  /* Now run the real handler iff the body did a throw. */
  if (my_handler_data.run_handler)
    return handler (handler_data, my_handler_data.tag, my_handler_data.args);
  else
    return answer;
}

/* The original CWDR for invoking Scheme code with a Scheme handler. */

static SCM
cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)
{
  struct cwdr_body_data c;

  c.a1 = a1;
  c.args = args;
  c.body_proc = proc;

  return scm_internal_cwdr (cwdr_body, &c,
			    scm_handle_by_proc, &handler,
			    stack_start);
}

SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
           (SCM thunk, SCM handler),
	    "Call @var{thunk} with a new dynamic state and within"
	    "a continuation barrier.  The @var{handler} catches all"
	    "otherwise uncaught throws and executes within the same"
	    "dynamic context as @var{thunk}.")
#define FUNC_NAME s_scm_call_with_dynamic_root
{
  SCM_STACKITEM stack_place;
  return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
}
#undef FUNC_NAME

SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0,
           (),
	    "Return an object representing the current dynamic root.\n\n"
	    "These objects are only useful for comparison using @code{eq?}.\n")
#define FUNC_NAME s_scm_dynamic_root
{
  return SCM_I_CURRENT_THREAD->continuation_root;
}
#undef FUNC_NAME

SCM
scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
{
  SCM_STACKITEM stack_place;
  return cwdr (proc, a1, args, handler, &stack_place);
}

void
scm_init_root ()
{
#include "libguile/root.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_ROOT_H
#define SCM_ROOT_H

/* Copyright (C) 1996,1998,2000,2001, 2002, 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 2.1 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"
#include "libguile/debug.h"
#include "libguile/throw.h"

#define scm_flo0 scm_sys_protects[0]
#define scm_listofnull scm_sys_protects[1]
#define scm_nullvect scm_sys_protects[2]
#define scm_nullstr scm_sys_protects[3]
#define scm_keyword_obarray scm_sys_protects[4]
#define scm_stand_in_procs scm_sys_protects[5]
#define scm_object_whash scm_sys_protects[6]
#define scm_permobjs scm_sys_protects[7]
#define scm_asyncs scm_sys_protects[8]
#define scm_protects scm_sys_protects[9]
#define scm_properties_whash scm_sys_protects[10]
#define scm_gc_registered_roots scm_sys_protects[11]
#define scm_source_whash scm_sys_protects[12]
#define SCM_NUM_PROTECTS 13

SCM_API SCM scm_sys_protects[];

SCM_API SCM scm_internal_cwdr (scm_t_catch_body body,
			       void *body_data,
			       scm_t_catch_handler handler,
			       void *handler_data,
			       SCM_STACKITEM *stack_start);
SCM_API SCM scm_call_with_dynamic_root (SCM thunk, SCM handler);
SCM_API SCM scm_dynamic_root (void);
SCM_API SCM scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler);
SCM_API void scm_init_root (void);

#endif  /* SCM_ROOT_H */

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


code:
#!/bin/sh -
# Run the guile-test script using the guile binary from this directory
cd ../test-suite
../libguile/guile -e main -s guile-test "$@"

path: libguile/run-test


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

/* This is the C part of the (ice-9 rw) module.  */

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

#include <errno.h>
#include <string.h>

#include "libguile/_scm.h"
#include "libguile/fports.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/rw.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/modules.h"
#include "libguile/strports.h"

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef HAVE_IO_H
#include <io.h>
#endif

#if defined (EAGAIN)
#define SCM_MAYBE_EAGAIN || errno == EAGAIN
#else
#define SCM_MAYBE_EAGAIN
#endif

#if defined (EWOULDBLOCK)
#define SCM_MAYBE_EWOULDBLOCK || errno == EWOULDBLOCK
#else
#define SCM_MAYBE_EWOULDBLOCK
#endif

/* MAYBE there is EAGAIN way of defining this macro but now I EWOULDBLOCK.  */
#define SCM_EBLOCK(errno) \
   (0 SCM_MAYBE_EAGAIN SCM_MAYBE_EWOULDBLOCK)

SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
	    (SCM str, SCM port_or_fdes, SCM start, SCM end),
	    "Read characters from a port or file descriptor into a\n"
	    "string @var{str}.  A port must have an underlying file\n"
	    "descriptor --- a so-called fport.  This procedure is\n"
	    "scsh-compatible and can efficiently read large strings.\n"
	    "It will:\n\n"
	    "@itemize\n"
	    "@item\n"
	    "attempt to fill the entire string, unless the @var{start}\n"
	    "and/or @var{end} arguments are supplied.  i.e., @var{start}\n"
	    "defaults to 0 and @var{end} defaults to\n"
	    "@code{(string-length str)}\n"
	    "@item\n"
	    "use the current input port if @var{port_or_fdes} is not\n"
	    "supplied.\n"
	    "@item\n"
	    "return fewer than the requested number of characters in some\n"
	    "cases, e.g., on end of file, if interrupted by a signal, or if\n"
	    "not all the characters are immediately available.\n"
	    "@item\n"
	    "wait indefinitely for some input if no characters are\n"
	    "currently available,\n"
	    "unless the port is in non-blocking mode.\n"
	    "@item\n"
	    "read characters from the port's input buffers if available,\n"
	    "instead from the underlying file descriptor.\n"
	    "@item\n"
	    "return @code{#f} if end-of-file is encountered before reading\n"
            "any characters, otherwise return the number of characters\n"
	    "read.\n"
	    "@item\n"
	    "return 0 if the port is in non-blocking mode and no characters\n"
	    "are immediately available.\n"
	    "@item\n"
	    "return 0 if the request is for 0 bytes, with no\n"
	    "end-of-file check.\n"
	    "@end itemize")
#define FUNC_NAME s_scm_read_string_x_partial
{
  char *dest;
  size_t offset;
  long read_len;
  long chars_read = 0;
  int fdes;

  {
    size_t last;

    SCM_VALIDATE_STRING (1, str);
    scm_i_get_substring_spec (scm_i_string_length (str),
			      start, &offset, end, &last);
    read_len = last - offset;
  }

  if (scm_is_integer (port_or_fdes))
    fdes = scm_to_int (port_or_fdes);
  else
    {
      SCM port = (SCM_UNBNDP (port_or_fdes)?
		  scm_current_input_port () : port_or_fdes);

      SCM_VALIDATE_OPFPORT (2, port);
      SCM_VALIDATE_INPUT_PORT (2, port);

      /* if there's anything in the port buffers, use it, but then
	 don't touch the file descriptor.  otherwise the
	 "return immediately if something is available" rule may
	 be violated.  */
      dest = scm_i_string_writable_chars (str) + offset;
      chars_read = scm_take_from_input_buffers (port, dest, read_len);
      scm_i_string_stop_writing ();
      fdes = SCM_FPORT_FDES (port);
    }

  if (chars_read == 0 && read_len > 0) /* don't confuse read_len == 0 with
					  EOF.  */
    {
      dest = scm_i_string_writable_chars (str) + offset;
      SCM_SYSCALL (chars_read = read (fdes, dest, read_len));
      scm_i_string_stop_writing ();
      if (chars_read == -1)
	{
	  if (SCM_EBLOCK (errno))
	    chars_read = 0;
	  else
	    SCM_SYSERROR;
        }
      else if (chars_read == 0)
	{
	  scm_remember_upto_here_1 (str);
	  return SCM_BOOL_F;
	}
    }

  scm_remember_upto_here_1 (str);
  return scm_from_long (chars_read);
}
#undef FUNC_NAME

SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0,
	    (SCM str, SCM port_or_fdes, SCM start, SCM end),
	    "Write characters from a string @var{str} to a port or file\n"
	    "descriptor.  A port must have an underlying file descriptor\n"
	    "--- a so-called fport.  This procedure is\n"
	    "scsh-compatible and can efficiently write large strings.\n"
	    "It will:\n\n"
	    "@itemize\n"
	    "@item\n"
	    "attempt to write the entire string, unless the @var{start}\n"
	    "and/or @var{end} arguments are supplied.  i.e., @var{start}\n"
	    "defaults to 0 and @var{end} defaults to\n"
	    "@code{(string-length str)}\n"
	    "@item\n"
	    "use the current output port if @var{port_of_fdes} is not\n"
	    "supplied.\n"
	    "@item\n"
	    "in the case of a buffered port, store the characters in the\n"
	    "port's output buffer, if all will fit.  If they will not fit\n"
	    "then any existing buffered characters will be flushed\n"
	    "before attempting\n"
	    "to write the new characters directly to the underlying file\n"
	    "descriptor.  If the port is in non-blocking mode and\n"
	    "buffered characters can not be flushed immediately, then an\n"
	    "@code{EAGAIN} system-error exception will be raised (Note:\n"
	    "scsh does not support the use of non-blocking buffered ports.)\n"
	    "@item\n"
	    "write fewer than the requested number of\n"
	    "characters in some cases, e.g., if interrupted by a signal or\n"
	    "if not all of the output can be accepted immediately.\n"
	    "@item\n"
	    "wait indefinitely for at least one character\n"
	    "from @var{str} to be accepted by the port, unless the port is\n"
	    "in non-blocking mode.\n"
	    "@item\n"
	    "return the number of characters accepted by the port.\n"
	    "@item\n"
	    "return 0 if the port is in non-blocking mode and can not accept\n"
	    "at least one character from @var{str} immediately\n"
	    "@item\n"
	    "return 0 immediately if the request size is 0 bytes.\n"
	    "@end itemize")
#define FUNC_NAME s_scm_write_string_partial
{
  const char *src;
  long write_len;
  int fdes;

  {
    size_t offset;
    size_t last;

    SCM_VALIDATE_STRING (1, str);
    src = scm_i_string_chars (str);
    scm_i_get_substring_spec (scm_i_string_length (str),
			      start, &offset, end, &last);
    src += offset;
    write_len = last - offset;
  }

  if (write_len == 0)
    return SCM_INUM0;

  if (scm_is_integer (port_or_fdes))
    fdes = scm_to_int (port_or_fdes);
  else
    {
      SCM port = (SCM_UNBNDP (port_or_fdes)?
		  scm_current_output_port () : port_or_fdes);
      scm_t_port *pt;
      off_t space;

      SCM_VALIDATE_OPFPORT (2, port);
      SCM_VALIDATE_OUTPUT_PORT (2, port);
      pt = SCM_PTAB_ENTRY (port);
      /* filling the last character in the buffer would require a flush.  */
      space = pt->write_end - pt->write_pos - 1;
      if (space >= write_len)
	{
	  memcpy (pt->write_pos, src, write_len);
	  pt->write_pos += write_len;
	  return scm_from_long (write_len);
	}
      if (pt->write_pos > pt->write_buf)
	scm_flush (port);
      fdes = SCM_FPORT_FDES (port);
    }
  {
    long rv;

    SCM_SYSCALL (rv = write (fdes, src, write_len));
    if (rv == -1)
      {
	if (SCM_EBLOCK (errno))
	  rv = 0;
	else
	  SCM_SYSERROR;
      }

    scm_remember_upto_here_1 (str);
    return scm_from_long (rv);
  }
}
#undef FUNC_NAME

SCM
scm_init_rw_builtins ()
{
#include "libguile/rw.x"

  return SCM_UNSPECIFIED;
}

void
scm_init_rw ()
{
  scm_c_define_gsubr ("%init-rw-builtins", 0, 0, 0, scm_init_rw_builtins);
}

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


code:
/* classes: h_files */

#ifndef SCM_RW_H
#define SCM_RW_H

/* Copyright (C) 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 2.1 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_string_x_partial (SCM str, SCM port_or_fdes, SCM start,
				       SCM end);
SCM_API SCM scm_write_string_partial (SCM str, SCM port_or_fdes, SCM start,
				      SCM end);

SCM_API SCM scm_init_rw_builtins (void);
SCM_API void scm_init_rw (void);

#endif  /* SCM_RW_H */

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


code:
/* Copyright (C) 2003, 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 2.1 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
 */